summaryrefslogtreecommitdiff
path: root/lisp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp')
-rw-r--r--lisp/COPYING249
-rw-r--r--lisp/ChangeLog5068
-rw-r--r--lisp/abbrev.el269
-rw-r--r--lisp/abbrev.elcbin0 -> 7437 bytes
-rw-r--r--lisp/abbrevlist.el2
-rw-r--r--lisp/abbrevlist.elcbin0 -> 457 bytes
-rw-r--r--lisp/ada.el175
-rw-r--r--lisp/ada.elcbin0 -> 16382 bytes
-rw-r--r--lisp/add-log.el87
-rw-r--r--lisp/add-log.elcbin0 -> 1552 bytes
-rw-r--r--lisp/array.el957
-rw-r--r--lisp/autoinsert.el8
-rw-r--r--lisp/backquote.el (renamed from lisp/emacs-lisp/backquote.el)70
-rw-r--r--lisp/backquote.elcbin0 -> 3718 bytes
-rw-r--r--lisp/bg-mouse.el (renamed from lisp/term/bg-mouse.el)11
-rw-r--r--lisp/bibtex.el426
-rw-r--r--lisp/bibtex.elcbin0 -> 11087 bytes
-rw-r--r--lisp/blackbox.el229
-rw-r--r--lisp/blackbox.elcbin0 -> 4404 bytes
-rw-r--r--lisp/buff-menu.el59
-rw-r--r--lisp/buff-menu.elcbin0 -> 7306 bytes
-rw-r--r--lisp/bytecomp.el1165
-rw-r--r--lisp/bytecomp.elcbin0 -> 29155 bytes
-rw-r--r--lisp/c-fill.el269
-rw-r--r--lisp/c-fill.elcbin0 -> 3309 bytes
-rw-r--r--lisp/c-mode.el662
-rw-r--r--lisp/c-mode.elcbin0 -> 12459 bytes
-rw-r--r--lisp/cal.el242
-rw-r--r--lisp/cal.elcbin0 -> 5054 bytes
-rw-r--r--lisp/calendar/appt.el500
-rw-r--r--lisp/case-table.el101
-rw-r--r--lisp/chistory.el151
-rw-r--r--lisp/chistory.elcbin0 -> 4185 bytes
-rw-r--r--lisp/cl-indent.el461
-rw-r--r--lisp/cl-indent.elcbin0 -> 5841 bytes
-rw-r--r--lisp/cl.el2018
-rw-r--r--lisp/cl.elcbin0 -> 46948 bytes
-rw-r--r--lisp/cmacexp.el45
-rw-r--r--lisp/comint.el866
-rw-r--r--lisp/compare-w.el59
-rw-r--r--lisp/compare-w.elcbin0 -> 659 bytes
-rw-r--r--lisp/compile.el318
-rw-r--r--lisp/compile.elcbin0 -> 6602 bytes
-rw-r--r--lisp/completion.el3113
-rw-r--r--lisp/dabbrev.el221
-rw-r--r--lisp/dabbrev.elcbin0 -> 3375 bytes
-rw-r--r--lisp/dbx.el165
-rw-r--r--lisp/dbx.elcbin0 -> 4515 bytes
-rw-r--r--lisp/debug.el261
-rw-r--r--lisp/debug.elcbin0 -> 6098 bytes
-rw-r--r--lisp/dired.el633
-rw-r--r--lisp/dired.elcbin0 -> 16161 bytes
-rw-r--r--lisp/disass.el446
-rw-r--r--lisp/disass.elcbin0 -> 6599 bytes
-rw-r--r--lisp/disp-table.el115
-rw-r--r--lisp/dissociate.el (renamed from lisp/play/dissociate.el)6
-rw-r--r--lisp/dissociate.elcbin0 -> 1198 bytes
-rw-r--r--lisp/doctex.el189
-rw-r--r--lisp/doctor.el1614
-rw-r--r--lisp/doctor.elcbin0 -> 43542 bytes
-rw-r--r--lisp/ebuff-menu.el244
-rw-r--r--lisp/ebuff-menu.elcbin0 -> 7038 bytes
-rw-r--r--lisp/echistory.el34
-rw-r--r--lisp/echistory.elcbin0 -> 5590 bytes
-rw-r--r--lisp/edmacro.el640
-rw-r--r--lisp/edt-doc.el106
-rw-r--r--lisp/edt.el (renamed from lisp/emulation/edt.el)53
-rw-r--r--lisp/edt.elcbin0 -> 12296 bytes
-rw-r--r--lisp/ehelp.el133
-rw-r--r--lisp/ehelp.elcbin0 -> 7393 bytes
-rw-r--r--lisp/electric.el9
-rw-r--r--lisp/electric.elcbin0 -> 2376 bytes
-rw-r--r--lisp/emacs-lisp/ring.el101
-rw-r--r--lisp/emacsbug.el (renamed from lisp/mail/emacsbug.el)2
-rw-r--r--lisp/files.el1080
-rw-r--r--lisp/files.elcbin0 -> 31068 bytes
-rw-r--r--lisp/fill.el287
-rw-r--r--lisp/fill.elcbin0 -> 4406 bytes
-rw-r--r--lisp/find-gc.el127
-rw-r--r--lisp/flame.el306
-rw-r--r--lisp/flame.elcbin0 -> 9125 bytes
-rw-r--r--lisp/float-sup.el52
-rw-r--r--lisp/float.el (renamed from lisp/emacs-lisp/float.el)31
-rw-r--r--lisp/float.elcbin0 -> 8128 bytes
-rw-r--r--lisp/fortran.el654
-rw-r--r--lisp/fortran.elc242
-rw-r--r--lisp/ftp.el142
-rw-r--r--lisp/ftp.elcbin0 -> 8730 bytes
-rw-r--r--lisp/gdb.el397
-rw-r--r--lisp/gdb.elcbin0 -> 7626 bytes
-rw-r--r--lisp/gnusmail.el148
-rw-r--r--lisp/gnusmisc.el214
-rw-r--r--lisp/gosmacs.el4
-rw-r--r--lisp/hanoi.el (renamed from lisp/play/hanoi.el)2
-rw-r--r--lisp/hanoi.elcbin0 -> 2236 bytes
-rw-r--r--lisp/help.el295
-rw-r--r--lisp/help.elcbin0 -> 8434 bytes
-rw-r--r--lisp/helper.el (renamed from lisp/emacs-lisp/helper.el)4
-rw-r--r--lisp/helper.elcbin0 -> 3044 bytes
-rw-r--r--lisp/hexl.el659
-rw-r--r--lisp/hideif.el (renamed from lisp/progmodes/hideif.el)144
-rw-r--r--lisp/hideif.elcbin0 -> 17884 bytes
-rw-r--r--lisp/icon.el (renamed from lisp/progmodes/icon.el)90
-rw-r--r--lisp/icon.elcbin0 -> 10882 bytes
-rw-r--r--lisp/inc-vers.el15
-rw-r--r--lisp/indent.el225
-rw-r--r--lisp/indent.elcbin0 -> 4961 bytes
-rw-r--r--lisp/info.el708
-rw-r--r--lisp/info.elcbin0 -> 16140 bytes
-rw-r--r--lisp/informat.el411
-rw-r--r--lisp/informat.elcbin0 -> 6734 bytes
-rw-r--r--lisp/isearch.el385
-rw-r--r--lisp/isearch.elcbin0 -> 4780 bytes
-rw-r--r--lisp/kermit.el86
-rw-r--r--lisp/keypad.el152
-rw-r--r--lisp/keypad.elcbin0 -> 2451 bytes
-rw-r--r--lisp/ledit.el24
-rw-r--r--lisp/life.el (renamed from lisp/play/life.el)8
-rw-r--r--lisp/life.elcbin0 -> 5219 bytes
-rw-r--r--lisp/lisp-mode.el (renamed from lisp/emacs-lisp/lisp-mode.el)191
-rw-r--r--lisp/lisp-mode.elcbin0 -> 11917 bytes
-rw-r--r--lisp/lisp.el (renamed from lisp/emacs-lisp/lisp.el)105
-rw-r--r--lisp/lisp.elcbin0 -> 5285 bytes
-rw-r--r--lisp/loaddefs.el1942
-rw-r--r--lisp/loadup.el56
-rw-r--r--lisp/lpr.el65
-rw-r--r--lisp/lpr.elcbin0 -> 1548 bytes
-rw-r--r--lisp/ls-lisp.el132
-rw-r--r--lisp/macros.el37
-rw-r--r--lisp/macros.elcbin0 -> 2356 bytes
-rw-r--r--lisp/mail-utils.el (renamed from lisp/mail/mail-utils.el)140
-rw-r--r--lisp/mail-utils.elcbin0 -> 3317 bytes
-rw-r--r--lisp/mail/rmailout.el182
-rw-r--r--lisp/mail/rmailsort.el203
-rw-r--r--lisp/mailalias.el (renamed from lisp/mail/mailalias.el)24
-rw-r--r--lisp/mailalias.elcbin0 -> 2037 bytes
-rw-r--r--lisp/mailpost.el (renamed from lisp/mail/mailpost.el)6
-rw-r--r--lisp/makesum.elcbin0 -> 1285 bytes
-rw-r--r--lisp/man.el54
-rw-r--r--lisp/man.elcbin0 -> 2143 bytes
-rw-r--r--lisp/medit.el4
-rw-r--r--lisp/medit.elcbin0 -> 2763 bytes
-rw-r--r--lisp/meese.el (renamed from lisp/play/meese.el)0
-rw-r--r--lisp/mh-e.el2910
-rw-r--r--lisp/mh-e.elc1128
-rw-r--r--lisp/mhspool.el404
-rw-r--r--lisp/mim-mode.el72
-rw-r--r--lisp/mim-mode.elcbin0 -> 20097 bytes
-rw-r--r--lisp/mim-syntax.elcbin0 -> 1276 bytes
-rw-r--r--lisp/misc.el51
-rw-r--r--lisp/mlconvert.el (renamed from lisp/emulation/mlconvert.el)0
-rw-r--r--lisp/mlconvert.elcbin0 -> 9065 bytes
-rw-r--r--lisp/mlsupport.el (renamed from lisp/emulation/mlsupport.el)5
-rw-r--r--lisp/mlsupport.elcbin0 -> 10191 bytes
-rw-r--r--lisp/modula2.el (renamed from lisp/progmodes/modula2.el)126
-rw-r--r--lisp/modula2.elcbin0 -> 9910 bytes
-rw-r--r--lisp/mouse.el524
-rw-r--r--lisp/netunam.el152
-rw-r--r--lisp/nnspool.el374
-rw-r--r--lisp/nntp.el667
-rw-r--r--lisp/nroff-mode.el (renamed from lisp/textmodes/nroff-mode.el)19
-rw-r--r--lisp/nroff-mode.elcbin0 -> 4631 bytes
-rw-r--r--lisp/options.el28
-rw-r--r--lisp/options.elcbin0 -> 2742 bytes
-rw-r--r--lisp/outline.el (renamed from lisp/textmodes/ooutline.el)139
-rw-r--r--lisp/outline.elcbin0 -> 9516 bytes
-rw-r--r--lisp/page.el (renamed from lisp/textmodes/page.el)6
-rw-r--r--lisp/page.elcbin0 -> 2186 bytes
-rw-r--r--lisp/paragraphs.el (renamed from lisp/textmodes/paragraphs.el)59
-rw-r--r--lisp/paragraphs.elcbin0 -> 4416 bytes
-rw-r--r--lisp/paths.el76
-rw-r--r--lisp/picture.el (renamed from lisp/textmodes/picture.el)82
-rw-r--r--lisp/picture.elcbin0 -> 19654 bytes
-rw-r--r--lisp/play/gomoku.el1161
-rw-r--r--lisp/play/mpuz.el448
-rw-r--r--lisp/progmodes/compile.el478
-rw-r--r--lisp/prolog.el (renamed from lisp/progmodes/prolog.el)50
-rw-r--r--lisp/prolog.elcbin0 -> 6261 bytes
-rw-r--r--lisp/rect.el13
-rw-r--r--lisp/rect.elcbin0 -> 5003 bytes
-rw-r--r--lisp/register.el39
-rw-r--r--lisp/register.elcbin0 -> 4126 bytes
-rw-r--r--lisp/replace.el307
-rw-r--r--lisp/replace.elcbin0 -> 6083 bytes
-rw-r--r--lisp/reposition.el185
-rw-r--r--lisp/resume.el160
-rw-r--r--lisp/rfc822.el (renamed from lisp/mail/rfc822.el)3
-rw-r--r--lisp/rfc822.elcbin0 -> 4324 bytes
-rw-r--r--lisp/rmail.el1433
-rw-r--r--lisp/rmail.elcbin0 -> 30112 bytes
-rw-r--r--lisp/rmailedit.el (renamed from lisp/mail/rmailedit.el)2
-rw-r--r--lisp/rmailedit.elcbin0 -> 2258 bytes
-rw-r--r--lisp/rmailkwd.el (renamed from lisp/mail/rmailkwd.el)14
-rw-r--r--lisp/rmailkwd.elcbin0 -> 4576 bytes
-rw-r--r--lisp/rmailmsc.el (renamed from lisp/mail/rmailmsc.el)6
-rw-r--r--lisp/rmailmsc.elcbin0 -> 728 bytes
-rw-r--r--lisp/rmailout.el126
-rw-r--r--lisp/rmailout.elcbin0 -> 2296 bytes
-rw-r--r--lisp/rmailsum.el (renamed from lisp/mail/rmailsum.el)51
-rw-r--r--lisp/rmailsum.elcbin0 -> 9655 bytes
-rw-r--r--lisp/rnews.el (renamed from lisp/mail/rnews.el)38
-rw-r--r--lisp/rnews.elcbin0 -> 23722 bytes
-rw-r--r--lisp/rnewspost.el (renamed from lisp/mail/rnewspost.el)15
-rw-r--r--lisp/rnewspost.elcbin0 -> 8941 bytes
-rw-r--r--lisp/saveconf.el240
-rw-r--r--lisp/scheme.el (renamed from lisp/progmodes/scheme.el)140
-rw-r--r--lisp/scheme.elcbin0 -> 10747 bytes
-rw-r--r--lisp/scribe.el (renamed from lisp/textmodes/scribe.el)26
-rw-r--r--lisp/scribe.elcbin0 -> 7839 bytes
-rw-r--r--lisp/sendmail.el469
-rw-r--r--lisp/sendmail.elcbin0 -> 9885 bytes
-rw-r--r--lisp/server.el60
-rw-r--r--lisp/server.elcbin0 -> 5497 bytes
-rw-r--r--lisp/shell.el726
-rw-r--r--lisp/shell.elcbin0 -> 12048 bytes
-rw-r--r--lisp/simple.el1431
-rw-r--r--lisp/simple.elcbin0 -> 36869 bytes
-rw-r--r--lisp/simula.defns185
-rw-r--r--lisp/simula.el827
-rw-r--r--lisp/simula.elcbin0 -> 17293 bytes
-rw-r--r--lisp/sort.el258
-rw-r--r--lisp/sort.elcbin0 -> 8884 bytes
-rw-r--r--lisp/spell.el (renamed from lisp/textmodes/spell.el)0
-rw-r--r--lisp/spell.elcbin0 -> 2616 bytes
-rw-r--r--lisp/spook.el (renamed from lisp/play/spook.el)2
-rw-r--r--lisp/startup.el238
-rw-r--r--lisp/startup.elcbin0 -> 4319 bytes
-rw-r--r--lisp/studly.el (renamed from lisp/play/studly.el)0
-rw-r--r--lisp/studly.elcbin0 -> 774 bytes
-rw-r--r--lisp/subr.el154
-rw-r--r--lisp/subr.elcbin0 -> 5669 bytes
-rw-r--r--lisp/sun-cursors.el (renamed from lisp/sun-curs.el)2
-rw-r--r--lisp/sun-fns.el223
-rw-r--r--lisp/sun-fns.elcbin0 -> 25003 bytes
-rw-r--r--lisp/sun-keys.el3
-rw-r--r--lisp/sun-mouse.el (renamed from lisp/term/sun-mouse.el)144
-rw-r--r--lisp/sun-mouse.elcbin0 -> 19797 bytes
-rw-r--r--lisp/sup-mouse.el (renamed from lisp/term/sup-mouse.el)0
-rw-r--r--lisp/sup-mouse.elcbin0 -> 3036 bytes
-rw-r--r--lisp/superyank.el1212
-rw-r--r--lisp/tabify.elcbin0 -> 786 bytes
-rw-r--r--lisp/tags.el304
-rw-r--r--lisp/tags.elcbin0 -> 7375 bytes
-rw-r--r--lisp/tar-mode.el1117
-rw-r--r--lisp/telnet.el204
-rw-r--r--lisp/telnet.elcbin0 -> 5416 bytes
-rw-r--r--lisp/term-nasty.el21
-rw-r--r--lisp/term/COPYING249
-rw-r--r--lisp/term/apollo.el1
-rw-r--r--lisp/term/at386.el101
-rw-r--r--lisp/term/bbn.el1
-rw-r--r--lisp/term/bg.el6
-rw-r--r--lisp/term/bgnv.el1
-rw-r--r--lisp/term/bgrv.el1
-rw-r--r--lisp/term/bobcat.el11
-rw-r--r--lisp/term/news.el85
-rw-r--r--lisp/term/s4.el142
-rw-r--r--lisp/term/sun.el333
-rw-r--r--lisp/term/supdup.el81
-rw-r--r--lisp/term/unixpc.el148
-rw-r--r--lisp/term/vt100.el66
-rw-r--r--lisp/term/vt101.el1
-rw-r--r--lisp/term/vt102.el1
-rw-r--r--lisp/term/vt125.el1
-rw-r--r--lisp/term/vt131.el1
-rw-r--r--lisp/term/vt200.el90
-rw-r--r--lisp/term/vt220.el1
-rw-r--r--lisp/term/vt240.el1
-rw-r--r--lisp/term/vt300.el1
-rw-r--r--lisp/term/wyse50.el235
-rw-r--r--lisp/term/x-win.el817
-rw-r--r--lisp/term/xterm.el2
-rw-r--r--lisp/terminal.el228
-rw-r--r--lisp/terminal.elcbin0 -> 23792 bytes
-rw-r--r--lisp/tex-mode.el465
-rw-r--r--lisp/tex-mode.elcbin0 -> 12135 bytes
-rw-r--r--lisp/tex-start.el11
-rw-r--r--lisp/texinfmt.el (renamed from lisp/textmodes/texinfmt.el)1015
-rw-r--r--lisp/texinfmt.elcbin0 -> 37533 bytes
-rw-r--r--lisp/texinfo.el175
-rw-r--r--lisp/texinfo.elc84
-rw-r--r--lisp/text-mode.el (renamed from lisp/textmodes/text-mode.el)42
-rw-r--r--lisp/text-mode.elcbin0 -> 3041 bytes
-rw-r--r--lisp/textmodes/bib-mode.el233
-rw-r--r--lisp/textmodes/fill.el246
-rw-r--r--lisp/textmodes/ispell4.el541
-rw-r--r--lisp/textmodes/page-ext.el745
-rw-r--r--lisp/textmodes/refbib.el715
-rw-r--r--lisp/textmodes/tex-mode.el799
-rw-r--r--lisp/textmodes/texinfo.el414
-rw-r--r--lisp/textmodes/texnfo-upd.el1726
-rw-r--r--lisp/time.el48
-rw-r--r--lisp/time.elcbin0 -> 2230 bytes
-rw-r--r--lisp/timer.el92
-rw-r--r--lisp/uncompress.el26
-rw-r--r--lisp/underline.el (renamed from lisp/textmodes/underline.el)2
-rw-r--r--lisp/underline.elcbin0 -> 739 bytes
-rw-r--r--lisp/undigest.el (renamed from lisp/mail/undigest.el)3
-rw-r--r--lisp/undigest.elcbin0 -> 1380 bytes
-rw-r--r--lisp/userlock.el9
-rw-r--r--lisp/userlock.elcbin0 -> 3234 bytes
-rw-r--r--lisp/version.el45
-rw-r--r--lisp/vi.el (renamed from lisp/emulation/vi.el)2
-rw-r--r--lisp/vi.elcbin0 -> 48241 bytes
-rw-r--r--lisp/view.el150
-rw-r--r--lisp/view.elcbin0 -> 12843 bytes
-rw-r--r--lisp/vip.el (renamed from lisp/emulation/vip.el)39
-rw-r--r--lisp/vip.elcbin0 -> 69338 bytes
-rw-r--r--lisp/vms-patch.el29
-rw-r--r--lisp/vms-patch.elcbin0 -> 1972 bytes
-rw-r--r--lisp/vmsproc.el98
-rw-r--r--lisp/vmsproc.elcbin0 -> 2255 bytes
-rw-r--r--lisp/vmsx.el137
-rw-r--r--lisp/window.el69
-rw-r--r--lisp/window.elcbin0 -> 1161 bytes
-rw-r--r--lisp/x-menu.elcbin0 -> 3126 bytes
-rw-r--r--lisp/x-mouse.el295
-rw-r--r--lisp/x-mouse.elcbin0 -> 9230 bytes
-rw-r--r--lisp/xscheme.el15
-rw-r--r--lisp/xscheme.elcbin0 -> 25651 bytes
-rw-r--r--lisp/yow.el (renamed from lisp/play/yow.el)17
-rw-r--r--lisp/yow.elcbin0 -> 1233 bytes
322 files changed, 36031 insertions, 26783 deletions
diff --git a/lisp/COPYING b/lisp/COPYING
new file mode 100644
index 00000000000..9a170375811
--- /dev/null
+++ b/lisp/COPYING
@@ -0,0 +1,249 @@
+
+ GNU GENERAL PUBLIC LICENSE
+ Version 1, February 1989
+
+ Copyright (C) 1989 Free Software Foundation, Inc.
+ 675 Mass Ave, Cambridge, MA 02139, USA
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+ Preamble
+
+ The license agreements of most software companies try to keep users
+at the mercy of those companies. By contrast, our General Public
+License is intended to guarantee your freedom to share and change free
+software--to make sure the software is free for all its users. The
+General Public License applies to the Free Software Foundation's
+software and to any other program whose authors commit to using it.
+You can use it for your programs, too.
+
+ When we speak of free software, we are referring to freedom, not
+price. Specifically, the General Public License is designed to make
+sure that you have the freedom to give away or sell copies of free
+software, that you receive source code or can get it if you want it,
+that you can change the software or use pieces of it in new free
+programs; and that you know you can do these things.
+
+ To protect your rights, we need to make restrictions that forbid
+anyone to deny you these rights or to ask you to surrender the rights.
+These restrictions translate to certain responsibilities for you if you
+distribute copies of the software, or if you modify it.
+
+ For example, if you distribute copies of a such a program, whether
+gratis or for a fee, you must give the recipients all the rights that
+you have. You must make sure that they, too, receive or can get the
+source code. And you must tell them their rights.
+
+ We protect your rights with two steps: (1) copyright the software, and
+(2) offer you this license which gives you legal permission to copy,
+distribute and/or modify the software.
+
+ Also, for each author's protection and ours, we want to make certain
+that everyone understands that there is no warranty for this free
+software. If the software is modified by someone else and passed on, we
+want its recipients to know that what they have is not the original, so
+that any problems introduced by others will not reflect on the original
+authors' reputations.
+
+ The precise terms and conditions for copying, distribution and
+modification follow.
+
+ GNU GENERAL PUBLIC LICENSE
+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+ 0. This License Agreement applies to any program or other work which
+contains a notice placed by the copyright holder saying it may be
+distributed under the terms of this General Public License. The
+"Program", below, refers to any such program or work, and a "work based
+on the Program" means either the Program or any work containing the
+Program or a portion of it, either verbatim or with modifications. Each
+licensee is addressed as "you".
+
+ 1. You may copy and distribute verbatim copies of the Program's source
+code as you receive it, in any medium, provided that you conspicuously and
+appropriately publish on each copy an appropriate copyright notice and
+disclaimer of warranty; keep intact all the notices that refer to this
+General Public License and to the absence of any warranty; and give any
+other recipients of the Program a copy of this General Public License
+along with the Program. You may charge a fee for the physical act of
+transferring a copy.
+
+ 2. You may modify your copy or copies of the Program or any portion of
+it, and copy and distribute such modifications under the terms of Paragraph
+1 above, provided that you also do the following:
+
+ a) cause the modified files to carry prominent notices stating that
+ you changed the files and the date of any change; and
+
+ b) cause the whole of any work that you distribute or publish, that
+ in whole or in part contains the Program or any part thereof, either
+ with or without modifications, to be licensed at no charge to all
+ third parties under the terms of this General Public License (except
+ that you may choose to grant warranty protection to some or all
+ third parties, at your option).
+
+ c) If the modified program normally reads commands interactively when
+ run, you must cause it, when started running for such interactive use
+ in the simplest and most usual way, to print or display an
+ announcement including an appropriate copyright notice and a notice
+ that there is no warranty (or else, saying that you provide a
+ warranty) and that users may redistribute the program under these
+ conditions, and telling the user how to view a copy of this General
+ Public License.
+
+ d) You may charge a fee for the physical act of transferring a
+ copy, and you may at your option offer warranty protection in
+ exchange for a fee.
+
+Mere aggregation of another independent work with the Program (or its
+derivative) on a volume of a storage or distribution medium does not bring
+the other work under the scope of these terms.
+
+ 3. You may copy and distribute the Program (or a portion or derivative of
+it, under Paragraph 2) in object code or executable form under the terms of
+Paragraphs 1 and 2 above provided that you also do one of the following:
+
+ a) accompany it with the complete corresponding machine-readable
+ source code, which must be distributed under the terms of
+ Paragraphs 1 and 2 above; or,
+
+ b) accompany it with a written offer, valid for at least three
+ years, to give any third party free (except for a nominal charge
+ for the cost of distribution) a complete machine-readable copy of the
+ corresponding source code, to be distributed under the terms of
+ Paragraphs 1 and 2 above; or,
+
+ c) accompany it with the information you received as to where the
+ corresponding source code may be obtained. (This alternative is
+ allowed only for noncommercial distribution and only if you
+ received the program in object code or executable form alone.)
+
+Source code for a work means the preferred form of the work for making
+modifications to it. For an executable file, complete source code means
+all the source code for all modules it contains; but, as a special
+exception, it need not include source code for modules which are standard
+libraries that accompany the operating system on which the executable
+file runs, or for standard header files or definitions files that
+accompany that operating system.
+
+ 4. You may not copy, modify, sublicense, distribute or transfer the
+Program except as expressly provided under this General Public License.
+Any attempt otherwise to copy, modify, sublicense, distribute or transfer
+the Program is void, and will automatically terminate your rights to use
+the Program under this License. However, parties who have received
+copies, or rights to use copies, from you under this General Public
+License will not have their licenses terminated so long as such parties
+remain in full compliance.
+
+ 5. By copying, distributing or modifying the Program (or any work based
+on the Program) you indicate your acceptance of this license to do so,
+and all its terms and conditions.
+
+ 6. Each time you redistribute the Program (or any work based on the
+Program), the recipient automatically receives a license from the original
+licensor to copy, distribute or modify the Program subject to these
+terms and conditions. You may not impose any further restrictions on the
+recipients' exercise of the rights granted herein.
+
+ 7. The Free Software Foundation may publish revised and/or new versions
+of the General Public License from time to time. Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+Each version is given a distinguishing version number. If the Program
+specifies a version number of the license which applies to it and "any
+later version", you have the option of following the terms and conditions
+either of that version or of any later version published by the Free
+Software Foundation. If the Program does not specify a version number of
+the license, you may choose any version ever published by the Free Software
+Foundation.
+
+ 8. If you wish to incorporate parts of the Program into other free
+programs whose distribution conditions are different, write to the author
+to ask for permission. For software which is copyrighted by the Free
+Software Foundation, write to the Free Software Foundation; we sometimes
+make exceptions for this. Our decision will be guided by the two goals
+of preserving the free status of all derivatives of our free software and
+of promoting the sharing and reuse of software generally.
+
+ NO WARRANTY
+
+ 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
+REPAIR OR CORRECTION.
+
+ 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGES.
+
+ END OF TERMS AND CONDITIONS
+
+ Appendix: How to Apply These Terms to Your New Programs
+
+ If you develop a new program, and you want it to be of the greatest
+possible use to humanity, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these
+terms.
+
+ To do so, attach the following notices to the program. It is safest to
+attach them to the start of each source file to most effectively convey
+the exclusion of warranty; and each file should have at least the
+"copyright" line and a pointer to where the full notice is found.
+
+ <one line to give the program's name and a brief idea of what it does.>
+ Copyright (C) 19yy <name of author>
+
+ This program 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 1, or (at your option)
+ any later version.
+
+ This program 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 this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+Also add information on how to contact you by electronic and paper mail.
+
+If the program is interactive, make it output a short notice like this
+when it starts in an interactive mode:
+
+ Gnomovision version 69, Copyright (C) 19xx name of author
+ Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+ This is free software, and you are welcome to redistribute it
+ under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the
+appropriate parts of the General Public License. Of course, the
+commands you use may be called something other than `show w' and `show
+c'; they could even be mouse-clicks or menu items--whatever suits your
+program.
+
+You should also get your employer (if you work as a programmer) or your
+school, if any, to sign a "copyright disclaimer" for the program, if
+necessary. Here a sample; alter the names:
+
+ Yoyodyne, Inc., hereby disclaims all copyright interest in the
+ program `Gnomovision' (a program to direct compilers to make passes
+ at assemblers) written by James Hacker.
+
+ <signature of Ty Coon>, 1 April 1989
+ Ty Coon, President of Vice
+
+That's all there is to it!
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
new file mode 100644
index 00000000000..94490f6ef33
--- /dev/null
+++ b/lisp/ChangeLog
@@ -0,0 +1,5068 @@
+Fri Oct 30 19:36:38 1992 Richard Stallman (rms@mole.gnu.ai.mit.edu)
+
+ * Version 18.59 released.
+
+Wed Oct 21 00:36:11 1992 Richard Stallman (rms@mole.gnu.ai.mit.edu)
+
+ * sun-fns.el, sun-mouse.el, term/sun.el: New versions from Peck.
+
+ * dired.el (dired-chown): Treat silicon-graphics-unix like usg-unix-v.
+
+ * lpr.el (lpr-command):
+ Treat hpux and silicon-graphics-unix like usg-unix-v.
+
+Thu Oct 15 03:18:59 1992 Richard Stallman (rms@mole.gnu.ai.mit.edu)
+
+ * telnet.el (telnet): Wait for telnet output before sending `open'.
+
+Sun Oct 11 18:21:46 1992 Richard Stallman (rms@mole.gnu.ai.mit.edu)
+
+ * picture.el (edit-picture): Run picture-mode-hook.
+
+ * files.el (hack-local-variables): Undo March 5 change.
+
+Fri Oct 9 01:26:40 1992 Richard Stallman (rms@mole.gnu.ai.mit.edu)
+
+ * files.el (hack-local-variables): Don't allow `force' as local var.
+
+Thu Oct 8 02:48:50 1992 Richard Stallman (rms@mole.gnu.ai.mit.edu)
+
+ * files.el (hack-local-variables):
+ Ignore attempt to set inhibit-local-eval as local variable.
+
+Wed Oct 7 03:33:05 1992 Richard Stallman (rms@mole.gnu.ai.mit.edu)
+
+ * files.el (file-name-sans-versions): Recognize empty VMS version.
+
+Wed Sep 23 00:22:55 1992 Richard Stallman (rms@mole.gnu.ai.mit.edu)
+
+ * c-mode.el (calculate-c-indent): When testing for function start line,
+ match the first open paren; insist no = or doublequote before it.
+
+Sat Sep 19 01:58:01 1992 Richard Stallman (rms@mole.gnu.ai.mit.edu)
+
+ * rmail.el (rmail-insert-inbox-text): Make the inbox file empty here
+ if we rename it with rename-file here.
+ (rmail-get-new-mail): Always try deleting the files in delete-files.
+
+Fri Sep 18 02:58:14 1992 Richard Stallman (rms@mole.gnu.ai.mit.edu)
+
+ * rmail.el (rmail-get-new-mail): Truncate inbox file if we
+ fail to delete it, or if it's not in the ordinary mail spool dir.
+
+Sat Sep 12 04:39:41 1992 Richard Stallman (rms@mole.gnu.ai.mit.edu)
+
+ * files.el (backup-buffer): Delete %backup% before copying to it.
+
+Fri Sep 4 03:33:08 1992 Richard Stallman (rms@mole.gnu.ai.mit.edu)
+
+ * shell.el (make-shell): Don't call shell-mode if already in that mode.
+
+Sat Aug 29 04:25:31 1992 Richard Stallman (rms@mole.gnu.ai.mit.edu)
+
+ * picture.el (picture-snarf-rectangle): Delete extra closeparen.
+
+ * c-mode.el (calculate-c-indent): If taking indent from prev stmt
+ and it starts with an {, subtract c-brace-offset.
+
+Wed Aug 19 23:26:47 1992 Richard Stallman (rms@mole.gnu.ai.mit.edu)
+
+ * info.el (Info-mode): Add mode-class property.
+
+Fri Aug 14 03:50:30 1992 Richard Stallman (rms@mole.gnu.ai.mit.edu)
+
+ * compile.el (compile1): Don't mess with comp-proc if it's nil.
+
+ * info.el (Info-find-node): Be more abt format of tags table.
+
+Thu Jul 23 14:26:14 1992 Richard Stallman (rms@mole.gnu.ai.mit.edu)
+
+ * paths.el (mh-lib, mh-prog): Add more alternatives.
+
+Sat Jul 4 12:20:43 1992 Richard Stallman (rms@mole.gnu.ai.mit.edu)
+
+ * files.el (save-buffers-kill-emacs): Consider open net connections
+ as possibly requiring a query.
+
+Thu Jul 2 16:13:10 1992 Richard Stallman (rms@mole.gnu.ai.mit.edu)
+
+ * tags.el (visit-tags-table-buffer): Update file name after find-file.
+
+Fri Jun 12 20:12:12 1992 Jim Blandy (jimb@wookumz.gnu.ai.mit.edu)
+
+ * cal.el (generate-month): Removed extranous '7' from let* binding
+ of `first-day-of-month'.
+
+Thu Jun 11 18:30:36 1992 Jim Blandy (jimb@pogo.cs.oberlin.edu)
+
+ * cal.el (calendar): Do not assume that if `one-window-p' returns
+ non-nil, then we can shrink the current window vertically. This is
+ not true if the screen is split only into side-by-side windows;
+ shrinking the window in this case enlarges the minibuffer.
+ Instead, add up the height of the current window and the
+ minibuffer window and compare this with the height of the whole
+ screen, to see if the current window is full-height. If it is,
+ don't try to shrink the current window.
+
+Sat May 30 03:38:17 1992 Jim Blandy (jimb@wookumz.gnu.ai.mit.edu)
+
+ * dbx.el (run-dbx): Apply expand-file-name to PATH. Among other
+ things, this makes sure that the default-directory gets set to
+ something non-nil when we set it to (file-name-directory PATH).
+
+Tue May 19 23:23:53 1992 Richard Stallman (rms@mole.gnu.ai.mit.edu)
+
+ * subr.el (one-window-p): If arg is t, completely avoid minibuffer.
+
+Thu May 14 23:08:09 1992 Richard Stallman (rms@mole.gnu.ai.mit.edu)
+
+ * fill.el (fill-region-as-paragraph):
+ Handle fill-prefix wider than fill-column.
+
+Wed May 13 15:42:52 1992 Jim Blandy (jimb@wookumz.gnu.ai.mit.edu)
+
+ * loadup.el: Disable undo in *scratch* while we're loading the
+ files to dump, and re-enable it before we dump. We used to
+ disable it in init_buffer_once in ../src/buffer.c, but didn't
+ re-enable it anywhere; this was obscured by the fact that GC would
+ re-enable undo in all buffers.
+
+Tue May 5 23:15:57 1992 Richard Stallman (rms@mole.gnu.ai.mit.edu)
+
+ * ftp.el (ftp-command): Correctly ignore lines without status codes.
+ (ftp-write-file-hook): Clear modified flag in the proper buffer.
+
+ * fill.el (fill-individual-paragraphs): Choice of two modes,
+ controlled by fill-individual-varying-indent.
+
+Sun May 3 23:26:39 1992 Richard Stallman (rms@mole.gnu.ai.mit.edu)
+
+ * dired.el (dired-readin): At end, clear modified flag.
+
+Sat Apr 18 17:38:03 1992 Jim Blandy (jimb@pogo.cs.oberlin.edu)
+
+ * startup.el (normal-top-level): Don't change default-directory to
+ (getenv "PWD") unless they actually refer to the same directory.
+
+Fri Apr 17 11:16:33 1992 Richard Stallman (rms@mole.gnu.ai.mit.edu)
+
+ * rmail.el (rmail-unix-mail-delimiter): Doc str changed to comment.
+
+Wed Apr 15 02:08:03 1992 Jim Blandy (jimb@pogo.cs.oberlin.edu)
+
+ * simple.el (reindent-then-newline-and-indent,
+ newline-and-indent): Call the newline function instead of saying
+ (insert ?\n), so that auto fill mode will break lines correctly.
+
+ * rmail.el (rmail-unix-mail-delimiter): New variable.
+ (rmail-convert-to-babyl-format): Use it to recognize the start of
+ an mbox message.
+ (rmail-nuke-pinhead-header): Same.
+
+Wed Mar 25 17:47:25 1992 Richard Stallman (rms@mole.gnu.ai.mit.edu)
+
+ * sendmail.el (mail-do-fcc): Use regexp to find time zone.
+
+Tue Mar 24 00:01:37 1992 Richard Stallman (rms@mole.gnu.ai.mit.edu)
+
+ * picture.el (picture-snarf-rectangle): Effectively preserve
+ column of mark.
+
+Fri Mar 20 15:13:12 1992 Richard Stallman (rms@mole.gnu.ai.mit.edu)
+
+ * files.el (find-backup-file-name): Fix the overflow test.
+
+Sun Mar 15 23:04:19 1992 Richard Stallman (rms@mole.gnu.ai.mit.edu)
+
+ * simple.el (undo): Suppress message in minibuffer.
+
+Sat Mar 14 00:39:09 1992 Richard Stallman (rms@mole.gnu.ai.mit.edu)
+
+ * sendmail.el (mail-do-fcc): Insert the time zone before the year.
+
+ * x-mouse-el (x-mouse-set-point): Special case if mouse is past eob.
+
+Fri Mar 13 17:40:09 1992 Richard Stallman (rms@mole.gnu.ai.mit.edu)
+
+ * sendmail.el (mail-position-on-field): Insert new field differently.
+
+Wed Mar 11 18:29:09 1992 Richard Stallman (rms@mole.gnu.ai.mit.edu)
+
+ * files.el (set-visited-file-name): Add comments.
+
+ * sendmail.el (mail-position-on-field):
+ Do find separator even if it's the first line.
+
+Thu Mar 5 17:30:24 1992 Richard Stallman (rms@mole.gnu.ai.mit.edu)
+
+ * files.el (find-backup-file-name): Use make-backup-file-name.
+
+ * sendmail.el: Doc fix.
+
+ * rect.el (clear-rectangle): New arg, preserve-position.
+ (clear-rectangle-line): Do the real work.
+ * picture.el (picture-snarf-rectangle): Pass t for preserve-position.
+
+ * dired.el (dired-do-deletions): Don't try delete-file on a dir.
+
+ * rmail.el (rmail-forward): Look for >From if no From.
+
+Wed Mar 4 02:57:57 1992 Jim Blandy (jimb@wookumz.gnu.ai.mit.edu)
+
+ * telnet.el (read-password): Allow C-g to terminate password
+ entry.
+
+Mon Feb 3 16:44:51 1992 Richard Stallman (rms@mole.gnu.ai.mit.edu)
+
+ * add-log.el (add-change-log-entry): Don't get confused by
+ old-format entries that use `at' instead of `@'.
+
+Sat Feb 1 16:41:32 1992 Richard Stallman (rms@mole.gnu.ai.mit.edu)
+
+ * x-mouse.el (x-set-mouse-point): Handle continuation at a tab.
+
+Wed Jan 29 12:16:42 1992 Jim Blandy (jimb at pogo.cs.oberlin.edu)
+
+ * float.el (mantissa-minval): Make this (1- (ash 1 maxbit)),
+ rather than plain (ash 1 maxbit), since the latter can't be
+ negated.
+ (mantissa-half-minval): New constant.
+ (normalize): Shift negative numbers until the next value would be
+ less than mantissa-minval, not until the highest bit is one; the
+ latter is always true of a negative number.
+ (f+): Let f1 and f2 be the arguments with the greatest and least
+ exponents, not values. If a negative number with a greater
+ exponent is added to a positive number with a lesser exponent, the
+ positive number should be shifted right to meet the negative
+ number, not vice versa. You can't shift a normalized mantissa
+ left.
+
+Tue Jan 28 16:22:59 1992 Richard Stallman (rms@mole.gnu.ai.mit.edu)
+
+ * sendmail.el (mail-do-fcc): Put timezone in From line.
+
+Mon Jan 27 15:57:46 1992 Richard Stallman (rms@mole.gnu.ai.mit.edu)
+
+ * loaddefs.el (auto-mode-alist): Treat .texi like .texinfo.
+
+Tue Jan 21 18:07:19 1992 Richard Stallman (rms@mole.gnu.ai.mit.edu)
+
+ * mh-e.el: New version from Gildea.
+
+Thu Jan 16 01:10:02 1992 Richard Stallman (rms at mole.gnu.ai.mit.edu)
+
+ * telnet.el (telnet-initial-filter): Bind `password'.
+
+Mon Jan 13 09:44:54 1992 Richard Stallman (rms at mole.gnu.ai.mit.edu)
+
+ * files.el (set-visited-file-name): Error check for directories.
+ Do error checks before setting buffer-file-name.
+
+Wed Dec 25 22:24:50 1991 Richard Stallman (rms at mole.gnu.ai.mit.edu)
+
+ * mail-utils.el (mail-strip-quoted-names): Return nil if given nil.
+
+Sun Dec 8 00:28:11 1991 Richard Stallman (rms at mole.gnu.ai.mit.edu)
+
+ * texinfmt.el: Handle @need and @sp.
+
+Sat Nov 30 22:49:11 1991 Richard Stallman (rms at mole.gnu.ai.mit.edu)
+
+ * simple.el (prefix-arg-internal): Make C-u end the arg.
+ Doc fixes on the argument commands.
+
+Mon Nov 18 11:43:56 1991 Stephen Gildea (gildea at expo.lcs.mit.edu)
+
+ * mh-e.el:
+ (mh-reply): pass -noquery to repl
+ (mh-list-folders): obey mh-recursive-subfolders
+ (mh-redist-full-contents): change default to nil
+ (mh-unshar-msg): new function w variable mh-unshar-default-directory
+ (mh-before-quit-hook): new hook
+ (mh-read-folder-sequences): parse private sequences properly
+ (mh-undo): search backwards if nothing to undo on current message
+ (mh-folder-mode): turn on truncate-lines
+
+Sat Nov 16 00:45:58 1991 Richard Stallman (rms at mole.gnu.ai.mit.edu)
+
+ * fill.el (fill-region-as-paragraph): Don't forget which side of
+ a space point and markers were on. Add lots of comments.
+
+ * files.el (file-name-sans-versions): Quote period in VMS regexp.
+ Don't accept .nnn which is really VMS file extension.
+ Merge non-VMS regexps. Use just nil as length if no version.
+
+Fri Nov 15 13:18:00 1991 Richard Stallman (rms at mole.gnu.ai.mit.edu)
+
+ * replace.el (query-replace-help): Correction to explain action of SPC.
+
+Wed Oct 23 20:42:23 1991 Richard Stallman (rms@mole.gnu.ai.mit.edu)
+
+ * bytecomp.el (byte-compile-cond-1): Typo in singleton uncond clause.
+
+Tue Oct 22 00:30:37 1991 Richard Stallman (rms@mole.gnu.ai.mit.edu)
+
+ * replace.el (how-many): Do count successive blank lines matching ^$.
+
+Sat Oct 19 12:32:16 1991 Richard Stallman (rms@mole.gnu.ai.mit.edu)
+
+ * simple.el (fixup-whitespace): Leave no space at end of line.
+
+Sun Oct 6 00:32:38 1991 Richard Stallman (rms@mole.gnu.ai.mit.edu)
+
+ * bytecomp.el (byte-compile-file): Don't run emacs-lisp-mode-hook.
+
+ * files.el (automount-dir-prefix): New var.
+ (find-file-noselect): Use it.
+
+Sat Oct 5 13:28:25 1991 Richard Stallman (rms@mole.gnu.ai.mit.edu)
+
+ * time.el (display-time-filter): Be consistent: space before words.
+
+ * texinfo.el (texinfo-mode): Don't call text-mode; run its hook once.
+
+Tue Sep 24 02:24:42 1991 Richard Stallman (rms@mole.gnu.ai.mit.edu)
+
+ * isearch.el (nonincremental-search):
+ Use separate defaults var for regexp search, like isearch.
+
+Sun Sep 15 15:34:14 1991 Richard Stallman (rms at mole.gnu.ai.mit.edu)
+
+ * rnewspost.el (news-setup): Delete text rather than killing.
+
+ * inc-vers.el: Search load-path for version.el.
+
+Fri Sep 13 00:32:19 1991 Richard Stallman (rms@mole.gnu.ai.mit.edu)
+
+ * fill.el (justify-current-line): Rewrite of insertion of spaces.
+
+ * x-mouse.el (x-mouse-select): Compensate for minibuf prompt width.
+
+Sat Sep 7 16:27:20 1991 Richard Stallman (rms at mole.gnu.ai.mit.edu)
+
+ * fill.el (fill-individual-paragraphs):
+ Find a fill-prefix that works for the whole paragraph.
+
+Mon Sep 2 20:28:24 1991 Richard Stallman (rms at mole.gnu.ai.mit.edu)
+
+ * server.el (server-start): Delete old socket in /tmp as well as in ~.
+
+Tue Jul 30 17:17:39 1991 Richard Stallman (rms at mole.gnu.ai.mit.edu)
+
+ * dired.el (dired-chown): Use /bin/chown on certain systems.
+
+Tue Jul 23 14:21:24 1991 Richard Stallman (rms at mole.gnu.ai.mit.edu)
+
+ * rmail.el (rmail-convert-to-babyl-format): Handle Content-Length.
+
+Sat Jun 29 13:07:39 1991 Richard Stallman (rms at mole.gnu.ai.mit.edu)
+
+ * simple.el (shell-command-on-region):
+ Handle case where input is from *Shell Command Output*.
+
+ * compile.el (compilation-parse-error): Don't screw up on silly lineno.
+
+Fri Jun 28 08:48:18 1991 Richard Stallman (rms at mole.gnu.ai.mit.edu)
+
+ * simple.el (kill-region): If read-only bfr, don't mess with undo.
+
+Mon May 13 11:37:01 1991 Richard Stallman (rms at mole.gnu.ai.mit.edu)
+
+ * view.el (View-previous-line, View-next-line): New functions.
+ (view-mode-map): Use them.
+ (view-mode-command-loop): Don't bind goal-column.
+
+ * loaddefs.el (auto-mode-alist): Recognize .emacs only at end.
+
+Thu May 2 14:35:31 1991 Richard Stallman (rms at mole.gnu.ai.mit.edu)
+
+ * time.el (display-time-filter): If load-average fails, run uptime.
+
+ * at386.el: New file.
+
+Tue Apr 30 18:14:58 1991 Richard Stallman (rms at mole.gnu.ai.mit.edu)
+
+ * mail-utils.el (mail-strip-quoted-names): Handle nested parens.
+
+ * isearch.el (isearch): * and ? are not special after incomplete input.
+ When they are special, use old other-end for cs in both reverse
+ and forward.
+
+Mon Apr 29 15:00:31 1991 Richard Stallman (rms at mole.gnu.ai.mit.edu)
+
+ * info.el (Info-read-subfile): Skip blank lines.
+
+Sat Apr 13 18:10:28 1991 Eric Youngdale (youngdale@v6550c.nrl.navy.mil)
+
+ * files.el (basic-save-buffer): Stop messing with the file protection
+ (mode) under VMS, since we are going to write a new file.
+
+ * vms-patch.el (make-auto-save-file-name): Fixed generation of the
+ name of the auto-save file, when the name of the file being edited has
+ a version number.
+
+
+Sun Mar 24 21:35:34 1991 Richard Stallman (rms at mole.gnu.ai.mit.edu)
+
+ * files.el (hack-local-variables): ignore-local-eval ignores `eval'.
+
+ * telnet.el (read-password): Clear quit-flag.
+
+Tue Mar 19 23:17:45 1991 Richard Stallman (rms at mole.gnu.ai.mit.edu)
+
+ * fill.el (justify-current-line): Adjust for 18.57 behavior
+ of current-column.
+
+Sun Mar 17 16:13:00 1991 Richard Stallman (rms@mole.ai.mit.edu)
+
+ * add-log.el (add-change-log-entry): Use @, not ` at '.
+
+ * fill.el (justify-current-line): Handle extra indent after prefix.
+
+Mon Mar 11 18:12:45 1991 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * simple.el (kill-region): Don't copy from undo list if empty.
+
+Sun Mar 10 19:42:39 1991 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * files.el (find-backup-file-name): Delete nothing if overflow
+ in number of versions to keep.
+
+Tue Mar 5 21:47:16 1991 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * files.el (find-alternate-file): Avoid killing current buffer.
+
+Thu Feb 28 18:04:11 1991 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * server.el (server-start): Don't use a pty.
+ * time.el (display-time): Likewise.
+ * mh-e.el (mh-exec-cmd-daemon): Likewise.
+
+ * bytecomp.el (byte-compile-cond-1): Better handling of
+ unconditional clauses.
+
+Tue Feb 26 16:00:30 1991 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * isearch.el (isearch): Copy point from small window
+ before deciding whether to set the mark.
+
+Mon Feb 25 13:07:37 1991 Paul Hilfinger (hilfingr at hilfinger.cs.nyu.edu)
+
+ * fill.el (fill-individual-paragraphs): Changed response to mailp
+ to effect only leading lines in a region (was getting confused
+ about colons embedded in ordinary text). Changed method of
+ moving to next paragraph in the main loop to use forward-paragraph
+ rather than goto-char, since the final character position is
+ rendered obsolete by the intervening fill-region-as-paragraph.
+
+Sun Feb 24 18:06:43 1991 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * vip.el (ex-write): Kill just this buffer, not Emacs.
+
+ * vip.el (vip-emacs-old-commands): New buffer-local variable.
+ (vip-change-mode): Redefine C-x 3 and C-x TAB, saving old definitions.
+ No longer redefine at top level.
+
+Sat Feb 9 13:16:53 1991 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * sendmail.el (sendmail-send-it): Turn off undo in tembuf.
+
+ * x-mouse.el (x-mouse-set-point): Take account of minibuffer prompt.
+
+ * rmailout.el (rmail-output-to-rmail-file): Always insert at end.
+
+Fri Feb 8 16:22:43 1991 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * simple.el (goto-line): Take special care of selective-display.
+ * compile.el (compilation-parse-errors): Likewise.
+
+Wed Feb 6 12:44:16 1991 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * rnews.el (news-select-message): Error does not prevent update
+ of .newsrc.
+
+ * rmail.el (rmail-insert-inbox-text): Don't insert newline after
+ empty file.
+
+Tue Feb 5 13:19:19 1991 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * info.el (Info-find-node): Try appending .info to node name.
+
+Mon Feb 4 21:49:39 1991 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * info.el (Info-extract-menu-node-name): New arg MULTI-LINE.
+ (Info-follow-reference): Pass t for that.
+
+Sat Feb 2 13:26:42 1991 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * files.el (basic-save-buffer): Clear setmodes if hook writes the file.
+
+Thu Jan 31 13:49:36 1991 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * rmailout.el (rmail-output):
+ Don't pass nil to mail-strip-quoted-names.
+
+ * files.el (find-file-noselect): Strip auto-mount prefix only if safe.
+
+Fri Jan 25 16:41:18 1991 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * Version 18.57 released.
+
+Fri Jan 18 02:06:18 1991 Jim Blandy (jimb at wookumz.ai.mit.edu)
+
+ * version.el (emacs-version): Change version number to 18.56.0.
+
+Wed Jan 16 18:57:23 1991 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * Version 18.56 released.
+
+Tue Jan 15 23:25:27 1991 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * startup.el (command-line-1): Update copyright year.
+
+Wed Jan 9 18:35:06 1991 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * doctex.el (LaTeXify-DOC): Upgrade permission notice that is output.
+
+ * Most files: Upgrade permission notice.
+
+Tue Jan 8 15:02:30 1991 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * rmail.el (rmail-insert-inbox-text): Put .newmail in dir with
+ rmail file.
+
+Fri Jan 4 00:41:56 1991 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * files.el (find-file-noselect): Get rid of automounter prefixes.
+
+Mon Dec 31 23:49:38 1990 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * files.el (revert-buffer): Clear buffer-backed-up if file has changed.
+
+Sun Dec 30 23:10:59 1990 Jim Blandy (jimb at pogo.ai.mit.edu)
+
+ * startup.el (command-line-1): Avoid binding load-path for -l
+ switch.
+
+Sun Dec 23 17:07:13 1990 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * rmail.el (rmail-convert-to-babyl-format, rmail-nuke-pinhead-header):
+ Accept `remote from ...' at end of UNIX From line.
+
+Sat Dec 22 13:15:09 1990 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * bytecomp.el (byte-compile-form): Handle call to explicit lambda.
+
+ * time.el (display-time): Specify precise directory for wakeup.
+ (display-time-filter): Don't display 0 as load.
+
+Fri Dec 21 11:32:28 1990 Chris Hanson (cph at kleph)
+
+ * info.el (Info-extract-menu-node-name): Permit \n between colon
+ and start of node name.
+
+Thu Dec 20 21:07:26 1990 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * sort.el (sort-numeric-fields): Fix syntax of chars to be skipped.
+
+Tue Dec 18 20:25:28 1990 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * files.el (hack-local-variables): Match suffix only at eol.
+
+Sun Dec 16 22:49:45 1990 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * rmail.el (rmail-parse-file-inboxes): Look for BABYL OPTIONS in u.c.
+ (rmail-convert-to-babyl-format): Likewise.
+ And don't skip white space after ^_ that ends a babyl format message.
+
+Wed Dec 12 00:11:37 1990 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * rmail.el (rmail-insert-inbox-text): Extra tests for POP.
+
+ * files.el (hack-local-variables): Display local vars at screen top.
+
+Mon Dec 10 12:24:56 1990 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * sendmail.el: Doc fix.
+
+Tue Dec 4 21:01:26 1990 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * server.el (server-process-filter): Don't be confused
+ if input from process is split into multiple chunks.
+
+ * time.el (display-time-filter): Let user specify mail file name.
+
+Thu Nov 29 20:43:40 1990 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * files.el (hack-local-variables): Show buffer when asking question.
+
+ * rmail.el (rmail-insert-inbox-text): Don't give up if movemail fails.
+
+ * cl.el (safe-idiv): Avoid overflow computing s.
+
+Wed Nov 28 17:01:40 1990 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * info.el (Info-extract-menu-item): Try exact match first.
+
+ * rmail.el (rmail-insert-inbox-text): Handle file names for pop.
+
+Mon Nov 26 17:02:13 1990 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * bg-mouse.el (bg-insert-moused-sexp): If before ')', just skip that.
+
+Mon Nov 19 16:24:35 1990 Richard Mlynarik (mly at august-east)
+
+ * rfc822.el (rfc822-addresses): Blow out, don't loop, on ")
+ (rfc822-addresses-1) Error if address "phrase" not followed by
+ route-spec
+
+Tue Nov 13 22:29:01 1990 David J. MacKenzie (djm at apple-gunkies)
+
+ * fortran.el: Use domain format instead of uucp format for bug
+ list address.
+
+Mon Nov 12 17:03:44 1990 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * lisp.el (lisp-complete-symbol): Use emacs-lisp-mode-syntax-table.
+
+Sun Nov 11 17:28:00 1990 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * simple.el (kill-region): Share storage with undo list.
+
+Fri Nov 2 19:19:05 1990 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * files.el (set-visited-file-name): Reject empty string as name.
+
+Thu Nov 1 20:30:50 1990 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * lisp-mode.el (lisp-interaction-mode): Use Emacs Lisp syntax.
+
+Tue Oct 30 15:20:05 1990 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * files.el (delete-auto-save-file-if-necessary):
+ Don't delete if auto-saving in visited file.
+
+Sun Oct 28 16:14:19 1990 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * dabbrev.el (dabbrevs-search): Rename arg nocase to do-case.
+ (dabbrev-expand): Likewise. Also correct usage in replace-match.
+ Also reinsert original abbrev before copying case pattern.
+
+Thu Oct 25 22:08:34 1990 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * x-win.el (command-switch-alist): Ignore -xrm.
+
+Tue Oct 16 13:32:21 1990 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * files.el (revert-buffer): Discard all undo records.
+ * rmail.el (rmail-expunge, rmail-get-new-mail): Likewise.
+
+Wed Oct 10 18:00:11 1990 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * rmailsum.el (rmail-summary-scroll-msg-up): Make msg visible.
+ (rmail-summary-scroll-msg-down): Likewise.
+
+Tue Oct 9 14:32:00 1990 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * dired.el (dired-compress, dired-uncompress): Put output from
+ subprocess in a buffer to display it.
+
+ * lisp.el (lisp-complete-symbol): Last change clobbered beg.
+
+ * lisp-mode.el (indent-sexp): Make sure outer loop ends at eob.
+
+Mon Oct 8 19:03:01 1990 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * files.el (save-buffers-kill-emacs): process-list is undef on VMS.
+
+Sun Sep 30 15:12:58 1990 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * compile.el (compile1): Make compilation-error-regexp local
+ only after switching modes.
+
+ * bytecomp.el (byte-compile-lambda): Handle string constant as value.
+
+Fri Sep 28 17:52:57 1990 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * mh-e.el: New version from Larus.
+
+Thu Sep 27 21:41:33 1990 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * time.el (display-time-filter): Don't lose if load-average fails.
+
+Wed Sep 26 16:03:59 1990 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * replace.el (occur-mode-goto-occurrence): Fix typo.
+
+Tue Sep 25 21:45:54 1990 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * lisp.el (lisp-complete-symbol): Switch to lisp syntax temporarily.
+ Put output in ` *Completions*' buffer.
+
+Fri Sep 21 16:04:59 1990 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * isearch.el (nonincremental-search): Bind cursor-in-echo-area
+ only as long as necessary.
+
+Thu Sep 20 14:06:22 1990 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * uncompress.el (uncompress-while-visiting): Make buffer writable.
+
+Tue Sep 18 08:53:22 1990 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * doctor.el (doctor-member, doctor-cadr, doctor-caddr): Renamed.
+ (doctor-cddr): Renamed.
+
+Thu Sep 13 22:23:01 1990 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * x-mouse.el (x-mouse-set-point): Compensate for hscroll.
+
+Tue Sep 11 18:14:21 1990 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * loadup.el: Handle dump-emacs-data if defined.
+
+Sat Sep 8 15:30:30 1990 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * ftp.el (ftp-sentinel): Bind buffer-read-only only very locally.
+ (ftp-command): Ignore output lines with no status code.
+
+Fri Sep 7 13:25:37 1990 Chris Hanson (cph at kleph)
+
+ * scheme.el: Don't treat #| ... |# as comment syntax. Emacs
+ doesn't handle it correctly, and when `indent-sexp' sees #| it
+ inserts a semicolon in the comment column.
+
+Thu Sep 6 17:04:03 1990 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * simple.el (kill-comment): Eliminate recursive-edit.
+
+Tue Sep 4 18:15:10 1990 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * ftp.el (ftp-write-file): Accept status 125 as normal.
+
+Wed Aug 29 18:19:46 1990 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * rmail.el (rmail-search): Call rmail-maybe-set-message-counters.
+
+Tue Aug 28 13:12:40 1990 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * isearch.el (isearch): Do regexp-quote for what ^W and ^Y get.
+
+Thu Aug 16 13:31:56 1990 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * vi.el (vi-next-line): Use next-line-internal.
+ * vip.el (vip-next-line): Likewise.
+
+ * telnet.el (telnet-mode-map): Take out copy-last-shell-input.
+
+ * time.el (display-time-filter): Check that file is non-empty.
+
+Wed Aug 15 18:31:16 1990 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * x-win.el (x-new-display): Define only for X10.
+
+Thu Aug 9 17:36:45 1990 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * replace.el (occur-mode-goto-occurrence): Calculate from
+ beginning of line in *occur* buffer.
+
+Tue Jul 31 23:21:10 1990 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * files.el (find-alternate-file): Nothing special for read-only buf.
+
+Sun Jul 29 14:18:37 1990 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * time.el (display-time-filter): Compute inbox name from user.
+
+Thu Jul 26 20:44:37 1990 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * help.el (view-lossage): Use insert, not `newline'.
+
+ * info.el (Info-find-node): Set case-fold-search for tag tbl buffer.
+
+Wed Jul 18 16:23:10 1990 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * files.el (save-buffers-kill-emacs): Improve confirmation msg.
+
+Sun Jul 15 22:34:33 1990 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * register.el (view-register): Don't ignore first line of rect.
+
+Wed Jul 4 15:35:44 1990 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * time.el (display-time-filter): Create the string here.
+ The output sent by the subprocess no longer matters.
+ (display-time): Run "wakeup", not "loadst".
+
+Sat Jun 30 13:07:32 1990 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * dbx.el: Use C-x SPC for setting break point.
+
+Wed Jun 27 14:33:55 1990 Richard Stallman (rms at mole.ai.mit.edu)
+
+ * paragraphs.el (start-of-paragraph-text): Avoid infinite loop.
+
+Fri Jun 22 13:30:24 1990 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * rmail.el (rmail): Ignore local variable specs in rmail file.
+
+Wed Jun 20 11:43:17 1990 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * float.el: Provide 'float.
+
+Tue Jun 19 21:06:48 1990 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * page.el (what-page): Reckon from beginning of line.
+
+Tue May 29 13:01:25 1990 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * scheme.el (run-scheme): Autoload deleted. Done in loaddefs.
+
+Sat May 26 17:44:57 1990 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * compile.el (next-error): Use set-buffer, not switch-to-buffer,
+ before parsing.
+
+Fri May 25 14:14:51 1990 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * files.el (save-buffers-kill-emacs): Fix bugs in testing
+ for modified buffers.
+
+ * subr.el (undo-start, undo-more): New functions.
+
+Mon May 21 14:53:38 1990 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * time.el (display-time): Local cleanup.
+
+ * simple.el (kill-comment): Local cleanup.
+
+ * buff-menu.el (Buffer-menu-buffer): Simplified.
+ Set Buffer-menu-buffer-column initially.
+
+ * rmail.el (rmail): Don't assume mode of existing buffer is rmail.
+ If not, switch to rmail-mode, unless it is rmail-edit-mode.
+
+Fri May 18 17:59:41 1990 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * lisp-mode.el (indent-sexp): Typo in name inner-loop-done.
+ * c-mode.el (indent-c-exp): Likewise.
+
+Sat May 12 16:53:35 1990 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * info.el (Info-read-subfile): Ignore blank lines in split file list.
+
+Tue May 1 14:49:46 1990 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * replace.el (occur): Avoid infinite loop at end of buffer.
+
+Mon Apr 30 20:54:47 1990 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * float.el (float-to-string):
+ Adjust POWER when rounding makes new digit.
+
+Sat Apr 28 17:51:24 1990 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * files.el (save-buffers-kill-emacs): Query here about modified
+ buffers and active processes.
+
+Wed Apr 25 17:12:08 1990 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * simple.el (next-line-internal): Handle track-eol more cleanly.
+
+Thu Apr 12 21:48:01 1990 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * startup.el (normal-top-level): Don't check envvar PWD on vms.
+
+Thu Apr 5 16:41:44 1990 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * rmailout.el (rmail-output-to-rmail-file): Set message counters
+ before inserting in a file being visited.
+
+ * startup.el (command-line-1): Always erase *scratch*, not current buf.
+
+Tue Apr 3 04:53:01 1990 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * fill.el (fill-individual-paragraphs): Anchor regexp for MAILP=t.
+
+Sun Mar 18 23:03:33 1990 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * c-mode.el: Doc fix.
+
+Fri Mar 9 18:24:21 1990 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * rnewspost.el (news-mail-reply, news-reply, news-post-news):
+ Include newline before the blank line, when narrowing.
+
+Thu Feb 1 02:21:56 1990 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * texinfmt.el (batch-texinfo-format): Paren error on (setq error 1).
+
+Thu Jan 4 21:09:29 1990 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * doctor.el: Delete spurious symbol at top level.
+
+Sat Dec 16 08:59:00 1989 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * c-mode.el (c-backward-to-noncomment): Stop better at beg of bfr.
+
+Wed Nov 8 15:56:52 1989 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * debug.el (debug): No need to check match-data for invalid markers.
+
+Mon Nov 6 01:20:59 1989 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * server.el (server-done): Add space to error message.
+
+Sat Oct 14 01:56:27 1989 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * paragraphs.el (forward-paragraph): Don't hang at eob.
+
+Tue Aug 15 21:41:10 1989 Richard Stallman (rms at hobbes.ai.mit.edu)
+
+ * Version 18.55 released.
+
+ * files.el (basic-save-buffer): If rename of precious file fails,
+ don't try to delete it after new version is written.
+
+Wed Aug 9 19:26:25 1989 Chris Hanson (cph at kleph)
+
+ * xscheme.el: From the RCS change log:
+
+ (1.23) Guarantee that the process-filter's state is correctly
+ updated before calling any code that can possibly allow more input
+ to be read from the process.
+
+ (1.22) Remove filter queuing mechanism. Rewrite filter state
+ machine to be iterative instead of tail-recursive. Move all C-c
+ commands to control characters.
+
+ (1.21) Force control-g synchronization always. Turns out BSD had
+ the same problem as hp-ux.
+
+ (1.20) Don't use second argument to `interrupt-process' and
+ `quit-process'. Apparently that causes difficulties under Ultrix.
+
+Thu Jul 20 02:02:33 1989 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * info.el (Info-follow-reference): Handle newline and indentation
+ immediately after *note.
+
+ * hideif.el (hif-tokenize): Recognize `defined', not `hif-defined',
+ in the input.
+
+Tue Jul 4 20:27:28 1989 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * mailalias.el (build-mail-aliases): Accept `group' as synonym.
+
+ * nroff-mode.el (electric-nroff-mode): Arg now optional.
+
+ * man.el (insert-man-file): Handle HP's directories with .Z in
+ their names.
+
+Sun Jun 25 12:45:05 1989 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * rmail.el (rmail, rmail-insert-inbox-text): For login name,
+ try LOGNAME, USER, and user-login-name.
+ * mail-utils.el (rmail-dont-reply-to): Likewise.
+
+Tue Jun 20 14:03:54 1989 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * term/x-win.el: If x-sigio-bug is non-nil, don't use interrupts.
+
+Thu Jun 8 12:09:14 1989 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * spell.el (spell-region): Downcase misspelled word.
+
+Tue Jun 6 19:58:01 1989 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * chistory.el (list-command-history): Go to history buffer
+ before examining its text.
+
+Fri Jun 2 16:04:14 1989 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * rmail.el (rmail-convert-to-babyl-format): Generalize time zone fmt.
+ (rmail-nuke-pinhead-header): Likewise.
+
+Wed May 31 18:05:20 1989 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * cmacexp.el (c-macro-expand): Handle \-continuation of macros.
+
+Wed May 17 14:27:38 1989 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * rmail.el (rmail-nuke-pinhead-header): Accept space before
+ numeric time zone in From line.
+
+ * sendmail.el (sendmail-send-it): Always pass -f option.
+
+Fri May 12 22:19:37 1989 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * term/s4.el: Don't define M-9, M-0.
+ Typo in defn of M-N I.
+
+Wed Apr 26 16:17:02 1989 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * Version 18.54 released.
+
+ * term/xterm.el: Set reset-terminal-on-clear.
+
+Wed Apr 12 10:45:30 1989 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * picture.el (picture-tab): Dumb errors in prefix-arg case.
+
+Tue Apr 11 01:04:53 1989 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * lpr.el (print-region-1): For tab-conversion case, insert specd range.
+
+Thu Apr 6 12:27:21 1989 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * startup.el (normal-top-level): Use PWD envvar to set default dir.
+ (command-switch-alist): Doc fix.
+
+ * rmail.el (rmail-convert-to-babyl-format):
+ Bind case-fold-search to t for mmdf case.
+
+ * rmail.el (rmail-convert-to-babyl-format, rmail-nuke-pinhead-header):
+ Accept spaces at end of Unix-style From line.
+
+Sun Apr 2 00:24:51 1989 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * paths.el (rmail-spool-directory): Treat silicon-graphics-unix
+ like usg.
+
+Tue Mar 14 17:23:47 1989 Randall Smith (randy at sugar-bombs.ai.mit.edu)
+
+ * rmail.el (rmail-convert-to-babyl-format): reset case-fold-search
+ to true in the mmdf case.
+
+Mon Mar 13 16:57:03 1989 Randall Smith (randy at sugar-bombs.ai.mit.edu)
+
+ * tex-mode.el (TeX-common-initialization): Made lines beginning
+ with % separate paragraphs.
+
+Thu Feb 23 06:47:13 1989 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * Version 18.53 released.
+
+ * tex-mode.el (TeX-start): Wait 1 second for TeX to start.
+ (TeX-common-initialization): Make comment-start-skip find comment
+ at start of a line.
+ (TeX-region): don't include previous line (before start) in the header.
+
+ * autoinsert.el: Change defconst to defvar.
+
+Wed Feb 15 03:55:23 1989 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * dbx.el (run-dbx): Set dbx-process.
+ (dbx-stop-at): Use that to decide where to send the string.
+
+Thu Dec 29 14:23:37 1988 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * compile.el (compilation-sentinel): Set OPOINT, OMAX in proper buffer.
+
+Wed Dec 28 23:07:35 1988 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * debug.el (cancel-debug-on-entry): Paren error in case for macros.
+
+ * spell.el (spell-region): Don't lose if `spell-filter' is local.
+
+ * texinfmt.el (texinfo-format-defun-1): Fix bug in &-kwds in @defun.
+ (texinfo-format-emph): Rescan the argument.
+
+ * lpr.el (print-region-1): sysV wants different options.
+
+ * rmail.el (rmail-convert-to-babyl-format):
+ Do case-significant searches.
+
+Thu Sep 1 14:22:30 1988 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * Version 18.52 released.
+
+ * fortran.el (fortran-split-line): Add space before continuation-char.
+
+Mon Aug 29 15:57:20 1988 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * mh-e.el: New version from Larus.
+
+Sun Aug 21 21:05:08 1988 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * view.el (view-mode): Initially view-scroll-size is nil.
+ (view-scroll-size): If it's nil, return (view-window-size).
+
+Thu Aug 18 14:21:41 1988 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * fill.el (justify-current-line): Skip fill-prefix before whitespace.
+
+ * spell.el (spell-region): Change minibuffer prompt.
+
+Mon Aug 15 19:37:27 1988 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * add-log.el (add-change-log-entry): Log filename is now an arg;
+ prompt for it with `interactive'.
+ (add-change-log-entry-other-window): Always use default log filename
+ and never prompt for anything.
+
+Sat Aug 13 14:59:02 1988 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * simula.el: New version from obh.
+
+ * add-log.el (add-change-log-entry): New arg OTHER-WINDOW.
+ (add-change-log-entry-other-window): New fn.
+ * loaddefs.el: Autoload that fn and put on C-x 4 a.
+
+Thu Aug 11 22:43:01 1988 Chris Hanson (cph at kleph)
+
+ * xscheme.el (xscheme-cd): New function to guarantee that `cd'
+ happens in Scheme process buffer.
+
+Mon Aug 8 08:09:17 1988 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * life.el, saveconf.el, doctex.el: New files.
+
+ * files.el (create-file-buffer): Avoid empty buffer name for root dir.
+ * dired.el (dired-find-buffer): Let create-file-buffer do more work.
+ (dired-noselect): Use directory-file-name, file-name-as-directory.
+
+Thu Aug 4 15:26:44 1988 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * server.el (server-process-filter): Handle +NNN to specify linenum.
+ (server-visit-files): Arg is now alist of (FILENAME . LINENUM).
+
+ * server.el (server-visit-files): criterion for revert is if either
+ buffer or file has changed.
+
+ * abbrev.el: Doc fix.
+ * files.el:
+
+Wed Aug 3 12:28:05 1988 Robert J. Chassell (bob at frosted-flakes.ai.mit.edu)
+
+ * texinfo.el: Changed fill-colum from 75 to 72. The larger
+ fill-column causes numerous overfull hboxes in TeX when you are
+ writing Emacs Lisp code that will be formatted as a Texinfo example.
+
+Sun Jul 31 06:46:43 1988 Richard Stallman (rms at frosted-flakes.ai.mit.edu)
+
+ * rmailsum.el (rmail-new-summary): Always go to line for current msg.
+ (rmail-summary-exit): Delete just current window, and that
+ only if Rmail was already in another window.
+
+Fri Jul 29 13:45:27 1988 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * tags.el: provide 'tags.
+
+Tue Jul 26 16:30:30 1988 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * info.el (Info-follow-reference): Handle extra newlines, tabs or
+ spaces inside of cross-references.
+
+ * outline.el: doc fix.
+
+Sat Jul 23 17:05:13 1988 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * loaddefs.el: autoload texinfo-format-region.
+
+Fri Jul 22 05:11:50 1988 Richard Stallman (rms at frosted-flakes.ai.mit.edu)
+
+ * simple.el (transpose-subr-1): Error if regions overlap.
+
+ * dired.el (dired-flag-file-deleted): Directories no longer special.
+ * dired.el (dired-do-deletions): If deleting a dir, run `rmdir'.
+
+Tue Jul 19 00:43:31 1988 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * ftp.el (ftp-find-file-or-directory): Typo in arg name.
+
+Mon Jul 18 00:24:40 1988 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * c-fill.el: New file.
+
+ * compile.el (compilation-error-regexp): Exclude colon from filename.
+
+Sun Jul 17 13:43:49 1988 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * view.el: `h' ran undefined command; make it like `?'.
+
+Sat Jul 16 22:25:36 1988 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * spell.el (spell-region): Run spell-filter to alter the text
+ before actual checking.
+
+Fri Jul 15 04:10:30 1988 Richard Stallman (rms at frosted-flakes.ai.mit.edu)
+
+ * rmailsum.el (rmail-make-basic-summary-line): If sender is self,
+ show recipient instead, with `to:'.
+
+Wed Jul 13 13:36:36 1988 Richard Stallman (rms at wheat-chex.ai.mit.edu)
+
+ * files.el (auto-save-file-name-p): doc fix.
+
+Tue Jul 12 21:58:17 1988 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * paths.el (rmail-spool-directory): Handle RTU like sysV.
+
+Sun Jul 10 14:43:44 1988 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * compile.el (compile1): use set-buffer, not switch-to-buffer.
+
+ * startup.el (command-line): strip hyphens one by one from TERM type.
+
+Tue Jul 5 15:11:42 1988 Chris Hanson (cph at kleph)
+
+ * texinfmt.el: Add support for @defun and related commands.
+
+Tue Jul 5 14:00:46 1988 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * loadup.el: Avoid setting the global variable `name'.
+
+Mon Jul 4 12:21:03 1988 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * rmail.el (rmail-make-in-reply-to-field): Use doublequotes, not
+ parens, around sender name in rfc822 mode.
+
+ * info.el (Info-read-subfile): Don't lose if subfile header isn't
+ same length as main file header.
+
+Sun Jul 3 10:37:05 1988 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * shell.el (shell-send-input): Put bound on search for prompt.
+
+Fri Jul 1 10:07:14 1988 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * autoinsert.el: New file.
+
+ * text-mode.el (center-region): Don't let end-of-region
+ become wrong when insertion/deletion is done.
+
+ * info.el (Info-find-node): Typo in regexp.
+ (Info-following-node-name): At open paren, continue to close.
+
+ * tags.el (list-tags): Terminate scan on end-of-buffer.
+
+Thu Jun 30 10:09:19 1988 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * loaddefs.el (auto-mode-alist): C mode for `.cc'.
+
+Mon Jun 27 12:22:11 1988 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * paths.el (rmail-spool-directory): Treat unisoft like usg.
+
+ * texinfo.el (texinfo-show-structure): New function.
+ (texinfo-insert-*): Several new functions.
+ (texinfo-mode-map): New keymap.
+
+ * dired.el: provide 'dired.
+
+Thu Jun 23 11:02:37 1988 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * files.el (hack-local-variables): Ignore `eval' if running as root.
+
+Wed Jun 22 10:33:39 1988 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * nroff-mode.el (nroff-brace-table): Add G1 vs G2.
+
+Tue Jun 21 04:43:41 1988 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * spell.el (spell-region, spell-string): Fix typo `spell-cmd'.
+
+Sun Jun 19 15:35:21 1988 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * lpr.el (lpr-command): New variable holds the shell command to
+ print a file (normally "lpr").
+
+Wed Jun 15 06:13:32 1988 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * rnewspost.el (news-inews): run news-inews-hook.
+
+ * rmail.el (rmail-show-message): run rmail-show-message-hook.
+
+Sun Jun 12 10:55:47 1988 Richard Stallman (rms at gluteus.ai.mit.edu)
+
+ * keypad.el: Additional conventional chars added in the comments.
+
+ * text-mode.el: erroneously installed text-mode-syntax-table
+ in current buffer.
+
+Thu Jun 9 05:28:48 1988 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * fill.el (fill-region-as-paragraph): Err if fill-prefix is
+ too long for the fill-column.
+
+ * texinfmt.el (texinfo-format-{region,buffer-1}): Make sure buffer
+ ends in a newline.
+
+Tue Jun 7 12:47:31 1988 Chris Hanson (cph at kleph)
+
+ * xscheme.el (xscheme-process-filter-alist): add escape sequence
+ which instructs Emacs to change the working directory of the
+ Scheme process buffer. This change is required for Scheme runtime
+ library version 14.
+
+Thu Jun 2 06:36:43 1988 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * sendmail.el (mail-do-fcc): avoid insert-buffer (too high level).
+
+Tue May 31 18:12:10 1988 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * outline.el: Must put `\(...\)' around outline-regexp
+ when prepending `^'.
+
+Mon May 30 17:30:18 1988 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * fortran.el, hanoi.el, helper.el, info.el, mlconvert.el, modula2.el,
+ rmail.el, sendmail.el, sort.el, underline.el: doc fixes.
+ * loaddefs.el: autoload doc fixes.
+
+Sat May 28 05:19:41 1988 Richard Stallman (rms at sugar-bombs.ai.mit.edu)
+
+ * help.el (print-help-return-message): Handle pop-up-windows = nil.
+
+ * nroff-mode.el (nroff-brace-table): Add more pairs, for some mm macros
+ (nroff-comment-indent): Recognize ' like period.
+ (nroff-mode): .SK and .OP separate pages.
+
+ * shell.el (lisp-send-defun): Install new, corrected no-process check.
+
+Fri May 27 21:28:20 1988 Richard Stallman (rms at frosted-flakes.ai.mit.edu)
+
+ * c-mode.el (electric-c-terminator): Tests to distinguish labels
+ from other uses of colon failed if inserting at end of buffer.
+
+Tue May 24 15:09:32 1988 Richard Stallman (rms at frosted-flakes.ai.mit.edu)
+
+ * texinfmt.el (texinfo-parse-expanded-arg): like texinfo-parse-line-arg
+ but expand commands inside the arg.
+ (texinfo-index): Use that.
+ (@end ifinfo): Discard terminating newline.
+
+Mon May 23 12:45:52 1988 Richard Stallman (rms at frosted-flakes.ai.mit.edu)
+
+ * files.el (file-name-sans-versions): VMS version can be sep. by `.'.
+ Also delete mysterious line that removes `$__$'.
+
+Sun May 22 14:28:56 1988 Richard Stallman (rms at frosted-flakes.ai.mit.edu)
+
+ * gdb.el (gdb-filter-accumulate-marker): Empty gdb-filter-accumulate
+ since its contents are now in STRING.
+
+ * rnews.el (news-get-pruned-list-of-files): catch errors for
+ read-protected directories.
+
+Fri May 20 00:54:22 1988 Richard Stallman (rms at frosted-flakes.ai.mit.edu)
+
+ * meese.el: Bind off buffer-read-only while changing buffer.
+ Don't add protect-innocence-hook twice.
+
+ * sendmail.el (mail-do-fcc): If fcc file is in a buffer, append there.
+
+Mon May 16 21:17:39 1988 Richard Stallman (rms at frosted-flakes.ai.mit.edu)
+
+ * bibtex.el (bibtex-mode): Delete some keys that were vt100 keypad.
+ (bibtex-DEAthesis): Delete this and its key definition.
+ (bibtex-sun-*): Insert functions.
+
+Sun May 15 19:35:59 1988 Richard Stallman (rms at frosted-flakes.ai.mit.edu)
+
+ * loaddefs.el: Doc fix.
+
+Thu May 12 17:47:35 1988 Richard Stallman (rms at frosted-flakes.ai.mit.edu)
+
+ * tex-mode.el (TeX-region): Pass nil to make-shell as startfile arg.
+
+Wed May 11 14:20:41 1988 Richard Stallman (rms at frosted-flakes.ai.mit.edu)
+
+ * shell.el (make-shell): If PROGRAM is nil, default like M-x shell.
+
+ * tex-mode.el (TeX-region): Used eliminated fn. expand-directory-name.
+
+Tue May 10 21:45:09 1988 Richard Stallman (rms at corn-chex.ai.mit.edu)
+
+ * shell.el (lisp-send-defun): Undo last change.
+
+ * loaddefs.el (rmail-primary-inbox-list): Doc fix.
+
+Sun May 8 15:15:45 1988 Richard Stallman (rms at lucky-charms.ai.mit.edu)
+
+ * man.el (manual-entry): Handle section names > 1 letter.
+
+ * paths.el (manual-formatted-*): Add alternative for Xenix.
+
+Fri May 6 10:49:12 1988 Richard Stallman (rms at frosted-flakes.ai.mit.edu)
+
+ * Version 18.51 released.
+
+ * vms-patch.el (vms-suspend-resume-hook): New fn to find a file
+ after Emacs is resumed on VMS.
+ (vms-suspend-hook): Don't suspend if logical name DONT_SUSPEND_EMACS
+
+ * server.el (server-start): Don't say "restarting" the first time.
+
+ * files.el (revert-buffer): Avoid wta error if autosave turned off.
+
+Tue May 3 08:30:12 1988 Richard Stallman (rms at frosted-flakes.ai.mit.edu)
+
+ * icon.el: New file.
+
+Mon May 2 17:44:49 1988 Brian Fox (bfox at rice-krispies.ai.mit.edu)
+
+ * replace.el (perform-replace): Make `y' do what SPC does, `n' do
+ what DEL does, and `q' do what ESC does. The original set of keys
+ still work.
+
+Sun May 1 17:09:04 1988 Richard Stallman (rms at frosted-flakes.ai.mit.edu)
+
+ * gdb.el (gdb-filter-insert): Save and restore prev. current buffer.
+ (gdb-filter-accumulate-marker): set-buffer should not be done here.
+
+Thu Apr 28 17:46:02 1988 Chris Hanson (cph at kleph)
+
+ * xscheme.el: Force use of pipes for communication with inferior
+ Scheme. This avoids bugs in PTY implementations on various
+ systems.
+
+Mon Apr 25 08:56:41 1988 Chris Hanson (cph at kleph)
+
+ * scheme.el: Add indentation for `with-values'.
+
+Fri Apr 22 07:12:46 1988 Richard Stallman (rms at frosted-flakes.ai.mit.edu)
+
+ * shell.el (shell-send-input, lisp-send-defun): Err right away
+ if shell no process.
+
+ * text-mode.el (center-line): doc fix.
+
+Thu Apr 21 01:00:45 1988 Richard Stallman (rms at corn-chex.ai.mit.edu)
+
+ * texinfmt.el (texinfo-format-region): Select the output buffer
+ at the beginning. Copy the @setfilename command as well as
+ the specified region. At end, put point at top.
+ Accept @bye only at beg of line.
+
+Wed Apr 20 19:20:33 1988 Richard Stallman (rms at frosted-flakes.ai.mit.edu)
+
+ * informat.el (Info-validate): Change message for Next's Previous.
+ Now the word "invalid" must be included in the message string
+ if it is wanted.
+
+Tue Apr 19 00:01:22 1988 Richard Stallman (rms at frosted-flakes.ai.mit.edu)
+
+ * cl-indent.el (common-lisp-indent-hook): Handle ` like '.
+
+ * gdb.el: Completely rewritten filtering mechanism (by cph).
+ Should look the same to the user.
+
+Mon Apr 18 16:17:42 1988 Richard Stallman (rms at frosted-flakes.ai.mit.edu)
+
+ * startup.el (command-line): Treat `_' in term-type name like `-'.
+
+ * term/apollo.el: New file, loads vt100.el.
+
+ * dired.el (dired-mode): Allow no arg--to put any old dir into
+ dired mode. Make it interactive.
+
+ * simple.el (indent-for-comment): If comment-start-skip has \(...\),
+ the delimiter starts where the end of the first pair matches.
+
+ * tex-mode.el (TeX-common-initialization): Add a \(...\) to
+ comment-start-skip so its end is always at start of delimiter.
+
+Thu Apr 14 05:54:37 1988 Richard Stallman (rms at frosted-flakes.ai.mit.edu)
+
+ * paragraph.el (forward-paragraph): Bug in pragraph-ignore-fill-prefix.
+
+ * terminal.el (te-sentinel): Delete whitespace at end of buffer
+ before inserting the message.
+
+ * debug.el (debug): Bind executing-macro to nil; avoid lossage
+ if enter debugger while kbd macro is running.
+
+ * rmailout.el (rmail-output-to-rmail-file):
+ Error if output file is same as current file.
+
+ * rmailout.el (rmail-output): Don't die if rmail-last-file is nil.
+
+Wed Apr 13 10:48:13 1988 Leonard H. Tower Jr. (tower at rice-krispies.ai.mit.edu)
+
+ * rnews.el: fixed mis-documentation.
+
+Wed Apr 13 00:55:00 1988 Richard Stallman (rms at frosted-flakes.ai.mit.edu)
+
+ * dired.el (dired-readin): Print msg on startup and when done.
+
+ * spell.el (spell-command): New var; command to use to invoke
+ the spell program.
+
+ * terminal.el (terminal-emulator): Choose default shell like shell.el.
+ Use /bin/sh for changing env.
+ (te-parse-program-and-args): Use shell-file-name for globbing.
+
+ * dired.el (dired-rename-file): Include old file name in prompt.
+
+ * cal.el (calendar): Convert any nonnull arg to a number.
+
+Tue Apr 12 13:05:18 1988 Chris Hanson (cph at kleph)
+
+ * xscheme.el: Change to print ";No value" when the value of an
+ expression is undefined.
+
+Sun Apr 10 02:33:43 1988 Richard Stallman (rms at frosted-flakes.ai.mit.edu)
+
+ * kermit.el: New file.
+
+ * tex-mode.el (TeX-common-initialization): Make TeX-command, etc.,
+ local here rather than in both callers.
+ Provide 'tex-mode.
+ (TeX-start-shell): Make keymap only once, and reuse it.
+ Pass 'nostartfile, not "/dev/null", to `make-shell'.
+ (set-buffer-directory): Use file-name-as-directory. Don't use...
+ (expand-directory-name): function deleted.
+
+ * simple.el (indent-for-comment): If comment-start-skip matches a
+ string with nonfinal whitespace, the comment delimiter starts
+ after that whitespace (for indentation purposes).
+ Don't modify the buffer if existing indent is correct.
+
+ * cmacexp.el (c-macro-expand): Use cpp to expand macros in the region.
+ * c-mode.el: Autoload that.
+
+ * texinfmt.el (texinfo-format-scan): Guts of texinfo-format-buffer-1
+ split into a new function.
+ Delete handling of C-q, which is not used in Texinfo nowadays.
+ (texinfo-format-region): New function to format a region.
+
+Sat Apr 9 11:48:24 1988 Leonard H. Tower Jr. (tower at frosted-flakes.ai.mit.edu)
+
+ * rnewspost.el (news-post-news, news-reply) No longer re-inits
+ *post-news* buffer, if buffer-modified-p.
+
+Sat Apr 9 03:09:36 1988 Richard Stallman (rms at frosted-flakes.ai.mit.edu)
+
+ * spook.el (shuffle-vector): Rewrite by phr.
+
+ * undigest.el (undigestify-rmail-message): Put space before `unseen'.
+
+ * ada.el, c-mode.el, lisp-mode.el, mim-mode.el, modula2.el, prolog.el,
+ scheme.el: Make paragraph-ignore-fill-prefix locally t in these modes.
+ * paragraph.el (forward-paragraph): Ignore fill-prefix if
+ Make paragraph-ignore-fill-prefix is non-nil.
+
+Fri Apr 8 05:39:13 1988 Richard Stallman (rms at frosted-flakes.ai.mit.edu)
+
+ * man.el, loaddefs.el: Doc fix.
+
+Wed Apr 6 21:06:52 1988 Robert J. Chassell (bob at frosted-flakes.ai.mit.edu)
+
+ * loaddefs.el: added `.texinfo' to the less common extensions
+ section of the auto-mode-alist so that emacs chooses the correct
+ mode for files with this extension.
+
+Fri Apr 1 17:53:57 1988 Richard M. Stallman (rms at wilson)
+
+ * gdb.el (gdb): Specify -cd option to GDB so GDB will use
+ the same path for the dir as the user is using in Emacs.
+
+Thu Mar 24 01:15:15 1988 Richard M. Stallman (rms at wilson)
+
+ * spook.el: New file.
+
+ * nroff-mode.el (forward-text-line): either . or ' starts a request.
+ (nroff-mode): In paragraph-{start,separate}, ditto.
+ (electric-nroff-newline): Don't insert extra newlines.
+
+Wed Mar 23 16:21:02 1988 Richard M. Stallman (rms at wilson)
+
+ * x-mouse.el: Change unshifted clicks for x11.
+ Bind all up-clicks to no-op.
+
+ * term/x-win.el (command-switch-alist): Ignore all X's switches
+ in x11.
+ Don't test fboundness of `x-change-display'.
+ On x11, don't set-input-mode or set term-setup-hook.
+ x-switches feature now broken.
+
+ * term/x11-win.el: Delete this file since X11 is now
+ a subcase of X.
+
+Sun Mar 20 14:23:07 1988 Richard M. Stallman (rms at wilson)
+
+ * rmailkwd.el (rmail-next-labeled-message): Allow space
+ before the label name (since now they are supposed to be there).
+
+ * paths.el (rmail-primary-inbox-list): Don't define it here.
+ * loaddefs.el: Define it here but set it to nil.
+ * rmail.el (rmail): If it's nil, compute the default here.
+ Now we decide $LOGNAME vs $USER at run time, not build time.
+
+ * lisp-mode.el (lisp-indent-line):
+ Single-semicolon comment lines should be indented at comment col.
+
+ * cl-indent.el (lisp-indent-do): Smarter version from Kevin Layer.
+
+ * cl.el (setf): Simplify code produced; don't use `apply'
+ and, if handler isn't a macro, don't bind any temp vars.
+
+ * cl.el: Make and doc strings and error messages use GNU style.
+
+Sat Mar 19 17:18:01 1988 Richard M. Stallman (rms at wilson)
+
+ * hideif.el: New version from liberte@b.cs.uiuc.edu.
+
+ * VMS-oriented bug fixes from David Gentzel.
+
+ * texinfmt.el (texinfo-format-setfilename): expand the filename.
+ (texinfo-do-itemize): Don't indent an empty line.
+ (texinfo-format-printindex): On VMS, use texinfo-sort-region to sort.
+ (texinfo-sort-{region,startkeyfun}): New functions.
+
+ * sort.el: provide 'sort.
+
+ * sendmail.el (mail): Doc fix.
+
+ * help.el (help-with-tutorial): Use expanded file name for making bfr.
+
+ * info.el (Info-find-node): Remove versions from file name.
+ * informat.el (Info-split): Remove versions from file name.
+
+ * bytecomp.el (byte-compile-file, byte-recompile-directory):
+ Remove versions from name of file to write. Good on VMS.
+ (batch-byte-compile): Likewise.
+
+Fri Mar 18 13:11:35 1988 Chris Hanson (cph at kleph)
+
+ * term/x11-win.el (command-switch-alist): Option "-rn" mistakenly
+ omitted from this list.
+
+Fri Mar 18 15:42:19 1988 Richard M. Stallman (rms at wilson)
+
+ * modula2.el: Changes from Michael Schmidt:
+ Better prompting in m2-for. Variables for program name for
+ compilation and for linking. Don't assume executable name
+ comes from module name. m2-toggle knows about .md and .mi files.
+
+ * rmail.el (rmail): Default for C-o is now `xmail';
+ rmail-last-rmail-file now defaults independently to `XMAIL'.
+
+ * lisp-mode.el (lisp-mode): Define C-c C-l as M-x run-lisp.
+
+ * paths.el (rmail-primary-inbox-list): Use rmail-spool-directory
+ as a basis for value of this; avoid redundant decisions.
+
+ * rnews.el (news-update-message-read): typo, cdadr => news-cdadr.
+
+ * gdb.el (gdb): expand `path'; start-process loses if
+ default-directory is not absolute.
+
+ * tags.el (find-tag-tag): Create this function again
+ to hold shared arg-reading code for find-tag and find-tag-other-window.
+ (find-tag, find-tag-other-window): Use find-tag-tag.
+
+ * shell.el (inferior-lisp-mode): lisp-mode-variables needs an arg.
+ Also improve the doc string.
+ * chistory.el (Command-history-setup): Likewise.
+
+Thu Feb 11 01:37:48 1988 Richard Stallman (rms at frosted-flakes.ai.mit.edu)
+
+ * Version 18.50 released.
+
+ * tex-mode.el (tex-mode): Use the default if file has no tex commands.
+
+ * term/vt200.el: Delete vt200-enable-arrows; leave the standard
+ name enable-arrow-keys.
+
+ * version.el (emacs-build-system): Store system name on which
+ Emacs was built.
+ * version.el (emacs-version): Print that system name.
+
+ * vip.el: Install version 3.5 sent by author.
+
+ * man.el (nuke-nroff-bs): New regexp for footers on hpux.
+
+Wed Feb 10 12:34:14 1988 Richard Stallman (rms at frosted-flakes.ai.mit.edu)
+
+ * simple.el (fundamental-mode): Delete fundamental-mode-map.
+
+Mon Feb 8 22:50:08 1988 Richard Stallman (rms at frosted-flakes.ai.mit.edu)
+
+ * paths.el (rmail-primary-inbox-list): Check separately for which
+ directory and which envvar.
+
+Sat Feb 6 18:31:55 1988 Richard Stallman (rms at frosted-flakes.ai.mit.edu)
+
+ * loaddefs.el: Autoload `gdb'.
+
+ * gdb.el: New file, interface to GDB. From Schelter,
+ but rewritten to use the new GDB -fullname feature
+ and the new Emacs overlay-arrow-position feature.
+
+ * dbx.el: New file (Masanobu's version,
+ changed to use overlay-arrow-string).
+
+Thu Feb 4 21:00:23 1988 Richard Stallman (rms at frosted-flakes.ai.mit.edu)
+
+ * mh-e.el: Version 3.4o from Larus.
+
+Sun Jan 31 18:16:14 1988 Richard Stallman (rms at frosted-flakes.ai.mit.edu)
+
+ * term/vt125.el, term/vt240.el: New files:
+ Just load vt100.el or vt200.el.
+
+Thu Jan 28 07:21:54 1988 Richard Stallman (rms at frosted-flakes.ai.mit.edu)
+
+ * tags.el (find-tag-tag): Deleted.
+ * tags.el (find-tag-default): New function returns default tag
+ based on buffer text, or nil.
+ Fix several bugs such as handling of quote-characters,
+ and case of before or after a list or near unbalanced paren.
+
+ * tags.el (find-tag): Use find-tag-default and show default in the
+ prompt while reading the tag.
+
+Sun Jan 24 02:38:17 1988 Richard Stallman (rms at frosted-flakes.ai.mit.edu)
+
+ * undigest.el (undigestify-rmail-message): Accept "Apparently-To".
+
+Fri Jan 22 22:46:19 1988 Richard Stallman (rms at frosted-flakes.ai.mit.edu)
+
+ * edt.el (edt-bind-gold-keypad): New fn so that calls to
+ define-keypad-key are deferred till edt-mode is turned on.
+
+Thu Jan 21 23:11:14 1988 Richard Stallman (rms at frosted-flakes)
+
+ * simple.el (kill-line): doc fix.
+
+Wed Jan 20 03:22:12 1988 Richard Stallman (rms at frosted-flakes)
+
+ * rmail.el (rmail-get-new-mail): If save fails, recount messages.
+ * rmail.el (rmail-revert): Handle revert-buffer; recount messages.
+ * rmail.el (rmail-variables): Set up to use this.
+ * rmail.el (rmail-convert-file): Babyl-mode conversion code
+ moved here from `rmail'.
+
+ * files.el (revert-buffer): Return t if did revert.
+
+Tue Jan 19 21:54:04 1988 Richard Stallman (rms at frosted-flakes)
+
+ * sendmail.el (mail-send-and-exit): Don't delete the window
+ unless an rmail-mode buffer is in the next window.
+
+Tue Jan 19 14:03:23 1988 Chris Hanson (cph at sugar-smacks)
+
+ * xscheme.el: Extensive changes including better documentation, a
+ new major mode `scheme-debugger-mode', and a new format for the
+ modeline when using the Scheme interface.
+
+ The major mode `scheme-debugger-mode' is used when Scheme is
+ running one of the character-driven debugger interfaces. It is
+ like Scheme mode except that evaluation is disabled, and
+ characters that are normally self-inserting instead are
+ transmitted to the Scheme process.
+
+ The modeline is changed so that information about the state of the
+ Scheme process is shown only in buffers whose major mode is
+ `scheme-mode' or one of the related Scheme major modes.
+ Information about the state of the read-eval-print loop is shown
+ only in the Scheme process buffer.
+
+ All of these changes are upwards compatible with versions of
+ Scheme which ran using the previous interface. However, some of
+ the features will not be enabled in older Scheme systems. Newer
+ versions of Scheme (specifically, those newer than release 6.1.1)
+ require the new interface for correct operation. They will not
+ work correctly with older version of this interface.
+
+ * scheme.el: Minor changes to support "xscheme.el" changes.
+ Mostly this involved adding hooks to existing facilities.
+
+Tue Jan 19 05:07:25 1988 Richard Stallman (rms at frosted-flakes)
+
+ * c-mode.el (indent-c-exp): Use new state-element from
+ parse-partial-sexp to handle case of (...newline...) {...
+
+Sun Jan 17 21:53:57 1988 Richard Stallman (rms at frosted-flakes)
+
+ * rmail.el (rmail-display-labels): Preserve buffer bounds correctly.
+ Remove extra spaces from the string before displaying it.
+
+ * rmail.el (rmail-insert-inbox-text): message only if file exists.
+ * rmail.el (rmail-get-new-mail): Don't save if was no new mail.
+
+Fri Jan 15 16:46:17 1988 Richard Stallman (rms at frosted-flakes)
+
+ * info.el (Info-search): Two bugs in indirect files:
+ Failed to search the indirect table right, and failed
+ to recover if nothing found.
+
+Thu Jan 14 00:23:29 1988 Richard Stallman (rms at frosted-flakes)
+
+ * loaddefs.el: Make search-... into user variables.
+
+Mon Jan 11 20:46:54 1988 Richard Stallman (rms at frosted-flakes)
+
+ * rmail.el (rmail-display-label): Put a space before each label
+ name if there wasn't one already. Turns out valid BABYL format
+ requires a space there.
+
+ * rmailkwd.el (rmail-set-label): Expect and write spaces before labels.
+ Eliminate the loop to delete such spaces.
+
+ * rmail.el (rmail-set-attribute): Expect and write spaces before labels.
+ * rmailsum.el (rmail-summary-by-labels): Expect spaces.
+
+ * info.el (Info-find-node): If filename starts with ./,
+ interpret relative to current directory.
+
+Sun Jan 10 15:51:08 1988 Richard Stallman (rms at frosted-flakes)
+
+ * undigest.el: If it fails, delete ALL of the temporary copy.
+
+Wed Jan 6 17:20:59 1988 Richard Stallman (rms at frosted-flakes)
+
+ * paths.el (mh-dir, mh-lib): Add two new alternatives to test for.
+ (For HPUX).
+ * paths.el (manual-formatted-dirlist) [HPUX]:
+ Add a completely new alternative value.
+
+Tue Jan 5 16:56:12 1988 Richard Stallman (rms at frosted-flakes)
+
+ * simple.el (indent-new-comment-line): In a comment, look back
+ for a line with a nonempty comment and indent the comment text
+ like it.
+
+ * lpr.el (print-buffer-1): Use `untabify' to expand tabs,
+ not the `expand' program. Fix other bugs with tab-width != 8.
+
+Sat Dec 26 13:27:00 1987 Richard Stallman (rms at frosted-flakes)
+
+ * c-mode.el (electric-c-terminator, c-indent-line):
+ Don't recognize `case' unless space or tab follows.
+
+Wed Dec 23 17:24:16 1987 Richard Mlynarik (mly at peduncle)
+
+ * loaddefs.el:
+ Update terminal-emualator documentation. (This wasn't done
+ after the last edit.)
+
+ * terminal.el:
+ Split out te-stty-string from function terminal-emulator.
+ Run "sh" if no env var SHELL.
+ Add nonstandard (though useful) NF and LP termcap flags.
+ Fix terminal-emulator documentation. Some comments.
+
+Tue Dec 22 19:34:37 1987 Richard Stallman (rms at frosted-flakes)
+
+ * rnews.el (news-get-pruned-list-of-files): Don't die on
+ unreadable directory.
+
+Mon Dec 21 19:52:15 1987 Richard Stallman (rms at frosted-flakes)
+
+ * window.el (split-widow-{vertically,horizontally}):
+ Make the arg optional.
+
+Wed Dec 9 18:32:21 1987 Richard Stallman (rms at frosted-flakes)
+
+ * picture.el (picture-clear-rectangle): Delete spurious arg.
+
+Tue Dec 8 16:09:28 1987 Richard Stallman (rms at frosted-flakes)
+
+ * rmailout.el (rmail-output): Don't crash if msg has no From.
+
+ * dabbrev.el (dabbrev-expand): Don't print messages.
+
+ * isearch.el (nonincremental-search): Put onto command-history.
+
+ * simple.el (kill-region): Doc fix.
+
+Sun Dec 6 01:22:27 1987 Richard Stallman (rms at frosted-flakes)
+
+ * compile.el (compilation-error-regexp): Last alternative
+ could match spuriously; change `.*' to ` *'. Change may be wrong;
+ nobody knows which program makes error messages this should match.
+
+ * terminal.el: Many fixes: some new termcap entries and fix bugs
+ in others.
+
+ Terminal width and height may be specified.
+ Scrolling is now the default. Enabling or disabling scrolling
+ during use does not really work because it is necessary to change
+ the termcap entry.
+
+ Do `stty new dec' at startup. Without this, you get printing
+ terminal echoing which looks very strange with DEL as the erase
+ char. This may lose on sysV, but the need can't be ignored.
+
+ One known bug remains a mystery: when running `ex', the empty-line
+ command fails to overprint the colon with the text that is
+ printed. The output Emacs receives contains a crlf in place of a cr.
+
+ * startup.el (command-line-1): Don't insert the startup-message
+ in a buffer other than *scratch*. Fixes bug with (rmail) in .emacs.
+
+ * files.el (save-buffer): Don't make a backup if arg is 0.
+ Clean up documentation.
+
+ * tags.el (tags-query-replace): Handle prefix arg like query-replace.
+
+ * replace.el ({keep,flush}-lines): Handle matches split across lines.
+
+Sat Dec 5 03:46:16 1987 Richard Stallman (rms at frosted-flakes)
+
+ * xscheme.el (xscheme-start-process): Put xscheme-mode-string
+ into mode-line-process.
+ * xscheme.el (add-to-global-mode-string): Function eliminated.
+
+ * startup.el: New var window-setup-hook; works like term-setup-hook.
+ * term/x-win.el: Set window-setup-hook instead of term-setup-hook.
+ term-setup-hook now for users only.
+
+Fri Dec 4 19:34:36 1987 Richard Stallman (rms at frosted-flakes)
+
+ * tags.el (find-tag): Better error message when no tag found
+ for substring.
+
+ * lisp-mode.el (emacs-lisp-mode-syntax-table): New variable.
+ Initialize this instead of lisp-mode-syntax-table.
+ * lisp-mode.el (lisp-mode-variables): New arg; if non-nil,
+ initialize lisp-mode-syntax-table unless already done,
+ and install it.
+ * lisp-mode.el (*-mode): Pass an arg to lisp-mode-variables.
+
+ * lisp-mode.el (eval-last-sexp): Use emacs-lisp-mode-syntax-table.
+ * lisp-mode.el (eval-print-last-sexp):
+ * debug.el (debugger-mode):
+ * chistory.el (Command-history-setup):
+ * options.el (Edit-options-mode):
+
+Tue Dec 1 00:48:06 1987 Richard Stallman (rms at frosted-flakes)
+
+ * lisp-mode.el (calculate-lisp-indent): Typo for case within a string.
+ Indent first arg of ordinary function directly under the function
+ name. Remove a call to parse-partial-sexp that always did
+ nothing.
+
+Wed Nov 25 19:14:29 1987 Richard Stallman (rms at frosted-flakes)
+
+ * rmail.el (rmail): Widen and goto beginning before checking format.
+
+Sun Nov 22 00:59:46 1987 Richard Stallman (rms at frosted-flakes)
+
+ * page.el (mark-page): Be more careful about where exactly
+ to put the buffer boundaries. Widen before searching for a page.
+
+Thu Nov 19 18:31:11 1987 Richard Stallman (rms at frosted-flakes)
+
+ * startup.el (command-line-1): Don't (goto-line 0).
+
+ * replace.el (occur-mode): Doc fix.
+
+Wed Nov 11 11:22:13 1987 Richard Stallman (rms at frosted-flakes)
+
+ * dired.el (dired-find-file{,-other-window}): No need to
+ check for a line saying it is a directory, because find-file
+ does that in a better way.
+ * dired.el (dired-view-file): Use file-directory-p to
+ decide whether to call dired.
+
+ * rmail.el (rmail): If buffer already existed and find-file
+ reverts it, recompute the message tables.
+
+Tue Nov 3 07:22:29 1987 Richard Stallman (rms at frosted-flakes)
+
+ * files.el (hack-local-variables): If selective-display
+ is set, next local-variables line starts with either \n or ^M.
+
+Sat Oct 31 22:09:52 1987 Richard Stallman (rms at sugar-smacks)
+
+ * mh-e.el (push): Renamed to mh-push.
+
+ * mailalias.el (define-mail-alias): Fix bug when there was
+ multiple whitespace.
+
+Thu Oct 29 20:39:55 1987 Richard Stallman (rms at frosted-flakes)
+
+ * simple.el (repeat-complex-command, next-complex-command):
+ Rename `arg' to `repeat-complex-command-arg'.
+
+Thu Oct 15 12:46:36 1987 Leonard H. Tower Jr. (tower at frosted-flakes)
+
+ * rnewspost.el (news-inews):
+ commented out -n and -t args in news-inews.
+
+Wed Oct 7 10:54:14 1987 Richard Stallman (rms at frosted-flakes)
+
+ * tex-mode.el (TeX-start-shell): Copy the local map
+ before changing it: don't clobber shell-mode's map.
+
+ * rmail.el (rmail-insert-inbox-text): Print the "getting..."
+ message for all files.
+
+Fri Oct 2 00:30:30 1987 Richard Stallman (rms at frosted-flakes)
+
+ * rnews.el: Rename // to news-/. Rename cadr, etc. to news-cadr, etc.
+ Rename push to news-push and supply a definition for it.
+
+Wed Sep 30 11:50:10 1987 Richard Stallman (rms at frosted-flakes)
+
+ * compile.el (compile1): Save the compilation process
+ across the sit-for.
+
+Wed Sep 16 17:19:40 1987 Richard M. Stallman (rms at prep)
+
+ * Version 18.49 released.
+
+ * debug.el (debugger-mode): mode-class special.
+
+ * buff-menu.el: Typo putting mode-class on `Buffer-menu-mode'.
+
+ * c-mode.el (electric-c-brace): set insertpos after
+ calling newline, since newline might do an auto-fill.
+
+Sat Sep 12 22:47:11 1987 Richard Mlynarik (mly at prep)
+
+ * loaddefs.el, mail-utils.el (rmail-dont-reply-to):
+ Add new variable `rmail-default-dont-reply-to-names' which is used
+ (together with the user's name) as the default value of
+ rmail-dont-reply-to-names. This variable replaces the wired-in
+ constant "info-" in `rmail-dont-reply-to' and is intended to be
+ used in the site-init.el file -- eg "all-ai\\>\\|[0-9]ai\\>\\|info-"
+
+Thu Sep 10 18:46:16 1987 Richard M. Stallman (rms at prep)
+
+ * debug.el (debug): bind default-major-mode normally when
+ creating the backtrace buffer.
+
+ * rmailsum.el (rmail-summary-goto-msg): Avoid error on empty buf.
+
+Mon Sep 7 19:49:56 1987 Richard Mlynarik (mly at prep)
+
+ * rmailsum (rmail-new-summary): Fix scope of `new-summary-line-count'
+
+ * lisp-mode.el (calculate-lisp-indent):
+ Don't fail on first line of defun.
+
+Sun Aug 30 02:20:48 1987 Richard M. Stallman (rms at prep)
+
+ * Version 18.48 released.
+
+ * backquote.el: Rename push to bq-push, and likewise for
+ caar, cadr and cdar. Delete cddr.
+ Definitions for the common-lisp functions
+ were different from those in cl.el and could interfere.
+
+Wed Aug 19 18:07:39 1987 Richard Mlynarik (mly at prep)
+
+ * lisp-mode.el (lisp-indent-hook): Fix braino.
+
+Fri Aug 14 17:55:42 1987 Richard M. Stallman (rms at prep)
+
+ * loaddefs.el (auto-mode-alist): Recognize .emacs file
+ with either Unix or VMS syntax.
+
+ * sun-mouse-fns.el: Renamed to sun-fns.el.
+ * sun-mouse.el, term/sun.el: Rename references too.
+
+ * shell.el (lisp-send-defun-and-go):
+ Call to lisp-send-defun requires an arg.
+
+Fri Jul 31 11:15:46 1987 Leonard H. Tower Jr. (tower at prep)
+
+ * rnewspost.el (news-setup) commented out Posting-Front-End to
+ save USENET bytes
+
+Wed Jul 29 22:12:12 1987 Richard Mlynarik (mly at prep)
+
+ * simple.el (negative-argument):
+ Pass explicit ?- to prefix-arg-internal rather than relying on
+ value of last-command-char (broke when this command wasn't
+ assigned to the "-" key)
+
+ * loaddefs.el: Autoload common-lisp-indent-hook.
+
+ * cl-indent.el:
+ New file which understands common lisp special forms and
+ has hairy indentation-specification templates.
+ (setq lisp-indent-hook 'common-lisp-indent-hook)
+ to enable it.
+
+ * lisp-mode.el (lisp-indent-hook):
+ No need to do save-excursion.
+ Deal with case of car of form being a list (which used to be
+ handled by calculate-lisp-indent)
+
+ * lisp-mode.el (calculate-lisp-indent):
+ Call indent-hook even if looking-at a list.
+ Needed for correct indentation of pleblisp FLET, etc.
+
+Sun Jul 26 20:07:49 1987 Richard M. Stallman (rms at prep)
+
+ * rmailsum.el (rmail-new-summary): Avoid error on empty summary.
+
+ * sendmail.el (mail): Doc fix.
+
+ * c-mode.el (c-backward-to-noncomment): Last change broke it totally.
+
+Sat Jul 25 15:33:26 1987 Richard M. Stallman (rms at prep)
+
+ * paths.el (term-file-prefix): Make it "[.term]" on VMS
+
+ * mlconvert.el: Add a few simple translations.
+
+ * tags.el (visit-tags-table): Reset tag-table-files.
+
+Sat Jul 18 19:37:10 1987 Richard M. Stallman (rms at prep)
+
+ * lpr.el (print-region-1): Make program name conditional on
+ system-type; use "lp" on sysV.
+
+ * keypad.el: Use help-for-help on the `?' key.
+ Provide a default for the `D' key. Change syntax for the
+ control-letters from ^ to `C-'.
+
+ * simple.el (delete-indentation): Do nothing if have arg
+ and on last line of buffer.
+
+ * mailalias.el (define-mail-alias): Call build-mail-aliases
+ if that has not yet been done.
+
+ * mailalias.el (build-mail-aliases): If no newline at eof, invent one.
+
+ * helper.el (Helper-help): Downcase the char before looking in map.
+
+ * informat.el (Info-tagify): The check for a split file
+ searched for the wrong string.
+
+Tue Jun 30 12:37:39 1987 Richard Mlynarik (mly at prep)
+
+ * info.el (Info-menu):
+ If interactive and point is within a menu item,
+ make that item the default for completing-read.
+
+ * man.el (nuke-nroff-bs):
+ Split this function out from manual-entry for users who need to
+ remove stupid control-h characters from text.
+
+ * mh-e.el: Version 3.4m from Larus.
+ Bug fixes plus draft folders.
+
+Mon Jun 29 01:04:03 1987 Richard M. Stallman (rms at prep)
+
+ * vms-patch.el (make-legal-file-name): New function converts any
+ string to a similar string that's a legal VMS filename.
+
+ * picture.el: provide 'picture.
+
+ * blackbox.el (bb-init-board):
+ Use (logand (random) 7) instead of remainder by 8.
+
+Thu Jun 25 21:38:21 1987 Richard M. Stallman (rms at prep)
+
+ * replace.el (perform-replace): Don't exit on no-op comma.
+
+Tue Jun 23 02:09:31 1987 Richard M. Stallman (rms at prep)
+
+ * c-mode.el (electric-c-terminator): Bug if auto-fill
+ while doing an auto-newline. (insertpos off by 1).
+
+ * files.el (set-visited-file-name):
+ Downcase buffer name uniformly on VMS.
+
+Mon Jun 22 22:24:12 1987 Richard M. Stallman (rms at prep)
+
+ * c-mode.el (c-backward-to-noncomment):
+ Don't loop on lines starting in ` #'.
+
+Thu Jun 18 00:38:46 1987 Richard M. Stallman (rms at prep)
+
+ * files.el (set-visited-file-name):
+ Downcase the new buffer name on VMS.
+
+Wed Jun 17 00:39:56 1987 Richard M. Stallman (rms at prep)
+
+ * view.el (View-scroll-lines-forward):
+ If end of buffer is visible, exit view mode.
+
+Mon Jun 15 20:25:55 1987 Richard M. Stallman (rms at prep)
+
+ * rmail.el (rmail-get-new-mail):
+ If file has changed on disk and is read in again,
+ count its messages again.
+
+Wed Jun 10 21:10:01 1987 Richard M. Stallman (rms at prep)
+
+ * Version 18.47 released.
+
+ * startup.el (command-line): Old test for su failed.
+ Now assume su if (user-login-name) != (getenv "USER").
+
+Mon Jun 8 19:31:03 1987 Richard M. Stallman (rms at prep)
+
+ * version 18.46 released.
+
+ * isearch.el (isearch): Typo (3 should be 2) in getting old
+ start-point in reverse regexp search made more liberal.
+
+Mon Jun 8 18:41:28 1987 Chris Hanson (cph at prep)
+
+ * scheme.el (scheme-mode-syntax-table): Typo.
+
+Thu Jun 4 17:14:54 1987 Richard M. Stallman (rms at prep)
+
+ * telnet.el: Doc fix.
+
+Sun May 31 01:20:32 1987 Richard M. Stallman (rms at prep)
+
+ * version 18.45.
+
+ * informat.el (Info-split): Bind case-fold-search to t.
+
+Fri May 29 00:41:16 1987 Richard M. Stallman (rms at prep)
+
+ * lisp-mode.el: Add some comments.
+
+ * replace.el (list-matching-lines): If run on *Occur* buffer,
+ find nothing, rather than getting infinite loop.
+
+Thu May 28 16:41:41 1987 Richard M. Stallman (rms at prep)
+
+ * simple.el (backward-delete-char-untabify):
+ Use insert-char to insert the spaces. Wins for large tab-width.
+
+Thu May 28 15:40:36 1987 Chris Hanson (cph at prep)
+
+ * xscheme.el (xscheme-send-current-line): Send the line to Scheme
+ AFTER writing the newline which acknowledges the command.
+ Otherwise the process-mark can end up in the wrong place.
+
+Thu May 28 12:24:54 1987 Richard M. Stallman (rms at prep)
+
+ * texinfmt.el (texinfo-format-printindex): Pass -d to `sort'.
+ This makes entry `Foo' precede `Foo Bar'.
+
+ * vms-patch.el (create-file-buffer): New VMS-override definition
+ downcases the file name.
+
+Wed May 27 12:44:22 1987 Richard M. Stallman (rms at prep)
+
+ * informat.el (Info-split): Put newlines at end of split files.
+
+ * dabbrev.el (dabbrev-expand): Preserve case in the replacement
+ if that's enabled and the replacement is either all lower case
+ or capitalized.
+ (dabbrevs-search): Don't distinguish possible replacements
+ that match except for case, if new 3rd arg NOCASE is set.
+
+ * ftp.el (various): Ignore errors in accept-process-output.
+
+Mon May 25 23:01:09 1987 Richard M. Stallman (rms at prep)
+
+ * sun-mouse-fns.el (mouse-scroll-proportional):
+ Scroll proportional to current restrictions.
+ * sun-mouse-fns.el (enable-mouse-in-buffer-list):
+ Make mouse do something on *Buffer List*.
+
+Sat May 23 18:30:02 1987 Richard M. Stallman (rms at prep)
+
+ * shell.el (kill-output-from-shell): Save final unfinished line.
+
+Thu May 21 17:37:45 1987 Richard M. Stallman (rms at prep)
+
+ * c-mode.el (calculate-c-indent, indent-c-exp):
+ When using c-continued-statement-offset, if line starts
+ with an open-brace, add c-continued-brace-offset.
+
+Wed May 20 11:38:25 1987 Richard M. Stallman (rms at prep)
+
+ * isearch.el (isearch): When splitting window, any hscroll
+ stays with the text it applied to.
+
+Tue May 19 10:38:25 1987 Chris Hanson (cph at prep)
+
+ * scheme.el (scheme-indent-specform):
+ Do not handle first two distinguished forms specially. All
+ distinguished forms are indented at double scheme-body-indent.
+
+ * scheme.el:
+ Conditionalize MIT-Scheme specific indentation with a flag
+ `scheme-mit-dialect'. Users of other dialects can set this to
+ false to disable that indentation.
+
+Sat May 16 02:16:31 1987 Richard M. Stallman (rms at prep)
+
+ * rmailsum.el (rmail-summary-scroll-msg-{up,down}):
+ Simplify, and make ...-down use scroll-other-window
+ so it avoids changing the selected window.
+
+ * tex-mode.el (TeX-common-initialization): Don't give \
+ any special syntax.
+
+ * dired.el (dired-compress): Fix typo in call to `message'.
+
+ * rmailsum.el (rmail-make-basic-summary-line):
+ When searching for header field names, insist they appear
+ at beginning of line.
+
+ * subr.el (one-window-p): If ARG was nil it was
+ really less-than-three-windows-p.
+ * sendmail.el, electric.el, ehelp.el, rmail.el:
+ Delete temporary duplicate definitions of one-window-p.
+
+Wed May 13 10:28:39 1987 Richard M. Stallman (rms at prep)
+
+ * sendmail.el (mail-setup): New parameter mail-default-reply-to:
+ if non-nil, insert it as a Reply-to field.
+
+ * dired.el (dired-unflag): Doc fix.
+
+ * simple.el (blink-matching-open):
+ Don't use last-input-char; look in the buffer to determine
+ which closeparen is present.
+
+Tue May 12 11:50:22 1987 Richard M. Stallman (rms at prep)
+
+ * loadefs.el (sentence-end): Treat `}' like `)'.
+
+ * buff-menu.el (buffer-menu-mode):
+ Run buffer-menu-mode-hook.
+
+ * modula2.el (m2-newline): Define this missing function.
+
+ * server.el (server-done): Write MH backup with write-region.
+ loaddefs.el: Autoload server-start, not server-edit.
+ (server-start): Change documentation: this is the main entry.
+
+ * startup.el (command-line): If running under `su',
+ use user's original login name to get init file.
+ Otherwise use $HOME.
+
+Mon May 11 17:25:04 1987 Richard M. Stallman (rms at prep)
+
+ * isearch.el (isearch): When splitting window for slow search
+ with temp window at the top, prevent scrolling in main window.
+
+ * term/vt200.el: Correct mapping of Insert key.
+
+ * loaddefs.el (run-scheme): Add an autoload.
+
+Wed Apr 29 14:46:12 1987 Richard Mlynarik (mly at prep)
+
+ * abbrevlist.el (list-one-abbrev-list): Use value returned by sort.
+ (Michael Prange <8704291816.AA13767@prep.ai.mit.edu>)
+
+Wed Apr 29 10:02:00 1987 Leonard H. Tower Jr. (tower at prep)
+
+ * loaddefs.el
+ Updated rnews documentation and added autoload of news-post-news.
+
+Tue Apr 28 15:24:49 1987 Leonard H. Tower Jr. (tower at prep)
+
+ * rnewspost.el (news-post-news, news-reply)
+ Fixed news-show-all-headers bug when *news* buffer was on an
+ article that no longer has a file in the news spool directory
+ tree. Also made both work from almost any buffer in any mode.
+ (Dave Steiner <8704230309.AA03452@topaz.rutgers.edu>)
+
+Tue Apr 28 10:51:16 1987 Richard Mlynarik (mly at prep)
+
+ * files.el (save-buffer):
+ When saving a large file, print a message.
+
+ * terminal.el (te-newline, te-set-window-start):
+ Don't set-window-start unless
+ (eq (selected-window) (get-buffer-window (current-buffer)))
+
+ * startup.el (command-line): -batch => -no-init-file
+
+Thu Apr 23 17:10:41 1987 Leonard H. Tower Jr. (tower at prep)
+
+ * rnewspost.el; rnews.el:
+ added (require 'rnews) and (provide 'rnews), respectively.
+
+Thu Apr 23 12:38:37 1987 Chris Hanson (cph at prep)
+
+ * scheme.el:
+ * xscheme.el:
+ Install new versions of these files to correspond to CScheme
+ release 5. The old `xscheme.el' will not work correctly with the
+ new CScheme release. The new `scheme.el' implements the Scheme
+ standard syntax more correctly.
+
+Thu Apr 23 10:42:53 1987 Richard Mlynarik (mly at prep)
+
+ * loaddefs.el:
+ Autoload `run-prolog'. ".pl" files are in prolog-mode.
+
+ * prolog.el: Fix to prolog-indent-level.
+ (Masanobu UMEDA <8704201111.AA10940@flab.flab.fujitsu.junet>)
+
+ * vip.el: Fixes from Masahiko Sato; Version 2.8
+ (ms@sail.stanford.edu <8704231017.AA11075@nttlab.ntt.junet>)
+
+Wed Apr 15 01:29:41 1987 Paul Rubin (phr at prep)
+
+ * version 18.44 released.
+
+Tue Apr 14 09:55:34 1987 Richard Mlynarik (mly at prep)
+
+ * mailalias.el (build-mail-aliases):
+ Don't treat "alt" as "alias" (delimit "[ \t]+" not "[ \t]*")
+ (sjk <8704140433.AA00840@cancun.ads.arpa>)
+
+Mon Apr 13 08:53:18 1987 Richard Mlynarik (mly at prep)
+
+ * loaddefs.el ((query-)replace-regexp documentation):
+ Use \=\<n> in doc strings now that \< is special in
+ substitute-command-keys.
+
+Sat Apr 11 15:30:17 1987 Richard Mlynarik (mly at prep)
+
+ * server.el: (various):
+ Changes suggested by rlk@athena.mit.edu
+ (<8704032045.AA00797@CHOWPEENTULK.MIT.EDU>)
+
+ * loaddefs.el:
+ Autoload server-edit rather than server-start.
+ [This was later taken out.]
+
+ * dired.el (dired-compress, dired-uncompress):
+ Add "(Un)compressing <file>... done" messages.
+
+ * view.el (view-mode-command-loop):
+ Restore local map of correct buffer, even if user has switched
+ buffers.
+ (jason <19933.545094826@violet.berkeley.edu>)
+
+ * lisp.el (lisp-complete-symbol):
+ Skip over `quote' syntax chars to find real start of symbol.
+ (douglis <8704102143.AA16318@sloth.Berkeley.EDU>)
+
+Fri Apr 10 10:16:51 1987 Richard Mlynarik (mly at prep)
+
+ * mailalias.el:
+ build-mail-aliases: Hack "\\\n" continuation lines.
+ define-mail-alias: Addresses sent to the mailer should be
+ separated by ", ", not " "!!
+
+Wed Apr 8 13:05:41 1987 Richard Mlynarik (mly at prep)
+
+ * rfc822.el (rfc822-addresses):
+ Don't loop trying to report that ";" is an invalid address.
+
+Mon Apr 6 09:21:18 1987 Richard Mlynarik (mly at prep)
+
+ * sun-mouse.el: (sm::window-xy):
+ Agree with `new' args to next-window.
+ (peck@sun.com <8704032106.AA12845@denali.sun.com>)
+
+Fri Apr 3 08:49:27 1987 Richard Mlynarik (mly at prep)
+
+ * term/vt200.el: Fix typo.
+
+Thu Apr 2 12:42:08 1987 Richard Mlynarik (mly at prep)
+
+ * startup.el (command-line):
+ Default init file is "$HOME/.emacs", not "~$USER/.emacs"
+
+Tue Mar 31 10:03:06 1987 Richard Mlynarik (mly at prep)
+
+ * edt.el: Fix typo.
+
+ * mh-e.el (mh-send-letter):
+ "-unique" => "-nopush.
+ (larus <8703311804.AA05788@paris.Berkeley.EDU>)
+
+ * shell.el: Minor doc fixes.
+
+ * rmail.el (rmail-get-new-mail):
+ Handle errors competently. (Don't attempt to
+ handle them, rather than botching the job)
+
+ * rmail.el (rmail-insert-inbox-text):
+ Put ".newmail" file in same directory as rmail-file-name
+ rather than in $HOME. This allows one to read things in
+ even when out of space on one filesystem.
+ Use expand-file-name rather than (concat file "/...")
+ for system-independence.
+ Collect and report errors from `movemail' (rather than
+ saying "(There is no new mail)"!)
+
+ * rmail.el:
+ rms' changes of the 5th of March never made it in.
+ rmail-undelete-previous-message, rmail-next-undeleted-message:
+ Don't call rmail-show-msg if message is already current.
+ Avoids scrolling.
+
+Sun Mar 22 09:26:51 1987 Richard M. Stallman (rms at prep)
+
+ * Version 18.41 released.
+
+ * vip.el (vip-mode): Add this function, which loaddefs.el expected.
+ * vip.el (change-mode): Eliminate emacs-mode-line-format;
+ use change-mode-line when reentering emacs-mode.
+
+ * prolog.el (prolog-mode-variables): comment-column=48.
+ * prolog.el (prolog-consult-region): New arg COMPILE (prefix).
+ Before the region, send one of prolog-{consult,compile}-string.
+ After, send prolog-eof-string or else real eof.
+ Get region bounds using interactive r.
+ * prolog.el (prolog-consult-region-and-go): Similar.
+
+ * info.el (Info-find-node): Don't call Info-mode
+ if already in that mode. Avoids wiping out local variables
+ such as Info-current-file.
+
+Sat Mar 21 13:36:04 1987 Richard M. Stallman (rms at prep)
+
+ * term/sun.el: Define sun-esc-bracket as nil:
+ don't redefine M-[ by default.
+
+ * informat.el (Info-validate): Don't get error while
+ checking for an indirect info file.
+
+Fri Mar 20 10:20:16 1987 Richard M. Stallman (rms at prep)
+
+ * dired.el (dired-{un,}compress): Don't specify path
+ for programs compress and uncompress.
+
+Thu Mar 19 14:56:55 1987 Richard Mlynarik (mly at prep)
+
+ * disassemble.el (disassemble-1):
+ Let print-escape-newlines t around constant printing.
+
+ * terminal.el (terminal-emulator):
+ Quote shell arg as "TERMCAP=foo" not TERMCAP="foo"
+
+Thu Mar 19 14:21:09 1987 Richard M. Stallman (rms at prep)
+
+ * vip.el (string-tail, change-mode-line):
+ Use string manipulation; flush the temp buffer " *working-space*".
+
+Wed Mar 18 11:36:49 1987 Richard M. Stallman (rms at prep)
+
+ * Version 18.40 released.
+
+ * files.el (after-find-file): Use directory-file-name where needed.
+
+Wed Mar 18 10:11:51 1987 Richard Mlynarik (mly at prep)
+
+ * ftp.el (ftp-find-file-or-directory): Paren error.
+
+Tue Mar 17 09:46:29 1987 Richard M. Stallman (rms at prep)
+
+ * server.el (server-visit-buffers): Don't revert a buffer
+ automatically if the file does not currently exist.
+
+ * mh-e.el (mh-list-to-string, mh-page-digest{,-backwards}):
+ Fixes from Larus.
+
+ * server.el (server-start): Kill old server before
+ clearing out its records. Delete any old server socket
+ unconditionally. Mark server process as kill-without-query.
+
+ * files.el (recover-file): Don't try to list directory on vms.
+
+Sat Mar 14 09:39:24 1987 Richard M. Stallman (rms at prep)
+
+ * Version 18.39 released.
+
+Fri Mar 13 19:34:24 1987 Richard M. Stallman (rms at prep)
+
+ * dired.el: New commands dired-{un,}compress,
+ dired-byte-compile, dired-ch{mod,own,grp} and subroutine
+ dired-redisplay. From Jim Cottrell, rbj@icst-cmr.arpa.
+ They are all put on keys.
+
+ * sun-{mouse,mouse-fns,cursors}.el, term/sun.el:
+ New and replacement files from peck@sun.com.
+
+Thu Mar 12 16:17:22 1987 Richard M. Stallman (rms at prep)
+
+ * server.el (server-visit-files): Before trying
+ find-file-noselect, check for existing buffer, and if it
+ isn't modified, revert it unconditionally.
+
+ * mh-e.el (mh-send-letter): Considerable rewrite by Larus;
+ don't know why.
+
+Wed Mar 11 18:11:12 1987 Chris Hanson (cph at prep)
+
+ * sort.el (sort-subr): fix typo in sorting of lists: in case where
+ `sortcar' is not available, and arguments are numbers, was using
+ `cdr' to extract second argument to `sort' (rather than `car').
+
+Wed Mar 11 10:05:35 1987 Richard M. Stallman (rms at prep)
+
+ * tex-mode.el (TeX-comment-indent): In column 0,
+ don't require indenting at least to column 1.
+
+ * vip.el: New version from Sato; handles the EX commands.
+
+ * server.el: New version frm peck@sun, supporting
+ multiple clients.
+
+Tue Mar 10 16:20:48 1987 Richard M. Stallman (rms at prep)
+
+ * outline.el (hide-region-body): Exit loop cleanly
+ no matter which stage reaches eob.
+
+Mon Mar 9 10:21:40 1987 Richard M. Stallman (rms at prep)
+
+ * files.el (hack-local-variables): New optional arg FORCE.
+ If it's nil, and `inhibit-local-variables' is non-nil,
+ then query before installing the file's local variables.
+ * files.el (normal-mode): Pass non-nil FORCE to
+ hack-local-variables if we were called from find-file.
+
+ * shell.el (shell-send-input): Fix typo in condition-case syntax.
+
+ * shell.el (make-shell): Make a TERMCAP env var
+ for term type "emacs" to give the screen width.
+
+Sun Mar 8 08:30:26 1987 Richard M. Stallman (rms at prep)
+
+ * info.el (Info-mode): Make variables Info-current-*,
+ Info-tag-table-marker and Info-history local in Info-mode.
+
+Fri Mar 6 14:55:31 1987 Richard Mlynarik (mly at prep)
+
+ * ftp.el: Paren error.
+
+Thu Mar 5 16:27:47 1987 Richard M. Stallman (rms at prep)
+
+ * sort.el (sort-reorder-buffer): Fix typo `end'->`last'
+ in insertion of the spacing after the last sort record.
+
+ * rmail.el (rmail-undelete-previous-message):
+ Don't call rmail-show-msg if message is already current.
+ Avoids scrolling.
+
+ * rmail.el (rmail-next-undeleted-message): Likewise.
+
+Wed Mar 4 01:21:22 1987 Richard M. Stallman (rms at prep)
+
+ * loaddefs.el (auto-mode-alist): Add .article and .letter
+ as text-mode, for rn.
+
+ * ftp.el (ftp-list-directory): New command.
+ * ftp.el (ftp-find-file-or-directory):
+ Guts of ftp-find-file are now here. 3rd arg is t for a file,
+ nil for listing a directory.
+
+ * mailalias.el (expand-mail-aliases): Correct handling of
+ aliases whose expansions use other aliases, and aliases
+ that are self-referent.
+
+ * c-mode.el (calculate-c-indent): Line at beg of buffer
+ needs no indentation.
+
+Tue Mar 3 21:43:01 1987 Richard M. Stallman (rms at prep)
+
+ * shell.el (shell): New series of variables `explicit-FOO-args'
+ specify args to use when running program FOO as a shell.
+ Supply system-dependent default for explicit-csh-args.
+
+ * mailalias.el (expand-mail-aliases):
+ Fix typo: use build-mail-aliases to gobble redefined mail aliases.
+
+ * loaddefs.el (dired-listing-switches): Doc fix.
+
+Mon Mar 2 15:54:47 1987 Richard Mlynarik (mly at prep)
+
+ * Version 18.38 released.
+
+ * shell.el (make-shell):
+ Use the "env" program.
+ This both simplifies and shortens the code, and makes it
+ environment-implementation-independent.
+
+Mon Mar 2 08:36:03 1987 Chris Hanson (cph at prep)
+
+ * page.el (what-page): Reported wrong page number if invoked
+ exactly to the right of a page-delimiter.
+
+Sat Feb 28 14:28:28 1987 Richard M. Stallman (rms at prep)
+
+ * loaddefs.el (mode-line-modified):
+ New variable for string that indicates modifiedness in mode line.
+
+ * rmail.el (rmail-mode-1): If mode-line-modified is bound,
+ change it rather than mode-line-format.
+ * rmailedit.el (rmail-edit-mode): same thing.
+
+Fri Feb 27 14:06:52 1987 Richard M. Stallman (rms at prep)
+
+ * info.el (Info-follow-reference): Combine multiple spaces
+ in node name before searching. Also helps with newline and
+ spaces.
+
+ * texinfmt.el (texinfo-format-buffer-1):
+ Discard everything after the @bye.
+
+Thu Feb 26 22:02:09 1987 Paul Rubin (phr at prep)
+
+ * texinfmt.el (texinfo-format-emph):
+ Function was accidentally misnamed `texinfo-format'.
+
+Thu Feb 26 02:10:58 1987 Richard M. Stallman (rms at prep)
+
+ * x-mouse.el (x-help, x-buffer-menu):
+ Install definitions of these commands, possible now that
+ xmenu.c is installed.
+
+Tue Feb 24 13:00:44 1987 Richard M. Stallman (rms at prep)
+
+ * edt.el (update-mode-line): New function forces mode line update.
+ * edt.el (backup-mode, advance-mode): Call update-mode-line.
+ Also include a space at front of the word that's displayed.
+ function-map => function-keymap.
+ * edt.el: fix calls to define-keypad-key.
+ * edt.el: fix typo `delete-previous-character'.
+
+Sun Feb 22 23:08:54 1987 Richard M. Stallman (rms at prep)
+
+ * texinfmt.el: Define @cite, @emph and @strong.
+
+Thu Feb 19 16:00:13 1987 Richard Mlynarik (mly at prep)
+
+ * subr.el:
+ (fset 'set-window-buffer 'show-buffer) =>
+ (fset 'show-buffer 'set-window-buffer)
+
+Thu Feb 19 14:25:04 1987 Richard M. Stallman (rms at prep)
+
+ * view.el (view-mode): No longer interactive.
+ Much easier than fixing the problems that happen if it is
+ used wrong.
+
+ * files.el (find-alternate-file): Don't offer save if read-only.
+
+Wed Feb 18 19:32:06 1987 Chris Hanson (cph at prep)
+
+ * simple.el (do-auto-fill): Do not `save-excursion' if
+ do-auto-fill should have exactly the same effect as doing
+ indent-new-comment-line. Otherwise if a fill-prefix or
+ comment-start is inserted, point will be left at the beginning
+ rather than the end of the inserted prefix.
+
+Wed Feb 18 10:20:23 1987 Richard M. Stallman (rms at prep)
+
+ * abbrev.el (abbrev-mode): Update the mode line.
+ * simple.el (overwrite-mode): Update the mode line.
+
+ * term/vt100.el: If there are already keymaps on \e[ amd \eO,
+ use them for the CSI-map and SS3-map.
+
+ * texinfmt.el (texinfo-format-center): @center was missing.
+
+ * isearch.el (isearch): If DEL is not special,
+ it terminates the search as a random control character.
+
+Mon Feb 16 14:56:18 1987 Richard M. Stallman (rms at prep)
+
+ * dabbrev.el: Missing quote in arg to make-variable-buffer-local.
+
+ * man.el (manual-entry):
+ Use insert-man-file instead of insert-file-contents.
+
+ * tex-mode.el (TeX-show-print-queue): Start tex shell
+ if not already done.
+
+ * tex-mode.el (TeX-mode): bound search for % at eol.
+
+Sun Feb 15 18:03:14 1987 Richard M. Stallman (rms at prep)
+
+ * loaddefs.el (completion-ignored-extensions): Add .bin again;
+ scheme is said to use it.
+
+Fri Feb 13 14:40:51 1987 Richard M. Stallman (rms at prep)
+
+ * rmail.el (rmail-insert-inbox-text): Do expand-file-name
+ on names of inbox files.
+
+ * loaddefs.el: Add autoload for server-start.
+
+Mon Feb 9 09:53:27 1987 Richard Mlynarik (mly at prep)
+
+ * Version 18.37 released.
+
+ * rmail.el (rmail-mode-1):
+ Don't rely on mode-line-format being consp.
+
+Sun Feb 8 08:53:07 1987 Richard M. Stallman (rms at prep)
+
+ * shell.el (inferior-lisp-program): New variable is used
+ as program name when starting inferior Lisp.
+
+ * shell.el (lisp-send-defun): Write the text to a temp file,
+ then send a string saying to load the file.
+ inferior-lisp-load-command controls generation of that string.
+ Prefix arg means bring *lisp* buffer onto the screen
+ and scroll it to the end.
+ inferior-lisp-prompt controls recognition of when prompt
+ arrives, indicating no more output coming so scrolling may be done.
+
+ * server.el (server-start): Make "Server" appear in mode line
+ while actual server operation is going on.
+ Do process-kill-without-query also.
+
+ * server.el (various): Call the buffer " *server*", not "*server*".
+
+ * server.el (server-sentinel): Considerable cleanup.
+ Don't ever switch-to-buffer on *server*. Do all parsing in it
+ and finding of files without changing displayed buffers;
+ only then display one buffer that merits it.
+ Eliminate variable old-server-edit-buffer.
+
+ * files.el (save-abbrevs): Default value is nil.
+ * abbrev.el (read-abbrev-file): Set save-abbrevs to t.
+
+ * shell.el (make-shell): Change process-environment
+ to specify EMACS=t, TERM=switch and no TERMCAP.
+
+ * debug.el (debug): Bind print-escape-newlines to t
+ while printing the backtrace.
+
+ * subr.el (run-hooks): Each hook value may be a list of functions
+ as well as a single function.
+
+ * files.el (after-find-file): Wait only after serious messages,
+ not "(New file)" or "File is read-only". And don't redisplay
+ when waiting.
+
+ * mlconvert.el (convert-mocklisp-buffer):
+ Generate mocklisp-style defuns, not Lisp-style,
+ for dummy function ml-foo. Indent the body.
+
+Sun Feb 8 08:42:44 1987 Daniel LaLiberte (liberte at b.cs.uiuc.edu)
+
+ * mlconvert.el (convert-mocklisp-buffer):
+ Insert the starting comment and the `require' after
+ encapsulating non-defuns into defuns.
+
+ * mlconvert.el (fix-mlisp-syntax): Detect and fix the
+ ^LETTER syntax.
+
+Sat Feb 7 22:27:16 1987 Richard M. Stallman (rms at prep)
+
+ * mlconvert.el (convert-mocklisp-buffer):
+ Treat | as alphabetic char. Convert syntax before
+ converting non-defuns to defuns.
+
+Thu Feb 5 07:10:39 1987 Richard Mlynarik (mly at prep)
+
+ * ftp.el (ftp-find-file):
+ Ignore `125's from server.
+
+Tue Feb 3 05:21:10 1987 Richard Mlynarik (mly at prep)
+
+ * simple.el (auto-fill-mode):
+ Update mode-line after changing minor mode.
+
+Tue Feb 3 00:10:47 1987 Richard M. Stallman (rms at prep)
+
+ * mh-e.el (mh-insert-prefix-string):
+ Use explicit loop by lines.
+
+Sun Feb 1 04:39:34 1987 Richard M. Stallman (rms at prep)
+
+ * loaddefs.el: purecopy many strings found in initial var values.
+ Garbage collect in middle of file to reduce storage required
+ for loading. Remove ".bin" from completion-ignored-extensions
+ on Unix since only Symbolics customers would benefit from its presence.
+ Symbolics killed the MIT AI lab; don't do business with them.
+
+ * view.el (view-file): Kill the buffer at the end if it was
+ created just for this and was not modified.
+
+ * userlock.el (ask-user-about-supercession-help):
+ Suggest use of revert-buffer.
+
+ * help.el (print-help-return-message): Don't count minibuffer window
+ when deciding whether there is only one window. Calls one-window-p.
+ * subr.el (one-window-p): New function.
+ * subr.el: Rename some args to reduce number of symbols.
+
+ * electric.el (Electric-pop-up-window):
+ * ehelp.el (with-electric-help):
+ * rmail.el (rmail-forward):
+ * sendmail.el (mail-send-and-exit): Don't count minibuffer window
+ when deciding whether there is only one window.
+ These are done by definining subroutine one-window-p in a way that
+ works in old versions of Emacs.
+
+Fri Jan 30 16:35:48 1987 Richard Mlynarik (mly at prep)
+
+ * loaddefs.el (completion-ignored-extensions):
+ Add ".lbin"
+
+ * mail-utils.el, loaddefs.el (mail-use-rfc822): Doc typo.
+
+Thu Jan 29 03:44:29 1987 Richard M. Stallman (rms at prep)
+
+ * rmail.el (rmail-set-message-counters):
+ * rmail.el (rmail-count-new-messages):
+ Don't bind cursor-in-echo-area.
+
+ * debug.el (debug-on-entry): Doc fix.
+
+ * files.el (rename-auto-save-file): Don't rename if new and old
+ names are the same.
+
+Wed Jan 28 17:55:02 1987 Richard M. Stallman (rms at prep)
+
+ * rmail.el (rmail-mode-1): Don't set mode-line-buffer-identification.
+
+Mon Jan 26 17:15:27 1987 Richard M. Stallman (rms at prep)
+
+ * simple.el (set-variable): Use documentation-property
+ instead of get, for getting variable documentation.
+
+Sun Jan 25 15:46:01 1987 Richard Mlynarik (mly at prep)
+
+ * debug.el (debug):
+ Bind cursor-in-echo-area.
+
+Fri Jan 23 13:19:28 1987 Richard M. Stallman (rms at prep)
+
+ * isearch.el (isearch): In reverse search, wrapping is to end
+ of buffer, not beginning.
+
+ * man.el (manual-entry): Take 1st char of `section' as a
+ substring, not as a char, to pass to `concat'.
+
+ * loaddefs.el (completion-ignored-extensions):
+ Add ".glo", ".idx" and ".lot".
+
+Thu Jan 22 16:09:51 1987 Chris Hanson (cph at prep)
+
+ * shell.el (shell): Do not pass -T flag to `/bin/sh', only to
+ `/bin/csh'.
+
+Thu Jan 22 15:08:24 1987 Richard M. Stallman (rms at prep)
+
+ * scribe.el (scribe-mode): Doc fix.
+ * loaddefs.el (scribe-mode): Doc fix.
+
+ * tex-mode.el (tex-mode): Change tex vs latex discrimination
+ to avoid a slow regexp.
+
+Thu Jan 22 13:06:33 1987 Richard Mlynarik (mly at prep)
+
+ * files.el (find-file-noselect):
+ Call expand-file-name earlier so it is correct in case of errors,
+ file-not-found, etc.
+
+Wed Jan 21 17:00:19 1987 Richard Mlynarik (mly at prep)
+
+ * yow.el, flame.el, doctor.el:
+ Change calls to (random) (lisp reader doesn't read octal "07777")
+
+Wed Jan 21 02:13:17 1987 Richard M. Stallman (rms at prep)
+
+ * Version 18.36 released.
+
+Wed Jan 21 02:13:17 1987 Richard M. Stallman (rms at prep)
+
+ * bytecomp.el (byte-compile-setq-default): New function for
+ special handling needed because setq-default has an unevalled arg.
+
+ * c-mode.el (calculate-c-indent): When finding first statement
+ inside brace-group, `case' is not special unless a colon appears.
+
+ * macros.el (kbd-macro-query): Make C-l call `recenter'.
+
+ * bytecomp.el (byte-compile-setq): Make setq with no args
+ generate a value.
+
+ * bytecomp.el (byte-compile-cond): Notice unconditional clauses
+ and optimize the code generated.
+
+Tue Jan 20 11:48:17 1987 Richard M. Stallman (rms at prep)
+
+ * bytecomp.el (byte-compile-if): Correct test for else-less if's.
+
+ * sun-mouse.el: Delete code to handle resize-blips
+ since they are unnecessary and no longer generated.
+
+ * sort.el (sort-columns): Pass -t\n instead of -b to `sort'.
+
+Mon Jan 19 12:44:42 1987 Richard M. Stallman (rms at prep)
+
+ * loaddefs.el (auto-mode-alist): Recognize .lsp as Lisp mode.
+
+Fri Jan 16 18:09:59 1987 Richard Mlynarik (mly at prep)
+
+ * rmail.el (rmail-count-new-messages),
+ rmailout.el (rmail-output-to-rmail-file):
+ Add optional arg `nomsg' to former, which latter supplies,
+ so that rmail doesn't report counting one appended message.
+
+Thu Jan 15 22:19:17 1987 Richard M. Stallman (rms at prep)
+
+ * shell.el (shell): Flush hpux kludge to use "sh" instead of
+ SHELL, and install another kludge to pass -T if on hpux.
+
+Thu Jan 15 17:08:01 1987 Richard Mlynarik (mly at prep)
+
+ * time.el (display-time-filter):
+ Never eat anything larger than your own head.
+
+Thu Jan 15 16:10:33 1987 Richard M. Stallman (rms at prep)
+
+ * files.el (after-find-file): Sit for 2 sec after warning msg.
+
+Thu Jan 15 09:07:04 1987 Richard Mlynarik (mly at prep)
+
+ * rmail.el (rmail-get-new-mail):
+ (or (verify-visited-file-modtime (current-buffer))
+ (find-file (buffer-file-name)))
+
+ * simple.el (append-next-kill):
+ Make this work when not (interactive-p)
+
+Wed Jan 14 16:40:38 1987 Richard Mlynarik (mly at prep)
+
+ * terminal.el:
+ Can't send ^d chars (004) through the cretinous so-called ptys
+ written by the mindless so-called hackers responsible for un*x
+ (the Operating System of the Future.)
+
+Mon Jan 12 01:08:19 1987 Richard Mlynarik (mly at prep)
+
+ * files.el (basic-save-buffer):
+ Typo.
+
+Sun Jan 11 16:16:15 1987 Richard Mlynarik (mly at prep)
+
+ * ebuff-menu (electric-buffer-list):
+ Typo.
+
+ * buff-menu.el (Buffer-menu-select):
+ If the buffer to select is also marked with ">" only make one
+ window for it.
+
+ * terminal.el (te-filter):
+ Save/restore point from te-saved-point to minimise the lossage
+ vandals can inflict.
+
+Fri Jan 9 15:54:00 1987 Richard M. Stallman (rms at prep)
+
+ * tex-mode.el: New version from Gildea.
+ Many changes.
+
+Fri Jan 9 15:04:45 1987 Richard Mlynarik (mly at prep)
+
+ * novice.el (disabled-command-hook):
+ cursor-in-echo-area.
+
+Fri Jan 9 10:23:13 1987 Richard M. Stallman (rms at prep)
+
+ * mh-e.el (mh-send-letter, mh-fully-kill-draft):
+ Two minor fixes from Larus.
+
+ * files.el (basic-save-buffer): After prompting for
+ filename for non-file buffer, turn on auto-save.
+
+Thu Jan 8 12:05:49 1987 Richard Mlynarik (mly at prep)
+
+ * files.el (set-visited-filename):
+ (kill-local-variable 'revert-buffer-function)
+
+ * hanoi.el (hanoi0), yow.el, flame.el (psychoanalyze-{pinhead,flamer}):
+ Quit if luser types a char rather than inhibiting redisplay for 20
+ minutes!
+
+Thu Jan 8 00:59:16 1987 Richard M. Stallman (rms at prep)
+
+ * sort.el (sort-columns): Fix typo in variable name.
+ Also check for presence of tabs and get error.
+
+Wed Jan 7 13:25:01 1987 Richard M. Stallman (rms at prep)
+
+ * vi.el: New version from wu@crys.wisc.edu.
+ All function and variable names start with `vi'.
+ Some missing vi capabilities now emulated.
+
+ * sun-mouse.el (set-screen-size-and-rdis):
+ was using x as screen height and y as width; exchange.
+
+Tue Jan 6 23:52:52 1987 Richard Mlynarik (mly at prep)
+
+ * term/x-win.el:
+ Set suspend-hook to get an error.
+
+Tue Jan 6 17:35:37 1987 Richard M. Stallman (rms at prep)
+
+ * mh-e.el (mh-write-msg-to-file): Generate buffer " *mh-temp*"
+ if it is missing.
+
+Tue Jan 6 11:53:42 1987 Richard Mlynarik (mly at prep)
+
+ * rmailmsc.el (set-rmail-inbox-list):
+ More informative prompt.
+
+Mon Jan 5 01:15:17 1987 Richard M. Stallman (rms at prep)
+
+ * paths.el: Prefer Berkeley-style formatted manual directories
+ (/usr/mat/cat1...) to ATT-style ones. Pyramid has trouble
+ if it uses ATT dirs in BSD universe.
+
+ * vi.el: New version from wu@crys.wisc.edu.
+
+ * Version 18.35 released.
+
+Sun Jan 4 22:11:20 1987 Richard M. Stallman (rms at prep)
+
+ * picture.el: Fix typo in define-key for C-c<.
+
+Sun Jan 4 21:15:59 1987 Richard Mlynarik (mly at prep)
+
+ * prolog.el:
+ Don't modify current buffer's syntax-table when loading this file.
+
+Sat Jan 3 19:59:41 1987 Richard M. Stallman (rms at prep)
+
+ * x-mouse.el: Define names for the button-up events.
+
+Wed Dec 31 04:19:31 1986 Richard M. Stallman (rms at prep)
+
+ * bytecomp.el (byte-compile-function-form):
+ Was miscompiling (function SYMBOL) by failing to quote SYMBOL.
+
+Sun Dec 28 14:32:22 1986 Richard Mlynarik (mly at prep)
+
+ * userlock.el:
+ Bind cursor-in-echo-area for read-char.
+
+Wed Dec 24 18:31:50 1986 Richard Mlynarik (mly at prep)
+
+ * terminal.el:
+ Lots of things changed.
+ Have to start a shell just to call stty since emacs
+ won't set things up correctly!!! (We end up sometimes
+ execing 5 programs to start up...)
+ Emulator terminal-type capabilities extended somewhat
+ and `command-set' made somewhat emacs-oid in order to make
+ termscript files easier to understand.
+
+Tue Dec 23 02:11:49 1986 Richard M. Stallman (rms at prep)
+
+ * macros.el (insert-kbd-macro): Only look for global key bindings
+ since we don't know how to record local ones properly
+ (and in general there is no way to do it).
+
+ * bytecomp.el (byte-compile-find-vars-1):
+ Cons up and return a macroexpanded version of the form
+ being scanned.
+ Don't look inside a call to `function' or `condition-case'.
+ For catch, look only at first argument.
+
+ * bytecomp.el (byte-compile-find-vars):
+ Return (MACROEXPANDEDFORM . VARSUSED).
+
+ * bytecomp.el (byte-compile-top-level):
+ Use the macroexpanded form returned by byte-compile-find-vars
+ for subsequent compilation. Thus, each macro call is expanded
+ only once.
+
+Mon Dec 22 15:50:58 1986 Richard M. Stallman (rms at prep)
+
+ * subr.el: Delete nth and copy-keymap (now in fns.c and keymap.c).
+
+Mon Dec 22 14:04:15 1986 Richard Mlynarik (mly at prep)
+
+ * texinfmt.el (batch-texinfo-format):
+ Was printing message about source file rather than output file.
+
+Mon Dec 22 13:08:39 1986 Richard M. Stallman (rms at prep)
+
+ * subr.el: Remove `delete-backward-char-untabify',
+ insert `backward-'delete-char'.
+
+Mon Dec 22 11:06:47 1986 Richard Mlynarik (mly at prep)
+
+ * simple.el (undo):
+ Was missing local var `modified'
+
+ * subr.el:
+ Make `set-window-buffer' synonym for obfuscatory `show-buffer'
+ Make 'delete-backward-char-untabify' a synonym for
+ `backward-delete-char-untabify' -- the non-conventional naming of
+ the latter confuses people
+
+Sat Dec 20 23:38:00 1986 Richard Mlynarik (mly at prep)
+
+ * loaddefs.el:
+ Add autoload for sort-regexp-fields.
+
+ * sort.el:
+ Rename skip-fields -> sort-skip-fields to avoid name-conflict
+
+Sat Dec 20 21:51:22 1986 Richard M. Stallman (rms at prep)
+
+ * isearch.el (isearch): Print message "" only if don't set mark.
+ * isearch.el (isearch-message): Put cursor in echo area instead of
+ ellipsis.
+ * isearch.el (isearch-search): use one string-match to check
+ for all errors that mean "incomplete input".
+
+ * files.el (rename-auto-save-file):
+ Alter auto save file name of current buffer, and rename
+ any existing auto save file.
+
+ * files.el (set-visited-file-name): Use rename-auto-save-file
+ if auto save mode is already on.
+
+ * simple.el (undo): If undo-mode clears modified,
+ delete any auto-save file.
+
+Sat Dec 20 17:04:26 1986 Richard Mlynarik (mly at prep)
+
+ * fortran.el:
+ Allow fortran-comment-indent-char to be a string of length 1,
+ since that is what is documented in the printed v18 manuals.
+
+ * terminal.el:
+ Print a help message when emulator starts.
+ Fix a bug in te-escape-help.
+
+ * subr.el (read-quoted-char):
+ Document PROMPT arg.
+
+Fri Dec 19 16:26:05 1986 Richard M. Stallman (rms at prep)
+
+ * lisp.el (lisp-complete-symbol):
+ Don't put pre-completion text on kill ring.
+
+Fri Dec 19 11:31:22 1986 Richard Mlynarik (mly at prep)
+
+ * ftp.el (read-ftp-user-password):
+ Change prompting for user-name
+
+Thu Dec 18 01:40:37 1986 Richard M. Stallman (rms at prep)
+
+ * files.el (recover-file): Supply missing arg in call to error.
+
+ * isearch.el: If search-slow-window-lines is negative, put the
+ search window at the top. Always bind window-min-height to 1.
+
+ * isearch.el: When extending a reverse non-regexp search
+ must not extend past barrier (same idea as below for regexps).
+
+Wed Dec 17 11:44:21 1986 Richard M. Stallman (rms at prep)
+
+ * isearch.el: Combine code for search-repeat-char and
+ search-reverse-char into one cond clause.
+ If search direction is changing, don't greb prev search-string.
+ Otherwise, do grab it if search-string is currently empty.
+
+ * isearch.el: When extending a reverse regexp search string,
+ criterion for extending current match was one off, and also
+ now won't go into the area beyond where last C-r was typed.
+
+ * replace.el (perform-replace): If user types C-l,
+ clear screen, redisplay, and ask again.
+
+ * isearch.el: In regexp isearch, when a ?, * or | is input,
+ back up start of search. New local variable `barrier' is
+ position of original command or of last C-s or C-r; it
+ is saved by isearch-push-state.
+
+Mon Dec 15 09:30:22 1986 Richard Mlynarik (mly at prep)
+
+ * fortran.el:
+ Initialise fortran-mode-abbrev-table correctly.
+
+ * fortran.el:
+ fortran-comment-indent-char should be a character (a fixnum), not
+ a string of length one.
+
+ * rmail.el:
+ Add support for delta-from-UT timezone specs ("EST" = "-0500")
+ Add support for four-character timezone specifications such as NZST
+ [This is actually a bit suspect, since four-character timezone
+ specs violate the rfc822 date format -- one should be using a spec
+ like "+1000" instead]
+
+Fri Dec 12 09:21:03 1986 Richard M. Stallman (rms at prep)
+
+ * loaddefs.el: Delete incorrect entry for .mss in auto-mode-alist,
+ so correct entry is visible.
+
+ * rmail.el (rmail): Initialize rmail-last-{rmail-,}file here
+ rather than when rmail.el is loaded.
+
+ * Version 18.33 released.
+
+ * rnewspost.el: require sendmail.
+
+ * loaddefs.el: Autoload scribe-mode and use for ".mss" files.
+ Autoload modula-2-mode and prolog-mode as well.
+
+ * sendmail.el (mail-mode): Set buffer-offer-save.
+
+ * files.el (save-some-buffers): If user says `n' to "Save
+ abbrevs?", clear abbrevs-changed so won't ask again.
+
+ * files.el (buffer-offer-save): New variable, local in all buffers.
+ * files.el (save-some-buffers): New 2nd arg EXITING.
+ If non-nil, offer to save any nonempty modified buffer
+ in which `buffer-offer-save' is non-nil.
+
+ * sup-mouse.el: New file to handle mouse commands on
+ supdup terminals.
+
+Thu Dec 11 17:59:43 1986 Chris Hanson (cph at prep)
+
+ * man.el: Fix bug in regexp used to nuke footers in hp-ux.
+
+Thu Dec 11 17:52:44 1986 Richard M. Stallman (rms at prep)
+
+ * keypad.el: Fix typo "kill-linee".
+
+Thu Dec 11 14:19:20 1986 Richard Mlynarik (mly at prep)
+
+ * isearch.el (isearch):
+ Never set search-last-string to ""
+
+Wed Dec 10 17:28:20 1986 Richard M. Stallman (rms at prep)
+
+ * help.el (help-for-help): Once long help text is on screen,
+ bind cursor-in-echo-area to t for reading subsequent chars.
+
+ * sort.el (sort-columns): Fix typo (col-beg1 was col-beg
+ and likewise for col-end1).
+
+Tue Dec 9 16:06:45 1986 Richard Mlynarik (mly at prep)
+
+ * terminal.el, ehelp.el:
+ New files.
+ "terminal" still needs a small amount of documentation.
+
+Sat Dec 6 14:28:39 1986 Richard M. Stallman (rms at prep)
+
+ * Version 18.32 released.
+
+ * scribe.el: New file containing scribe-mode.
+ * server.el: New file containing server-start
+ (makes existing Emacs process serve as "the editor" for
+ other programs that want to invoke an editor subprocess.)
+
+Fri Dec 5 01:14:16 1986 Richard M. Stallman (rms at prep)
+
+ * subr.el (substitute-key-definition): [MLY]
+ The definitions are in the cdr's of alist elts, not the cars.
+
+ * mh-e.el: 3.4h from Larus.
+
+ * rmail.el (rmail-get-new-mail):
+ Never bind make-backup-files to t if it was nil before.
+
+ * keypad.el (function-key-sequence):
+ * macros.el (insert-kbd-macro):
+ * vi.el:
+ Pass local map argument to where-is-internal.
+
+ * c-mode.el (c-backward-to-noncomment): Skip ^L like newline.
+
+ * c-mode.el (calculate-c-indent):
+ When checking for continued previous lines, after skipping one,
+ use c-backward-to-noncomment to find next real text.
+ When classifying top-level lines, ignore page breaks;
+ lines ending in } are not continued lines.
+
+ * rmailkwd.el (rmail-set-label):
+ Delete whitespace only next to commas.
+
+ * rmailkwd.el (rmail-nuke-whitespace): Delete this function.
+
+ * sendmail.el (mail-do-fcc): Delete the entire line of an fcc
+ including the newline after it. Was failing to do so
+ if the line had a space or tab at the end.
+
+ * c-mode.el (c-indent-line): Don't think that "else_..."
+ is the keyword "else".
+
+ * rmail.el (rmail-search): For reverse search, use
+ re-search-forward to filter messages; then, once a message is found,
+ use re-search-backward to position point within it.
+
+ * rmail.el (rmail-expunge): Don't bomb if rmail file is empty.
+ * rmail.el (rmail-show-message): If showing message number zero,
+ don't beep, and set point at beginning of it.
+ * rmail.el (rmail-set-message-counters): If no messages, set
+ rmail-current-message to 0.
+
+Thu Dec 4 18:53:38 1986 Richard Mlynarik (mly at prep)
+
+ * ftp.el (ftp-sentinel):
+ Catch time taken/transfer-rate information.
+
+Tue Dec 2 22:35:00 1986 Richard M. Stallman (rms at prep)
+
+ * float.el (float-to-string): Don't infinite-loop if arg is zero.
+
+ * float.el (float-regexp): Accept numbers lacking digits before
+ the point. Accept numbers with a point and no digits after it.
+ Don't get confused by matching just part of the input.
+
+ * float.el (string-to-float): Detect if loading-0s
+ gets to equal the length of digit-string.
+
+Tue Dec 2 15:46:37 1986 Richard Mlynarik (mly at prep)
+
+ * float.el (extract-match):
+ Convert to new re-register regime
+
+Mon Dec 1 18:08:39 1986 Richard Mlynarik (mly at prep)
+
+ * mailalias.el (expand-mail-aliases):
+ Check for case of (eq mail-aliases t) -- can happen if mail-mode
+ is entered without calling mail-setup (eg when trying to recover
+ an autosaved mail file)
+
+Wed Nov 26 17:30:21 1986 Richard Mlynarik (mly at prep)
+
+ * loaddefs.el:
+ mode-line-format should contain (-3 . "%p") rather than "%3p"
+
+ * terminal.el:
+ Use the "env" program
+
+Wed Nov 26 00:07:19 1986 Richard M. Stallman (rms at prep)
+
+ * compile.el (compile1, compilation_sentinel):
+ Don't make *compilation* read-only.
+
+ * simple.el (next-complex-command): fix one-off about
+ largest allowed value of ARG. If attempting to move
+ past beginning or end of history, move to the first or
+ last element and then signal an error.
+
+ * terminal.el: New file, like shell-mode modified to
+ simulate a display terminal for the inferior.
+
+Tue Nov 25 00:04:36 1986 Richard M. Stallman (rms at prep)
+
+ * outline.el (outline-mode): outline-regexp must match at start
+ of line to be a paragraph start.
+
+ * simple.el ({beginning,end}-of-buffer):
+ When buffer-size is large, divide before multiplying
+ to avoid overflow.
+
+ * mailalias.el (expand-mail-aliases):
+ Re-expand the expansions for compatibility with Berkeley mail.
+
+ * ftp.el: New file for visiting remote files using FTP.
+
+Mon Nov 24 14:07:40 1986 Richard M. Stallman (rms at prep)
+
+ * files.el (find-file-noselect): Due to change in
+ insert-file-contents, need not set buffer-file-name if error.
+
+ * paths.el: Correct manual-formatted-dirlist for USG systems.
+
+ * man.el: Use new subroutine insert-man-file to insert files
+ uncompressing if nec. Also uncompact compacted files.
+ Detect sysV footers. Detect headers when section contains a
+ letter (as in 3n). Delete the vars already moved to paths.el.
+
+ * disass.el: new name for disassemble.el to avoid USG truncation.
+ loaddefs.el changed for this.
+
+Mon Nov 24 02:43:08 1986 Chris Hanson (cph at prep)
+
+ * term/supdup.el: Add code for hp-ux which has no binding for the
+ TERMCAP environment variable.
+
+Sun Nov 23 00:03:35 1986 Richard M. Stallman (rms at prep)
+
+ * version 18.31 released.
+
+ * x-mouse.el: New mouse-command keys are C-x C-@.
+
+Sat Nov 22 14:15:11 1986 Richard Mlynarik (mly at prep)
+
+ * bytecomp.el (byte-recompile-directory):
+ Use third arg to `directory-files'
+
+Sat Nov 22 02:26:22 1986 Richard M. Stallman (rms at prep)
+
+ * subr.el: Defvars for global-map, ctl-x-map, esc-map
+ and mouse-map, just so they get doc strings.
+
+Fri Nov 21 15:43:49 1986 Richard M. Stallman (rms at prep)
+
+ * bytecomp.el (byte-compile-file): Bind vms-stmlf-recfm to t
+ around writing the output file.
+
+Fri Nov 21 14:46:37 1986 Leonard H. Tower Jr. (tower at prep)
+
+ * rnews.el, rnewspost.el (caesar-region, news-caesar-buffer-body)
+ Added former from phr, rename latter and modified it to work with
+ former. Changed key-bindings for rename. This gets rid of the
+ interface (which also is ugly) to the UNIX "tr" command.
+
+Fri Nov 21 00:29:13 1986 Richard M. Stallman (rms at prep)
+
+ * mh-e.el (mh-display-msg):
+ Pass non-nil 2nd arg to insert-file-contents
+
+Thu Nov 20 23:57:52 1986 Richard M. Stallman (rms at prep)
+
+ * vip.el (vip-find-char): Use search-forward instead of
+ * yow.el (snarf-yows): scan-buffer. A few other local
+ * man.el (manual-entry): simplifications.
+
+ * bytecomp.el: Don't open-code scan-buffer.
+
+Thu Nov 20 12:33:31 1986 Richard Mlynarik (mly at prep)
+
+ * helper.el:
+ Flush Helper-major-mode, Helper-mode-name:
+ there is a much simpler way of doing this
+ (see new Helper-describe-mode)
+ Make it work for Helper-return-blurb to be buffer-local
+ (this is better than binding it dynamically)
+
+ * ebuffer-menu.el, echistory.el, view.el:
+ Flush references to Helper-{major-mode,mode-name}
+
+Wed Nov 19 22:39:57 1986 Richard M. Stallman (rms at prep)
+
+ * indent.el: Make tab-stop-list a user variable.
+
+ * rmail.el: Undo previous change to rmail-show-message.
+
+Tue Nov 18 08:39:59 1986 Richard Mlynarik (mly at prep)
+
+ * prolog.el (end-of-prolog-clause):
+ Typo
+
+ * ebuff-menu.el:
+ Make "n" and "p" synonymous with "\C-n" and "\C-p"
+
+ * rmail.el (rmail-show-message):
+ With no interactive argument, just move to beginning of current
+ message (like ".") rather than to message 1.
+
+Sun Nov 16 23:32:19 1986 Richard M. Stallman (rms at prep)
+
+ * startup.el: expect window-system to be a symbol, not a string,
+ and concatenate "-win" instead of "-windows" to keep
+ file names short.
+
+ * term/x-win.el: New name for term/X-windows.el
+ needed due to change in dispnew.c re window-systems.
+
+Sun Nov 16 11:04:33 1986 Leonard H. Tower Jr. (tower at prep)
+
+ * rnews.el (news-ignored-headers)
+ removed Organization:, so it's visible to readers.
+
+Fri Nov 14 13:16:48 1986 Richard M. Stallman (rms at prep)
+
+ * Emacs version 18.30 *
+
+ * rmail.el (rmail-forward):
+ Use mail-other-window unless there is only one window visible.
+ Use of `mail' instead in the case of multiple windows on the
+ screen makes it a nuisance to get back to Rmail.
+
+ * outline.el (outline-regexp): ^L starts a header line.
+
+Thu Nov 13 23:38:57 1986 Richard M. Stallman (rms at prep)
+
+ * fill.el (fill-region-as-paragraph):
+ If 1st line starts with fill prefix, exclude that fill
+ prefix from the preprocessing before actual filling.
+ Fixes failure to preserve initial whitespace after a fill prefix.
+
+Tue Nov 11 14:57:25 1986 Leonard H. Tower Jr. (tower at prep)
+
+ * rnews.el (news-show-all-headers)
+ Added code to replace previously deleted (news-get-back).
+
+ * emacsbug.el (report-emacs-bug):
+ Got rid of redundant "on system-name (system-type)" now that
+ (emacs-version) outputs it.
+
+Mon Nov 10 08:54:05 1986 Richard Mlynarik (mly at prep)
+
+ * dired.el (dired-mode):
+ (run-hooks 'dired-mode-hook)
+
+Sun Nov 9 21:59:30 1986 Richard Mlynarik (mly at prep)
+
+ * files.el (set-visited-file-name):
+ (kill-local-variable 'write-file-hooks)
+
+Sun Nov 9 14:28:43 1986 Richard M. Stallman (rms at prep)
+
+ * simple.el (push-mark): Print nothing if minibuffer active.
+
+Sat Nov 8 09:38:18 1986 Richard M. Stallman (rms at prep)
+
+ * rnews.el (news-set-mode-line):
+ Don't change mode-line-format; instead change mode-line-process
+ and mode-line-buffer-identification.
+ Delete unused function `strcpyn'.
+
+ * echistory.el (electric-command-history):
+ Delete no-op `let'.
+
+ * compile.el (compile1): Flush v17 compatibility code to sett
+ mode-line-format.
+ * info.el (Info-set-mode-line, Info-edit): Ditto.
+ * shell.el (shell-mode, inferior-lisp-mode): Ditto.
+ * telnet.el (telnet-mode): Ditto.
+
+ * c-mode.el (calculate-c-indent): When deciding whether
+ a line is a continuation, ignore label-lines.
+ Also ignore preceding lines that end in commas. Consequence:
+ if the preceding line is a continuation, our line
+ is indented just like it (as a continuation of the same thing).
+
+ * loadup.el: look for new file "site-load.el" to preload
+ libraries before the DOC file is read.
+
+Fri Nov 7 19:15:57 1986 Richard M. Stallman (rms at prep)
+
+ * novice.el (disabled-command-hook):
+ Catch errors in `documentation' in case doc file is missing.
+
+ * keypad.el (function-key-sequence):
+ Use cons, not list, to make the definition to search for.
+
+Fri Nov 7 12:30:48 1986 Richard Mlynarik (mly at prep)
+
+ * sort.el (sort-build-lists):
+ Delete CPH's change.
+ This had already been fixed in a different way.
+
+Fri Nov 7 10:40:40 1986 Richard M. Stallman (rms at prep)
+
+ * c-mode.el (calculate-c-indent):
+ A line ending in singlequote-colon now does not make the
+ following line be considered a continuation.
+
+Fri Nov 7 09:14:29 1986 Chris Hanson (cph at prep)
+
+ * sort.el (sort-build-lists):
+ Was not initializing point to the beginning of the region. As a
+ result, if one tried to sort a region where point was at the end
+ and mark at the beginning, nothing would happen.
+
+Thu Nov 6 19:47:21 1986 Richard M. Stallman (rms at prep)
+
+ * subr.el (indent-to-column): New alias for indent-to.
+
+Thu Nov 6 18:09:10 1986 Leonard H. Tower Jr. (tower at prep)
+
+ * rnewspost.el
+ Finish bringing posting and followups (mostly) up to the News 2.11
+ revision of RFC 850 (exceptions noted in rnewspost.el's header).
+ Added function news-reply-yank-original, to be used in lieu of
+ mail-yank-original.
+
+Thu Nov 6 12:46:57 1986 Richard M. Stallman (rms at prep)
+
+ * version.el (emacs-version):
+ Include host name and system type.
+
+ * rmail.el: rmail-edit-current-message moved from C-r to w.
+ Doc string of rmail-mode changed.
+
+ * loaddefs.el (auto-mode-alist, completion-ignored-extensions):
+ Ignore ".blg" and ".bbl". Know modes for ".bbl" and ".bib".
+ Rearrange auto-mode-alist with frequently used elts first.
+
+ * files.el (find-file-noselect):
+ Eliminate incorrect nested or-for-effect within or-for-effect.
+ Bug was it didn't offer to reread a changed file.
+
+Wed Nov 5 16:32:31 1986 Leonard H. Tower Jr. (tower at prep)
+
+ * rnewspost.el (news-reply)
+ Fixed bug when point was outside of header on invocation.
+ Added References: header line per RFC850.
+
+Wed Nov 5 12:48:44 1986 Richard M. Stallman (rms at prep)
+
+ * files.el (file-name-sans-versions):
+ Fix one more typo in name of argument variable.
+
+Wed Nov 5 11:01:57 1986 Richard Mlynarik (mly at prep)
+
+ * mh-e.el:
+ Version 3.4d from Larus
+
+Wed Nov 5 10:10:53 1986 Richard M. Stallman (rms at prep)
+
+ * novice.el (disabled-command-hook):
+ Clean up the message in the case of coming from M-x ...
+
+Tue Nov 4 17:55:33 1986 Richard M. Stallman (rms at prep)
+
+ * various files (dired-mode, Edit-options-mode, rmail-mode,
+ rmail-summary-mode, rmail-edit-mode, Buffer-menu-mode):
+ Give these symbols `special' as a `mode-class' property.
+
+ * dired.el (dired-mode): Take out local value for
+ default-major-mode. The mode-class property now makes sure
+ new buffers are not made in dired-mode.
+
+Tue Nov 4 16:58:49 1986 Leonard H. Tower Jr. (tower at prep)
+
+ * rnews.el
+ Add several C-C C-F C-letter fields in RFC 850.
+
+Tue Nov 4 11:56:46 1986 Richard Mlynarik (mly at prep)
+
+ * paragraphs.el (various):
+ (interactive "*") needed in some places.
+
+Mon Nov 3 23:31:42 1986 Richard M. Stallman (rms at prep)
+
+ * help.el (variable-at-point):
+ Catch all errors anywhere within. Fixes bug when
+ `C-h v' was done with point after an `('.
+
+Sun Nov 2 17:30:54 1986 Richard Mlynarik (mly at prep)
+
+ * files.el (backup-buffer):
+ "neq" isn't defined -- use /=
+
+Sat Nov 1 00:28:14 1986 Richard Mlynarik (mly at prep)
+
+ * simple.el (open-line):
+ interactive "*"
+
+ * rmail.el (rmail-variables):
+ rmail-keywords should be buffer-local
+
+ * undigest.el:
+ Another broken-un*x-mailer-compensation fix from rlk.
+
+ * file.el (file-name-sans-version):
+ Fix typo in VMS case.
+
+Thu Oct 30 20:12:01 1986 Richard Mlynarik (mly at prep)
+
+ * xscheme.el:
+ defvar scheme-program-name, not defconst
+
+ * keypad.el (setup-terminal-keypad):
+ Use correct format for indirect keymap entries.
+
+Wed Oct 29 19:07:03 1986 Leonard H. Tower Jr. (tower at prep)
+
+ * rnews.el, rnewspost.el:
+ Created later from parts of former to speed up initial rnews load
+ (also debugging time). Added autoloads as appropriate. The mail and
+ posting commands are most often not used in an rnews session.
+
+Wed Oct 29 18:53:37 1986 Richard Mlynarik (mly at prep)
+
+ * startup.el (command-line):
+ VMS sys$login:.emacs
+
+Wed Oct 29 14:13:10 1986 Leonard H. Tower Jr. (tower at prep)
+
+ * rnews.el (news-inews):
+ Added save-excursion call. Got bury-buffer at right nesting level.
+ Got rid of unneeded code.
+
+ * rnews.el (news-rotate-buffer-body):
+ Added and modified this function written by paul@media-lab.mit.edu.
+ Bound it to C-c C-r in both news and post-news modes.
+
+ * rnews.el:
+ Message text cleanup.
+
+Wed Oct 29 13:27:26 1986 Richard Mlynarik (mly at prep)
+
+ * help.el (view-lossage):
+ Use (goto-char (point-min)), not (beginning-of-buffer))
+
+ * electric.el (shrink-window-if-larger-than-buffer):
+ New function. Perhaps this should be in subr.el?
+
+ * tags.el (find-tag):
+ If arg is "" and interactive, put computed tag into
+ command-history so that repeat-complex-command works.
+
+ * subr.el (momentary-string-display):
+ Avoid losing due to file-locking.
+
+ * files.el (auto-save-mode):
+ Print a confirming message if interactive.
+
+Tue Oct 28 01:12:35 1986 Richard Mlynarik (mly at prep)
+
+ * undigestify.el:
+ Compensate for broken MH digests
+
+ * tex-mode.el (TeX-region):
+ Call csh with -f flag
+
+ * rmail.el (rmail-forward):
+ Use mail, not mail-other-window.
+
+Mon Oct 27 14:46:48 1986 Richard Mlynarik (mly at prep)
+
+ * nroff-mode (electric-nroff-mode):
+ Fix bugs.
+
+ * electric.el, ebuff-menu.el, echistory.el:
+ Do the `space to flush' before calling Electric-command-loop
+ Delete the space to flush in electric-command-history.
+
+ * tex-mode.el:
+ defconst -> defvar
+
+Sun Oct 26 01:32:14 1986 Richard Mlynarik (mly at prep)
+
+ * sendmail.el:
+ (provide 'sendmail)
+
+ * files.el (basic-save-buffer):
+ Set file modes appropriately in file-precious-flag case.
+
+Wed Oct 22 18:00:18 1986 Richard Mlynarik (mly at prep)
+
+ * Rename term/xterm.el => term/X-windows.el
+
+ * startup.el (command-line):
+ If the variable window-system is non-nil, load
+ (concat term-file-prefix window-system "-windows")
+ rather than (concat term-file-prefix (getenv "TERM"))
+
+ * files.el (basic-save-buffer):
+ Fix write-file-hooks.
+
+ * tex-mode.el (TeX-region):
+ Ensure newline before trailer (from gildea)
+
+Tue Oct 21 11:39:56 1986 Richard Mlynarik (mly at prep)
+
+ * rmailedit.el (rmail-cease-edit):
+ Don't add edited attribute unless changes were actually made.
+
+ * term/xterm.el (x-handle-switch):
+ command-line-args => command-line-args-left (yet again)
+
+Mon Oct 20 18:40:23 1986 Richard Mlynarik (mly at prep)
+
+ * sort.el:
+ Work if (point) > (mark)
+
+ * vip.el (vi-change-mode-line):
+
+Sat Oct 18 17:02:13 1986 Richard Mlynarik (mly at prep)
+
+ * add-log.el (add-change-log-entry):
+ If file specified is a directory, then use `ChangeLog' in that
+ directory.
+
+ * sendmail.el (mail-send-and-exit):
+ Don't kill selected-window, if given a prefix arg.
+
+ * files.el (normal-mode):
+ Don't clobber value of major-mode set by way of default-major-mode.
+
+Fri Oct 17 01:06:06 1986 Richard Mlynarik (mly at prep)
+
+ * help.el, picture.el, simple.el, tags.el, vi.el:
+ Doc/spelling fixes from sjk
+
+ * rmailsum.el:
+ use new mode-line technology
+
+ * rmail.el (rmail-reply):
+ Handle resent-reply-to better.
+
+Wed Oct 15 16:20:03 1986 Richard Mlynarik (mly at prep)
+
+ * edt.el:
+ (require 'keypad)
+
+ * dired.el (dired-mode):
+ Don't lose finding files from dired when default-major-mode is
+ nil.
+
+Tue Oct 14 18:08:53 1986 Richard Mlynarik (mly at prep)
+
+ * texinfmt.el:
+ Support for @include from schaefer%andy.bgsu.edu@CSNET-RELAY.ARPA
+
+ * dabbrev.el (dabbrev-expand):
+ Give useful error message. Use save-excursion.
+ Allow both symbol-constituent and word-constituent chars in the
+ expansion.
+
+ * files.el (save-buffers-kill-emacs):
+ Make arg optional.
+
+Sun Oct 12 02:26:26 1986 Richard Mlynarik (mly at prep)
+
+ * macros.el (name-last-kbd-macro):
+ Insert omitted argument in error message.
+
+ * userlock.el (ask-user-about-lock-help):
+ Improve help message.
+
+Sat Oct 11 16:33:51 1986 Richard Mlynarik (mly at prep)
+
+ * files.el (find-backup-file-name):
+ Call make-backup-file-name rather than appending "~"
+
+ * lisp-mode.el:
+ Make `|' have `"' syntax for |WeIrD SymbolS|
+
+Fri Oct 10 14:21:15 1986 Richard Mlynarik (mly at prep)
+
+ * edt.el, vi.el:
+ typo.
+
+Wed Oct 8 09:56:38 1986 Richard Mlynarik (mly at prep)
+
+ * bytecomp.el (byte-compile-function-form):
+ Handle "(function symbol)"
+
+ * sendmail.el (mail-position-on-field):
+ Return nil if field wasn't there and we did add (the
+ non-`soft' case)
+
+Tue Oct 7 01:57:31 1986 Richard Mlynarik (mly at prep)
+
+ * shell.el:
+ Split off shell-set-directory from shell-send-input.
+
+ * dabbrev.el (dabbrev-expand):
+ Fix bugs. Check whether last-command was a dabbrev-expand.
+ Undo-boundary.
+
+Sat Oct 4 14:50:01 1986 Richard Mlynarik (mly at prep)
+
+ * info.el (Info-find-node):
+ Bug in case of nodename "*"
+
+ * info.el (Info-search):
+ Hair plus: make search work with split subfiles.
+ Also, push position on node history if searching puts us in a
+ different node.
+
+ * debug.el (debug):
+ New match-data format.
+
+ * info.el (Info-goto-node):
+ Adjust to new regexp-register scheme.
+
+ * info.el (Info-read-subfile):
+ Node delimiter is \n\^_, not just \^_
+
+ * texinfmt.el (batch-texinfo-format):
+ Wasn't updated when Info-validate was given a required arg.
+
+ * informat.el (Info-validate, Info-tagify):
+ Warn that don't know how to hack indirect files.
+
+ * texinfmt.el, informat.el (batch-{texinfo-format,info-validate}):
+ First elt of command-line-args-left shouldn't be skipped.
+
+Thu Oct 2 21:40:50 1986 Richard Mlynarik (mly at prep)
+
+ * info.el (Info-find-node):
+ Tag-table position match-data was being clobbered by intervening
+ search for "(indirect)"
+
+Thu Oct 2 01:59:17 1986 Richard M. Stallman (rms at prep)
+
+ * texinfmt.el: define @smallbook and @tex ... @end tex.
+
+Wed Oct 1 02:02:14 1986 Richard M. Stallman (rms at prep)
+
+ * lisp.el (lisp-complete-symbol): fix stupid bugs
+ affecting printing completion lists.
+
+ * loaddefs.el: Improve doc of isearch functions.
+
+ * texinfmt.el: Define commands chapheading, (sub)*heading
+ to format in the Info file like chapter and (sub)*section.
+
+ * macros.el (name-last-kbd-macro):
+ Supply (interactive).
+
+ * macros.el (insert-kbd-macro): Fix a few bugs.
+
+Mon Sep 29 00:55:06 1986 Richard M. Stallman (rms at prep)
+
+ * subr.el (momentary-string-display):
+ Use insert-before-markers to insert the string so that
+ the right cursor position is displayed.
+
+Sat Sep 27 04:56:36 1986 Richard M. Stallman (rms at prep)
+
+ * vip.el: renamed from vi1.el. Many cleanup changes.
+ Entry point is now vip-mode, autoloaded from loaddefs.el.
+
+Fri Sep 26 17:47:32 1986 Richard Mlynarik (mly at prep)
+
+ * files.el (recover-file, find-file-noselect):
+ Add nowarn arg to find-file-noselect, so that recover-file doesn't
+ warn one that one should consider doing m-x recover file.
+
+ * subr.el (mod):
+ Synonym for "%"
+
+ * files.el (recover-file):
+ Call expand-file-name.
+
+ Also, get an error if user specifies an auto-save filename.
+ (Would be able to do something useful if there were a way
+ to get back the original filename from the auto-save filename)
+
+Thu Sep 25 18:35:16 1986 Richard M. Stallman (rms at prep)
+
+ * man.el (manual-entry): If formatted man file name ends
+ in .Z, uncompress it.
+
+ * macros.el (name-last-kbd-macro):
+ Now in Lisp code and autoloaded.
+ Get an error if name has a definition that's not a kbd macro.
+
+Thu Sep 25 01:17:07 1986 Richard Mlynarik (mly at prep)
+
+ * replace.el (perform-replace):
+ Make ? (as well as C-h) give help for query-replace(-regexp)
+
+Wed Sep 24 15:22:37 1986 Richard Mlynarik (mly at prep)
+
+ * simple.el (set-mark):
+ set-mark is in lisp code now (from editfns.c)
+
+ * bytecomp.el:
+ Don't compile (mark) specially -- lisp code shouldn't
+ call this function very freqently.
+
+ * startup.el (command-line-1):
+ (let ((load-path (cons default-directory load-path))) (load ...))
+ so that the "-load" switch can specify a file relative to $cwd
+ now that $cwd isn't a component of emacs' default load-path.
+
+ * man.el (manual-entry)
+ HPUX dain bramage.
+
+Tue Sep 23 20:02:01 1986 Richard M. Stallman (rms at prep)
+
+ * help.el: New file containing help commands
+ formerly in simple.el. Installed in loadup.el
+ and ../src/ymakefile.
+
+ * help.el: Move calls to print-help-return-message
+ inside the with-output-to-temp-buffer constructs.
+ Outside, they saw the window state after displaying
+ the buffer and printed the wrong stuff.
+
+ * help.el (print-help-return-message):
+ If the help buffer is already visible, do nothing
+ since it is impossible to bring back the old contents
+ of that buffer in this case.
+
+ If given an argument, apply that argument to the message
+ (and return the result) instead of calling `message' with it.
+
+Tue Sep 23 16:17:48 1986 Richard Mlynarik (mly at prep)
+
+ * files.el (revert-buffer)
+ Pass noconfirm arg to revert-buffer-function
+ dired.el (dired-revert) Ignore extra arg.
+
+ * tags.el (visit-tags-table-buffer)
+ noconfirm revert-buffer
+
+Tue Sep 23 14:33:20 1986 Richard M. Stallman (rms at prep)
+
+ * rmail.el: Define "x" like "e" for consistency with Dired.
+
+ * buff-menu.el (Buffer-menu-other-window):
+ New function on "o" command, acts like "o" in Dired.
+ * buff-menu.el (Buffer-menu-this-window):
+ New function on "f" command, acts like "f" in Dired.
+ * buff-menu.el (Buffer-menu-mode):
+ Update doc for these changes and C-d change.
+
+ * mh-e.el: Version 3.4a from Larus.
+
+Tue Sep 23 11:06:41 1986 Richard Mlynarik (mly at prep)
+
+ * doctor.el:
+ Heroine isn't a drug.
+
+ * ebuff-menu.el (electric-buffer-list)
+ If no buffers are marked with ">" just select the selected buffer
+ and don't change the window configuration or any other buffers.
+ If more than one buffer is selected, split the screen up between
+ those buffers.
+ Remove after-electric-buffer-menu. "kill" -> "delete"
+
+ * buff-menu.el
+ Use "D" rather than "K" for buffers to be deleted for
+ consistency with rmail and dired and others.
+
+ Rename "kill" -> "delete" for both function-names and documentation.
+
+ Define C-d as Buffer-menu-delete-backwards. (also in ebuff-menu)
+
+ Save space: Merge buffer-menu-{execute,do-saves,do-kills}
+
+Mon Sep 22 15:54:49 1986 Richard M. Stallman (rms at prep)
+
+ * macros.el (insert-kbd-macro): New function to insert
+ Lisp code to define a kbd macro as it is now defined.
+ * macros.el ({write,append}-kbd-macro): Commands deleted.
+ * loaddef.el: change autoloads for above changes.
+
+ * simple.el (callers of print-help-return-message):
+ Calling this function is now the last thing done in each caller.
+
+Mon Sep 22 13:18:44 1986 Richard Mlynarik (mly at prep)
+
+ * loaddefs.el
+ Fix some defvars/defconsts whose doc-string didn't start on the
+ same line (yuck). Split some of these into a defvar nil followed
+ by a setq.
+
+Sun Sep 21 22:15:02 1986 Richard M. Stallman (rms at prep)
+
+ * loaddefs.el (auto-mode-alist):
+ Don't use non-saved-text-mode now that it is deleted.
+
+Sun Sep 21 15:56:25 1986 Richard Mlynarik (mly at prep)
+
+ * disassemble.el, fortran.el
+ Use insert-char.
+
+ * fortran.el (fortran-electric-line-number)):
+ "self-insert-command", not "self-insert"
+
+ * fortran.el (fortran-window-create):
+ Just bind window-min-width, don't set it.
+
+ * fortran.el (fortran-abbrev-start):
+ Don't mark buffer as modified after ";?"
+ fortran-abbrev-help -- do "message...done"
+
+ * files.el (revert-buffer)
+ Check to see if (file-exists-p buffer-auto-save-file-name)
+ even if (recent-auto-save-p) before offering to revert from it.
+
+ * text-mode.el:
+ Remove non-saved-text-mode
+
+ * *-mode.el
+ Fix some initializations of syntax-tables so that user
+ can override them.
+
+Sun Sep 21 14:54:30 1986 Richard M. Stallman (rms at prep)
+
+ * files.el (recover-file, list-directory):
+ Don't say /bin/ls; let search path be searched for ls.
+
+Sat Sep 20 21:25:01 1986 Richard M. Stallman (rms at prep)
+
+ * lisp.el (lisp-complete-symbol): New command does
+ completion on a symbol name in the buffer.
+
+ * fortran.el: New file defining fortran-mode,
+ which is autoloaded from loaddefs.
+
+ * abbrevlist.el: New file defining list-one-abbrev-table,
+ a function now used by fortran-mode but not Fortran-specific.
+
+Fri Sep 19 00:52:07 1986 Richard M. Stallman (rms at prep)
+
+ * subr.el (momentary-string-display): New function
+ to display a string momentarily in the buffer.
+
+ * loadup.el: Load loaddefs before simple and files
+ because loaddefs makes more garbage.
+
+ * loaddefs.el: Include defvar of ctl-x-4-map
+ needed now that this is loaded before files.el.
+
+Wed Sep 17 20:55:00 1986 Richard Mlynarik (mly at prep)
+
+ * hanoi.el
+ Vital improvements
+
+Wed Sep 17 12:13:58 1986 Richard M. Stallman (rms at prep)
+
+ * loaddefs.el: disable C-x p.
+ * loaddefs.el: autoload set-gosmacs-bindings.
+ * gosmacs.el: renamed from gosling.el with many changes
+ (saves old bindings and can restore them as they were).
+
+Wed Sep 17 11:02:39 1986 Richard Mlynarik (mly at prep)
+
+ * replace.el (occur)
+ Use variable list-matching-lines-default-context-lines if
+ no prefix arg specified.
+ If nlines arg is -ve, include that many lines of preceding
+ context, no lines of following context.
+ Use markers instead of line-numbers.
+ In occur-mode-goto-occurrence, warn about deleted buffer.
+
+Tue Sep 16 02:07:53 1986 Richard M. Stallman (rms at prep)
+
+ * simple.el (indent-for-comment):
+ Delete only the spaces before the beginning of the comment starter
+ in case the comment starter contains a leading space.
+
+ * abbrev.el (edit-abbrevs-map): Define C-c C-c like C-x C-s.
+
+ * texinfmt.el: define @r as noop.
+
+ * simple.el (print-help-return-message): New function.
+ Use before doing with-output-to-temp-buffer, and it
+ prints an echo area message about how to restore
+ current screen configuration from the configuration
+ that will obtain after the with-output-to-temp-buffer.
+
+ * simple.el (describe-{key,mode,function,variable}):
+ * simple.el (view-lossage, command-apropos):
+ Ca;; print-help-return-message.
+
+Mon Sep 15 17:49:07 1986 Richard M. Stallman (rms at prep)
+
+ * sendmail.el (sendmail-send-it):
+ Don't require newline before header-separator;
+ search for regexp and use `^'.
+
+ * mh-e.el: Version 3.4 from Larus.
+ Uses `interactive' properly to read the arguments.
+
+Sun Sep 14 19:44:31 1986 Richard Mlynarik (mly at prep)
+
+ * files.el (normal-mode)
+ Use shorter error message, so more fits on screen.
+
+Sun Sep 14 14:14:35 1986 Richard M. Stallman (rms at prep)
+
+ * loadup.el: On VMS, dump under name temacs.dump only.
+
+ * vms-patch.el (make-auto-save-file-name):
+ Append "$" at end as well as "_$" at front.
+
+ * files.el (cd): Don't do file-name-as-directory on VMS.
+
+Sat Sep 13 19:36:01 1986 Richard M. Stallman (rms at prep)
+
+ * bytecomp.el (byte-compile-file):
+ Don't bomb on defvar with no initial value argument.
+
+ * texinfmt.el (texinfo-format-buffer):
+ Tagify and maybe even split automatically if buffer is big enough.
+ Non-nil arg inhibits this.
+
+ * informat.el (Info-tagify):
+ Don't leave buffer narrowed if it wasn't narrowed to start with.
+
+ * simple.el (comment-column, fill-prefix):
+ Make them buffer-local and fix documentation.
+ * loaddefs.el: make indent-tabs-mode buffer-local.
+
+Fri Sep 12 18:37:08 1986 Richard M. Stallman (rms at prep)
+
+ * dired.el (dired-add-entry): Go to beginning of line
+ before adding the entry.
+
+Fri Sep 12 02:36:53 1986 Richard Mlynarik (mly at prep)
+
+ * mlsupport.el:
+ Define ml-substr (used to be in mocklisp.c)
+
+Fri Sep 12 02:07:23 1986 Richard M. Stallman (rms at prep)
+
+ * time.el: Don't just clobber global-mode-string.
+ Instead, add 'display-time-string as an element
+ and update the time by changing value of that variable.
+
+ * rmail.el (rmail-mode-1): Change only part of mode-line-format
+ Instead set mode-line-buffer-identification.
+
+ * rmail.el (rmail-show-message): Use mode-line-process to
+ display the message numbers and labels.
+
+Thu Sep 11 18:24:28 1986 Richard Mlynarik (mly at prep)
+
+ * compile.el (compilation-sentinel)
+ Ignore buffer-read-only.
+
+Wed Sep 10 17:40:01 1986 Richard M. Stallman (rms at prep)
+
+ * picture.el: Convert `Picture' to `picture' in all symbols.
+
+ * subr.el: Define old names send-string and send-region
+ as aliases for new names process-send-...
+
+Tue Sep 9 13:08:12 1986 Richard M. Stallman (rms at prep)
+
+ * time.el (display-time): variable display-time-interval
+ specifies seconds between updates.
+
+ * loaddefs.el: Put \-newline in doc strings that lacked it.
+
+Mon Sep 8 09:45:01 1986 Richard M. Stallman (rms at prep)
+
+ * simple.el: Give C-c's keymap a name, mode-specific-map.
+
+ * options.el (list-options): Use user-variable-p to filter
+ the variables and documentation-property to get the strings.
+
+Sat Sep 6 08:52:01 1986 Richard M. Stallman (rms at prep)
+
+ * tex-mode.el (tex-region):
+ Handle case where specified region extends before header.
+
+Thu Sep 4 17:00:05 1986 Leonard H. Tower Jr. (tower at prep)
+
+ * rnews.el (news-inews)
+ added -h to call of inews to insert all header fields.
+
+Thu Sep 4 08:37:49 1986 Richard M. Stallman (rms at prep)
+
+ * files.el (save-buffers-kill-emacs):
+ Prefix arg means save with no query.
+
+ * files.el (backup-buffer): Fix uses of % in message about %backup%.
+
+Wed Sep 3 12:22:06 1986 Leonard H. Tower Jr. (tower at prep)
+
+ * rnews.el (news-reply-mode-map)
+ Change mail-x field bindings from C-c x to C-c C-f C-x to agree
+ with sendmail.el .
+
+ * sendmail.el (mail-mode-map)
+ Change mail-x field bindings from C-c C-f x to C-c C-f C-x to
+ agree with ../etc/NEWS .
+
+Mon Sep 1 06:17:17 1986 Richard M. Stallman (rms at prep)
+
+ * info.el (Info-find-node, Info-read-subfile):
+ Now knows how to deal with indirect info files.
+ * info.el: Info-current-file is now the primary
+ place that records which info file is in the *info* buffer,
+ and it is updated as soon as a new file is correctly read.
+ * info.el: New var Info-current-subfile records which
+ subfile is in the *info* buffer, or is nil for an Info file
+ that doesn't have subfiles or if no subfile read in yet.
+
+ * informat.el (Info-split): New function to split
+ an Info file into a bunch of subfiles. It edits the original
+ file into an indirect file.
+
+ * info.el, loaddefs.el:
+ Autoloads for informat.el moved from info.el to loaddefs.el.
+
+Sun Aug 31 04:21:17 1986 Richard M. Stallman (rms at prep)
+
+ * page.el (mark-page):
+ * paragraphs.el (mark-paragraph):
+ * x-mouse.el (x-mouse-set-mark):
+ Use push-mark and inhibit the message, instead of set-mark.
+
+ * mh-e.el (mh-position-on-field, mh-exec-lib-cmd-output,
+ mh-exec-cmd-output): use push-mark instead of set-mark.
+
+ * simple.el (push-mark): optional 2nd arg NOMSG inhibits message.
+
+ * ebuff-menu.el (electric-buffer-list):
+ Was using the mark for internal purposes.
+ Use an anonymous marker instead.
+
+ * bytecomp.el: Stop using the byte-set-mark opcode.
+
+ * replace.el (occur): Put the *Occur* buffer in Occur mode.
+ Remember line number of each occurrence in occur-pos-list
+ Occur mode defines C-c C-c as occur-mode-goto-occurrence,
+ which uses that list to move the cursor in the original buffer
+ (which is saved in occur-buffer).
+
+ * aton.el (occur-menu: File deleted; occur-menu is subsumed by occur.
+
+ * isearch.el (isearch): repeating the search in either direction
+ must set success to t to produce correct echo area text.
+
+ * edt.el: New file. Autoloadable entry is edt-emulation-on.
+
+ * keypad.el (function-key-sequence): New function
+ finds which key sequence leads to a slot in function-keymap.
+
+Sat Aug 30 00:31:48 1986 Richard M. Stallman (rms at prep)
+
+ * files.el (backup-buffer): Use "%backup%~", not "%backup%",
+ if cannot write the backup in the usual place.
+
+ * sort.el (sort-columns): Sort into reverse order
+ if have prefix arg. Args are now the same as for
+ sort-lines, etc.
+
+Thu Aug 28 13:56:56 1986 Richard Mlynarik (mly at prep)
+
+ * c-mode.el (electric-c-{brace,terminator})
+ c-indent-line takes no args.
+
+Thu Aug 28 01:57:58 1986 Richard M. Stallman (rms at prep)
+
+ * files.el (backup-buffer): file-precious-flag forces copying.
+
+ * loaddefs.el: Autoload plain-TeX-mode and LaTeX-mode.
+ Define aliases for them. Fix doc for TeX-mode.
+
+Tue Aug 26 14:25:59 1986 Leonard H. Tower Jr. (tower at prep)
+
+ * rnews.el:
+ Added autoload of rmail-output and bound it to C-o in
+ news-mode-map. Also needed defvar of rmail-last-file.
+
+ * rmailout.el (rmail-output):
+ Made rmail-mode specific code dependent on rmail-mode being
+ major-mode.
+
+Mon Aug 25 03:47:24 1986 Richard M. Stallman (rms at prep)
+
+ * view.el (view-mode):
+ Bind mode-line-buffer-identification;
+ in new versions don't change mode-line-format.
+
+ * dired.el (dired-mode):
+ * info.el (Info-set-mode-line):
+ * x-menu.el (x-menu-mode):
+ Don't change mode-line-format.
+ Use mode-line-buffer-identification instead.
+ * ebuff-menu.el (electric-buffer-menu-mode):
+ Likewise, and also copy the mode-line-format
+ and replace `mode-name in it with "Buffers".
+
+ * info.el (Info-edit): Restore normal mode line
+ by killing the local variables used by Info to change it.
+
+ * echistory.el (electric-command-history):
+ In newer Emacs versions, don't alter mode-line-format.
+
+ * compile.el (compile1, compilation-sentinel):
+ * shell.el (shell-mode, inferior-lisp-mode):
+ * xscheme.el (inferior-scheme-mode):
+ * telnet.el (telnet-mode):
+ If minor-mode-alist is bound, put the %s or process status
+ into mode-line-process instead of changing mode-line-format.
+
+ * sort.el: New file contains buffer-sorting commands.
+ Autoload them in loaddefs.el.
+
+ * files.el (backup-buffer): Obey new variable
+ backup-by-copying-when-mismatch.
+
+ * loaddefs.el: Set default-mode-line-format to use
+ the new list and symbol constructs. Define minor-mode-alist.
+
+ * rnews.el (news-set-minor-modes):
+ Store the string in news-minor-modes, and set minor-modes
+ only if minor-mode-alist is unbound (Emacs versions < 18.16).
+ * rnews.el (news-mode): In newer Emacses, set mode-name
+ so it displays news-minor-mode.
+
+ * nroff-mode.el (nroff-mode):
+ If minor-mode-alist bound, add an entry for nroff-electric-mode
+ to it, and don't call set-minor-mode.
+
+ * simple.el (overwrite-mode, auto-fill-mode):
+ * abbrev.el (abbrev-mode):
+ Don't call set-minor-mode.
+
+ * simple.el (set-minor-mode): Delete this function.
+
+ * bytecomp.el (byte-compile-file):
+ Put backslash-newline at front of doc string when that is safe.
+ * bytecomp.el (old-file-newer-than-file-p):
+ Deleted this; built-in file-newer-than-file-p is well established.
+
+Sun Aug 24 03:11:41 1986 Richard M. Stallman (rms at prep)
+
+ * term/xterm.el: Install some changes from rlk.
+ -ib switch and InternalBorder default are handled.
+ Set variable x-processed-defaults when defaults are processed.
+ Use require to load x-mouse.
+ Use message to say why suspend-emacs is disabled.
+
+ * x-mouse.el: Install some changes from rlk.
+
+ * x-menu.el: New file that handles menus on X window system.
+
+ * buff-menu.el (buffer-menu): Put point on third line
+ initially (this line describes the buffer that had been selected).
+
+ * files.el (create-file-buffer):
+ Delete the variable ask-about-buffer-names
+ and simplify this function.
+
+Sat Aug 23 14:57:55 1986 Richard M. Stallman (rms at prep)
+
+ * files.el (basic-save-buffer):
+ When changing visited name, don't try to rename old auto-save file
+ if it does not exist.
+
+ * c-mode.el (c-indent-command): New definition of TAB,
+ uses c-indent-line as a subroutine. Handling of prefix arg
+ and indenting an entire expression rigidly is now in this fn.
+
+ * c-mode.el (c-tab-always-indent): If nil, TAB inserts a tab
+ if not in the initial whitespace of the line.
+
+ * c-mode.el (calculate-c-indent):
+ For statements: if prev line ends in `:', this line is still
+ a continuation if the `:' follows a non-symbol-constituent char.
+ For top level: look at previous line that starts in column 0
+ to determine whether this line is at top level or in arg decls.
+ Also notice if line is a continuation.
+
+ * novice.el (disabled-command-hook):
+ If the 'disabled property is a string, include it in the message.
+
+Thu Aug 21 14:50:03 1986 Richard M. Stallman (rms at prep)
+
+ * bytecomp.el (byte-compile-interactive-p):
+ Remove superfluous compilation of 'nil causing stack overflow.
+
+ * compile.el (compilation-parse-errors):
+ Count lines from the previous error message, not from line 1.
+
+Thu Aug 21 10:45:44 1986 Richard Mlynarik (mly at prep)
+
+ * debug.el (debug, debugger-eval-expression):
+ Evaluate the expression in the context of the buffer
+ current when the debugger was entered.
+
+Thu Aug 21 02:15:36 1986 Richard M. Stallman (rms at prep)
+
+ * files.el (after-find-file): Print no message
+ rather than printing a null message.
+
+Wed Aug 20 23:34:04 1986 Richard M. Stallman (rms at prep)
+
+ * files.el (set-auto-mode): On VMS, turn on case-fold-search
+ while matching auto-mode-alist elements.
+
+Wed Aug 20 12:30:45 1986 Richard M. Stallman (rms at prep)
+
+ * debug.el (debug): Don't try to restore the match data
+ if it refers to a dead buffer.
+
+ * startup.el (command-line-1):
+ -i FILE or -insert FILE means insert contents of file into buffer.
+
+Tue Aug 19 00:05:15 1986 Richard M. Stallman (rms at prep)
+
+ * simple.el (describe-variable):
+ Use `documentation-property' instead of `get' to get
+ the `variable-documentation' property.
+
+ * userlock.el: correct spelling "supercession" -> "supersession".
+
+ * files.el (basic-save-file):
+ If file-precious-flag is non-nil, rename the old file
+ before saving, and if saving fails, rename the old file back.
+
+ * rmail.el (rmail-get-new-mail):
+ Do not make a backup file if the rmail file was just visited
+ and hasn't been changed aside from reading the new mail.
+ This preserves the old backup file.
+ * rmail.el (rmail-expunge-and-save): New name for rmail-save.
+ * rmail.el (rmail-mode): Turn on file-precious-flag.
+
+ * dired.el: Define `g' as revert-buffer in dired-mode.
+
+ * c-mode.el (c-mode): Give `&' and `|' "punctuation" syntax.
+
+Mon Aug 18 14:24:55 1986 Richard Mlynarik (mly at prep)
+
+ * files.el (find-backup-file-name):
+ Don't blow up if (eq version-control 'never)
+
+ * files.el (set-visited-file-name):
+ Use `buffer-auto-save-file-name' not `auto-save-file-name' which
+ is unbound and unused.
+
+Sun Aug 17 18:34:09 1986 Richard M. Stallman (rms at prep)
+
+ * compile.el (compilation-sentinel):
+ Don't get error if *compilation* has been killed.
+ Include current date/time in message inserted in buffer.
+
+Sun Aug 17 15:07:28 1986 Richard Mlynarik (mly at prep)
+
+ * files.el (basic-save-buffer)
+ Fix paren error
+
+Sat Aug 16 19:25:09 1986 Richard M. Stallman (rms at prep)
+
+ * files.el (find-file-noselect):
+ Change find-file-not-found-hook to find-file-not-found-hooks
+ and make it a list of functions to call until one of them
+ returns non-nil.
+ * files.el (normal-mode, after-find-file):
+ Change find-file-hook to find-file-hooks, a list of functions to
+ call. Call it from after-find-file, not from normal-mode.
+ * files.el (revert-buffer):
+ Restore old point before calling after-find-file.
+ * files.el (basic-save-buffer):
+ Change write-file-hook to write-file-hooks, a list of functions
+ to run until one returns t. In that case, skip writing the file
+ the usual way.
+
+ * tags.el (visit-tag-table-buffer):
+ Get proper error for empty tag table file;
+ realize that char-after returns nil in that case.
+ Also move error check after auto-revert.
+
+Sat Aug 16 19:21:20 1986 Richard Mlynarik (mly at prep)
+
+ * subr.el
+ Move copy-alist to c code, moved nth from c code.
+
+Sat Aug 16 19:11:11 1986 Richard M. Stallman (rms at prep)
+
+ * files.el (normal-mode): initially call fundamental-mode
+ to reinitialize everything.
+
+ * files.el (hack-local-variables):
+ Don't consider suffix as including any leading spaces.
+
+Sat Aug 16 17:05:41 1986 Richard Mlynarik (mly at prep)
+
+ * informat.el, texinfmt.el
+ Detect and complain about duplicate node-names
+
+Sat Aug 16 16:56:05 1986 Richard M. Stallman (rms at prep)
+
+ * mh-e.el: 3.3j from Larus. Changes C-c C-g prefix to C-c C-f.
+
+Fri Aug 15 16:11:37 1986 Richard M. Stallman (rms at prep)
+
+ * isearch.el:
+ Default for regexp searches is now search-last-regexp.
+ Rename isearch-slow... vars to search-slow...
+ C-s or C-r in failing search wraps around buffer and tries again.
+ New local var `wrapped' records this has happened.
+ Display `Wrapped' in echo area at such times.
+ Record value of `wrapped' on the search state stack.
+ Display shorter string for incomplete regexps.
+ Incomplete regexp no longer implies "failure" of search.
+ Clean up isearch-search considerably.
+ isearch-message computes message in lower case,
+ then case-converts the first char.
+
+ * loaddefs.el: New variable search-last-regexp;
+ default string for isearch-regexp.
+ Rename isearch-... vars to search-...
+
+ * simple.el (next-line, kill-line):
+ * lisp.el (end-of-defun):
+ * picture.el (Picture-clear-line):
+ * replace.el (keep-lines):
+ * indent.el (indent-relative):
+ Use forward-line, not scan-buffer.
+ * fill.el (justify-current-line): Use search-backward
+ not scan-buffer to check whether the line has a space in it.
+
+ * files.el (set-visited-file-name):
+ Rename the auto-save file if appropriate.
+ (make-auto-save-file-name, auto-save-file-name-p):
+ Auto save file for foo is now #foo#.
+ (make-backup-file-name, backup-file-name-p):
+ New functions, used in appropriate places.
+
+ * dired.el (dired-flag-backup-files):
+ Use backup-file-name-p.
+
+ * sendmail.el (mail-mode):
+ Fix documentation of key bindings.
+
+Fri Aug 15 14:45:40 1986 Richard Mlynarik (mly at prep)
+
+ * man.el (manual-entry)
+ Compensate for Sun wankerism.
+ If would be nice if there were something a little
+ more fine-grained than `system-type' for testing for
+ these cases...
+
+Fri Aug 15 04:11:01 1986 Richard M. Stallman (rms at prep)
+
+ * startup.el (command-line): No longer necessary to set
+ ctl-arrow from default-ctl-arrow, etc., after init file is run
+ due to changed behavior of those variables.
+
+ * info.el (Info-edit):
+ * rmailedit.el (rmail-edit-mode):
+ Change default-mode-line-format to (default-value 'mode-line-format).
+
+Thu Aug 14 16:17:20 1986 Richard Mlynarik (mly at prep)
+
+ * man.el (manual-entry):
+ Speed up `\b'-hacking.
+
+Thu Aug 14 01:08:32 1986 Richard M. Stallman (rms at prep)
+
+ * sendmail.el: Change key bindings.
+ C-c <letter> becomes C-c C-<letter> or C-c C-f <letter>.
+
+ * mh-e.el (mh-position-on-field):
+ mh-header-end -> mh-goto-header-end.
+
+ * novice.el (disabled-command-hook):
+ Print only the first paragraph of the command's documentation.
+ [Test this, once new narrow-to-region doc is installed.]
+
+ * rmailsum.el (rmail-make-basic-summary-line):
+ Don't accept a time zone as a month.
+
+Wed Aug 13 02:01:59 1986 Richard M. Stallman (rms at prep)
+
+ * mh-e.el: New version 3.3i, moving mode-specific commands
+ to C-c prefix.
+
+ * tex-mode.el: many new features incl. LaTeX mode
+ and some C-c commands.
+
+ * indent.el (indent-relative):
+ Fix lossage if point to indent under was inside a tab.
+
+ * bytecomp.el (byte-compile-substring):
+ Fix dumb error.
+
+ * info.el: Autoload Info-validate. Fix bug in autoload Info-tagify.
+
+Tue Aug 12 11:30:53 1986 Richard Mlynarik (mly at prep)
+
+ * rmailedit.el (rmail-cease-edit, rmail-attributes)
+ Add label (well, `attribute,' really) "edited" to message.
+
+ * mlsupport.el (auto-execute)
+ Fix from bap@g.cs.cmu.edu
+
+Mon Aug 11 10:36:51 1986 Richard Mlynarik (mly at prep)
+
+ * bytecomp.el (byte-compile-form)
+ Compile references to t and nil as constants rather then variable
+ references.
+
+ * bytecomp.el (byte-compile-no-args, ..., byte-compile-three-args)
+ If called with wrong-number-of-args, do a normal function call
+ and get an error at runtime.
+
+ * bytecomp.el (byte-compile-file-form)
+ Process (require ...) at compile-time
+
+ * informat.el, info.el, loaddefs.el
+ Move Info-validate and friends into new file informat.el
+ Add batch-info-validate
+
+ * texinfmt.el, loaddefs.el
+ Add batch-texinfo-format
+
+ * startup.el
+ Add synonym switches "-funcall" "-load" "-user" "-no-init-file"
+ for cryptic "-f" "-l" "-u" "-q"
+
+ * mlsupport.el
+ Make various turds know that inhibit-command-line has gone.
+
+ * bytecomp.el (batch-byte-compile), tex-start.el
+ Because of RMS's change "Mon Jul 7 14:01:51 1986"
+ must use variable command-line-args-left rather than command-line-args.
+
+ Actually, I see no circumstances under which a switch -could- be
+ interested in any command-line-args before the mention of itself,
+ and so think that rebinding command-line-args as appropriate was
+ correct (if perhaps a little confusing to the person who requested
+ that RMS' change be made)
+
+Sun Aug 10 08:02:19 1986 Richard Mlynarik (mly at prep)
+
+ * info.el (Info-validate)
+ re-search for \\*, not *
+
+Thu Aug 7 10:24:21 1986 Richard Mlynarik (mly at prep)
+
+ * rfc822.el, loaddefs.el, mail-utils.el
+ Hairy address parser, used only if mail-use-rfc822 is non-nil
+ (It is nil by default, so if one doesn't like or need the hair of
+ this file, then one is never troubled by it)
+
+ * disassemble.el, loaddefs.el
+ Code from doug@csli.stanford.edu modified by mly.
+ RMS -- if this is too random to be in the GNU Emacs
+ distribution, please tell me so.
+
+ * bytecomp.el
+ Compile eql same as eq.
+
+Wed Jul 30 22:03:02 1986 Richard M. Stallman (rms at prep)
+
+ * outline.el (many functions):
+ New variable outline-regexp controls what is a heading line.
+ It must match at the beginning of a line. Length of matched text
+ gives the depth of heading within the tree.
+
+ * term/xterm.el (x-get-default-args):
+ Process reversevideo option just once. (Twice is noop.)
+
+Mon Jul 28 20:24:18 1986 Richard M. Stallman (rms at prep)
+
+ * term/vt100.el, term/vt200.el:
+ Move (require 'keypad) to top to avoid error.
+
+Fri Jul 18 14:26:00 1986 Leonard H. Tower Jr. (tower at prep)
+
+ * rnews.el: (news-add-news-group)
+ handle unsubscribed groups better
+
+ * rnews.el: (news-{next,previous}-group)
+ now skip groups with no new messages
+
+Thu Jul 17 19:06:59 1986 Richard M. Stallman (rms at prep)
+
+ * mh-e.el: Install version 3.3h from Larus.
+
+Tue Jul 15 17:35:34 1986 Richard M. Stallman (rms at prep)
+
+ * shell.el (shell-send-input):
+ If get error trying to change directory, call
+ shell-set-directory-error-hook with no args.
+
+Sat Jul 12 00:12:37 1986 Richard M. Stallman (rms at prep)
+
+ * tags.el (list-tags, tags-apropos): Call output buffer *Tags List*.
+
+ * c-mode.el (calculate-c-indent):
+ Better handling of case where first statement at current level
+ starts on same line as a case..: or label. New local var
+ colon-line-end.
+
+Mon Jul 7 14:01:51 1986 Richard M. Stallman (rms at prep)
+
+ * startup.el (command-line-1): rename argument variable
+ command-line-args to command-line-args-left. Don't rebind
+ command-line-args.
+
+Sat Jun 21 01:11:23 1986 Richard M. Stallman (rms at prep)
+
+ * mh-e.el: Version 3.3g from Larus.
+
+Thu Jun 19 12:35:17 1986 Richard M. Stallman (rms at prep)
+
+ * isearch.el (isearch): Use slow terminal mode
+ only if current window is > 4 times the slow-terminal lines high.
+
+Tue Jun 17 05:37:59 1986 Richard M. Stallman (rms at prep)
+
+ * nroff-mode.el: Add elements to nrofff-brace-table.
+
+Mon Jun 16 06:30:54 1986 Richard M. Stallman (rms at prep)
+
+ * mlconvert.el (convert-mocklisp-buffer):
+ Proper handling of `!' function, via new function ml-not.
+ Proper handling of non-defuns, by putting them inside a
+ dummy defun and calling that function.
+
+Sat Jun 14 22:05:58 1986 Richard M. Stallman (rms at prep)
+
+ * mh-e.el : Install 3.3f from Larus.
+
+Thu Jun 12 02:47:11 1986 Richard M. Stallman (rms at prep)
+
+ * startup.el (command-line):
+ Rename default init file to default.el.
+ Don't look for suffixes on .emacs file.
+
+ * keypad.el: New file that defines a standard keypad mode.
+ * term/vt*.el: Rewrite completely to use keypad.el.
+
+Wed Jun 11 16:43:27 1986 Richard M. Stallman (rms at prep)
+
+ * abbrev.el (abbrev-prefix-mark):
+ Insert a - at the beginning of the abbrev.
+ expand-abbrev will now delete such -'s.
+
+ * userlock.el (ask-user-about-supercession):
+ Ask user what to do if he is modifying a buffer whose
+ file is changed on disk.
+
+Tue Jun 10 04:54:33 1986 Richard M. Stallman (rms at prep)
+
+ * rmail.el (rmail-reply): For the in-reply-to,
+ try to get the sender's full name from within parentheses.
+
+ * outline.el: pervasive changes; new features, changed keys.
+
+ * files.el (backup-bufer):
+ If cannot write backup under normal name, write it in ~/%backup%.
+ Preserve the last-modified time when backing up by copying.
+
+Mon Jun 9 00:00:24 1986 Richard M. Stallman (rms at prep)
+
+ * rmail.el (rmail-expunge): Preserve point unless expunging
+ the current message.
+
+ * bytecomp.el (file-newer-than-file-p):
+ Since this is a primitive in version 18, define it
+ only if not defined.
+
+Sun Jun 8 09:43:02 1986 Richard M. Stallman (rms at prep)
+
+ * files.el (load-file, load-library): two new commands.
+
+ * startup.el (command-line): Eliminate inhibit-command-line
+ since one can just set command-line-args to nil.
+
+ * term/xterm.el: No need to handle -d switch
+ since main() handles it now.
+
+ * tags.el: Display name of file being processed.
+
+ * mh-e.el: Install version 3.3 from Larus.
+
+ * replace.el, loaddefs.el (perform-replace):
+ perform-replace does not print "done"; its callers do.
+
+ * startup.el (command-line):
+ Rename file default-profile to .emacs-df;
+ load it always, unless inhibit-default-init is set to t.
+
+ * telnet.el: Switch to C-c prefix for mode-specific commands.
+
+ * startup.el (command-line): Use just first word of
+ terminal name to make per-terminal library file name.
+
+ * loadup.el: Change name of installed docstr file to
+ DOC-mm.nn.oo from DOC.mm.nn.oo.
+
+ * files.el (file-name-sans-versions): New system-dependent
+ function to remove backup or version suffixes from filename.
+
+Sat Jun 7 16:04:07 1986 Richard M. Stallman (rms at prep)
+
+ * c-mode.el (electric-c-terminator):
+ Check for point being inside a multi-line string or comment
+ and do nothing. For colon, check for more than one word
+ before it on the line (with first one not "case") and do nothing.
+
+ * c-mode.el: Don't rebind Linefeed.
+
+ * c-mode.el (calculate-c-indent):
+ If previous line ends in ") {", skip back to matching "("
+ and use that line's indentation as the brace's column.
+
+Fri Jun 6 00:12:48 1986 Richard M. Stallman (rms at prep)
+
+ * nroff-mode.el (nroff-comment-indent, nroff-mode):
+ Define a comment syntax. Install comment-indenter
+ as supplied by gildea, but change it not to use
+ insert-before-markers, to avoid display anomalies.
+
+ * files.el (find-file-noselect): Tell revert-buffer not to query.
+ * files.el (revert-buffer): Second arg non-nil means no query.
+
+ * files.el (after-find-file): Warn if auto-save file
+ exists and is newer than the file visited.
+
+ * files.el (find-alternate-file):
+ Allow replacing a non-file buffer, as long as not modified.
+
+ * files.el (recover-file):
+ Initially show a directory listing of real and auto-save files.
+ Only find the file if user says yes.
+ Print better messages.
+
+ * simple.el (goto-line): Use new interactive code N.
+
+ * subr.el (substitute-key-definition): New function.
+ Replaces all bindings to one function in one map
+ with another function.
+
+ * xterm.el: Use substitute-key-definition to get rid of keys
+ that do suspend-emacs.
+
+Thu Jun 5 00:25:52 1986 Richard M. Stallman (rms at prep)
+
+ * simple.el (fundamental-mode):
+ Provide a fundamental-mode-map in case user does local-set-key.
+
+ * picture.el (picture-mode):
+ New key bindings for setting insert motion direction:
+ C-c <, C-c >, C-c ^ and C-c . instead of M- chars.
+
+ * rmail.el (rmail-reply): When putting From into In-reply-to,
+ stop at any newline.
+
+ * mail-utils.el (mail-strip-quoted-names):
+ Consider newlines like other whitespace for <...> hacks.
+
+ * bytecomp.el (byte-compile-cond{,-1}):
+ Handling of singleton clauses that are not last.
+ Handling of cond with no clauses.
+
+ * startup.el (command-line): Switch to *scratch* before
+ running initial-major-mode, and do this only if *scratch* exists.
+
+ * compare-w.el: Simplify the handling of `size':
+ always reduce size not to exceed the amount of space
+ left in either buffer.
+
+Wed Jun 4 21:44:40 1986 Richard M. Stallman (rms at prep)
+
+ * man.el (manual-entry): Use new variables manual-program,
+ manual-formatted-dir-prefix and manual-formatted-dirlist,
+ defined in paths.el.
+
+ * time.el (display-time):
+ Don't expand-file-name of "loadst". Let start-process search
+ the exec-path for it.
+
+ * texinfmt.el (texinfo-discard-line):
+ Allow and discard spaces at end of line.
+
+ * texinfo.el:
+ Split most of this into new file texinfmt.el.
+
+ * replace.el (perform-replace):
+ Bind help-form only while the read-char is done;
+ don't interfere with recursive edits.
+
+Thu May 29 19:05:19 1986 Richard M. Stallman (rms at prep)
+
+ * info.el (Info-validate): If file is valid,
+ erase the buffer of problems found previously.
+ Non-re search was used by mistake to search for regexps; fix.
+
+ * nroff-mode.el (electric-nroff-newline):
+ Leave point between the open-directive and the close-directive,
+ as it was supposed to do.
+ Add some directive-pairs to nroff-brace-table.
+
+Wed May 28 03:56:04 1986 Richard M. Stallman (rms at prep)
+
+ * telnet.el (telnet-initial-filter):
+ If host nonexistent, kill the telnet buffer and get error.
+
+Sun May 25 20:00:21 1986 Richard M. Stallman (rms at prep)
+
+ * rmail.el (rmail-search): Don't find a match in the current message.
+
+Mon May 19 22:11:52 1986 Richard M. Stallman (rms at prep)
+
+ * mh-e.el (mh-get-new-mail): Handle error messages reeived from `inc'.
+
+Thu May 15 18:35:25 1986 Richard M. Stallman (rms at prep)
+
+ * files.el (save-buffer): Switch meanings of one-C-u and two-C-u
+ in the code, so they match the documentation.
diff --git a/lisp/abbrev.el b/lisp/abbrev.el
new file mode 100644
index 00000000000..a8d525e0ec9
--- /dev/null
+++ b/lisp/abbrev.el
@@ -0,0 +1,269 @@
+;; Abbrev mode commands for Emacs
+
+;; Copyright (C) 1985, 1986 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+(defun abbrev-mode (arg)
+ "Toggle abbrev mode.
+With arg, turn abbrev mode on iff arg is positive.
+In abbrev mode, inserting an abbreviation causes it to expand
+and be replaced by its expansion."
+ (interactive "P")
+ (setq abbrev-mode
+ (if (null arg) (not abbrev-mode)
+ (> (prefix-numeric-value arg) 0)))
+ (set-buffer-modified-p (buffer-modified-p))) ;No-op, but updates mode line.
+
+(defvar edit-abbrevs-map nil
+ "Keymap used in edit-abbrevs.")
+(if edit-abbrevs-map
+ nil
+ (setq edit-abbrevs-map (make-sparse-keymap))
+ (define-key edit-abbrevs-map "\C-x\C-s" 'edit-abbrevs-redefine)
+ (define-key edit-abbrevs-map "\C-c\C-c" 'edit-abbrevs-redefine))
+
+(defun kill-all-abbrevs ()
+ "Undefine all defined abbrevs."
+ (interactive)
+ (let ((tables abbrev-table-name-list))
+ (while tables
+ (clear-abbrev-table (symbol-value (car tables)))
+ (setq tables (cdr tables)))))
+
+(defun insert-abbrevs ()
+ "Insert after point a description of all defined abbrevs.
+Mark is set after the inserted text."
+ (interactive)
+ (push-mark
+ (save-excursion
+ (let ((tables abbrev-table-name-list))
+ (while tables
+ (insert-abbrev-table-description (car tables) t)
+ (setq tables (cdr tables))))
+ (point))))
+
+(defun list-abbrevs ()
+ "Display a list of all defined abbrevs."
+ (interactive)
+ (display-buffer (prepare-abbrev-list-buffer)))
+
+(defun prepare-abbrev-list-buffer ()
+ (save-excursion
+ (set-buffer (get-buffer-create "*Abbrevs*"))
+ (erase-buffer)
+ (let ((tables abbrev-table-name-list))
+ (while tables
+ (insert-abbrev-table-description (car tables) t)
+ (setq tables (cdr tables))))
+ (goto-char (point-min))
+ (set-buffer-modified-p nil)
+ (edit-abbrevs-mode))
+ (get-buffer-create "*Abbrevs*"))
+
+(defun edit-abbrevs-mode ()
+ "Major mode for editing the list of abbrev definitions.
+\\{edit-abbrevs-map}"
+ (interactive)
+ (setq major-mode 'edit-abbrevs-mode)
+ (setq mode-name "Edit-Abbrevs")
+ (use-local-map edit-abbrevs-map))
+
+(defun edit-abbrevs ()
+ "Alter abbrev definitions by editing a list of them.
+Selects a buffer containing a list of abbrev definitions.
+You can edit them and type C-c C-c to redefine abbrevs
+according to your editing.
+Buffer contains a header line for each abbrev table,
+ which is the abbrev table name in parentheses.
+This is followed by one line per abbrev in that table:
+NAME USECOUNT EXPANSION HOOK
+where NAME and EXPANSION are strings with quotes,
+USECOUNT is an integer, and HOOK is any valid function
+or may be omitted (it is usually omitted)."
+ (interactive)
+ (switch-to-buffer (prepare-abbrev-list-buffer)))
+
+(defun edit-abbrevs-redefine ()
+ "Redefine abbrevs according to current buffer contents."
+ (interactive)
+ (define-abbrevs t)
+ (set-buffer-modified-p nil))
+
+(defun define-abbrevs (&optional arg)
+ "Define abbrevs according to current visible buffer contents.
+See documentation of edit-abbrevs for info on the format of the
+text you must have in the buffer.
+With argument, eliminate all abbrev definitions except
+the ones defined from the buffer now."
+ (interactive "P")
+ (if arg (kill-all-abbrevs))
+ (save-excursion
+ (goto-char (point-min))
+ (while (and (not (eobp)) (re-search-forward "^(" nil t))
+ (let* ((buf (current-buffer))
+ (table (read buf))
+ abbrevs)
+ (forward-line 1)
+ (while (progn (forward-line 1)
+ (not (eolp)))
+ (setq name (read buf) count (read buf) exp (read buf))
+ (skip-chars-backward " \t\n\f")
+ (setq hook (if (not (eolp)) (read buf)))
+ (skip-chars-backward " \t\n\f")
+ (setq abbrevs (cons (list name exp hook count) abbrevs)))
+ (define-abbrev-table table abbrevs)))))
+
+(defun read-abbrev-file (file &optional quietly)
+ "Read abbrev definitions from file written with write-abbrev-file.
+Takes file name as argument.
+Optional second argument non-nil means don't print anything."
+ (interactive "fRead abbrev file: ")
+ (load (if (and file (> (length file) 0)) file abbrev-file-name)
+ nil quietly)
+ (setq save-abbrevs t abbrevs-changed nil))
+
+(defun quietly-read-abbrev-file (file)
+ "Read abbrev definitions from file written with write-abbrev-file.
+Takes file name as argument. Does not print anything."
+ ;(interactive "fRead abbrev file: ")
+ (read-abbrev-file file t))
+
+(defun write-abbrev-file (file)
+ "Write all abbrev definitions to file of Lisp code.
+The file can be loaded to define the same abbrevs."
+ (interactive "FWrite abbrev file: ")
+ (or (and file (> (length file) 0))
+ (setq file abbrev-file-name))
+ (save-excursion
+ (set-buffer (get-buffer-create " write-abbrev-file"))
+ (erase-buffer)
+ (let ((tables abbrev-table-name-list))
+ (while tables
+ (insert-abbrev-table-description (car tables) nil)
+ (setq tables (cdr tables))))
+ (write-region 1 (point-max) file)
+ (erase-buffer)))
+
+(defun add-mode-abbrev (arg)
+ "Define mode-specific abbrev for last word(s) before point.
+Argument is how many words before point form the expansion;
+or zero means the region is the expansion.
+A negative argument means to undefine the specified abbrev.
+Reads the abbreviation in the minibuffer."
+ (interactive "p")
+ (add-abbrev
+ (if only-global-abbrevs
+ global-abbrev-table
+ (or local-abbrev-table
+ (error "No per-mode abbrev table.")))
+ "Mode" arg))
+
+(defun add-global-abbrev (arg)
+ "Define global (all modes) abbrev for last word(s) before point.
+Argument is how many words before point form the expansion;
+or zero means the region is the expansion.
+A negative argument means to undefine the specified abbrev.
+Reads the abbreviation in the minibuffer."
+ (interactive "p")
+ (add-abbrev global-abbrev-table "Global" arg))
+
+(defun add-abbrev (table type arg)
+ (let ((exp (and (>= arg 0)
+ (buffer-substring
+ (point)
+ (if (= arg 0) (mark)
+ (save-excursion (forward-word (- arg)) (point))))))
+ name)
+ (setq name (read-string (format "%s abbrev for \"%s\": "
+ type exp)))
+ (if (or (null exp)
+ (not (abbrev-expansion name table))
+ (y-or-n-p (format "%s expands to \"%s\"; redefine? "
+ name (abbrev-expansion name table))))
+ (define-abbrev table (downcase name) exp))))
+
+(defun inverse-add-mode-abbrev (arg)
+ "Define last word before point as a mode-specific abbrev.
+With argument N, defines the Nth word before point.
+Reads the expansion in the minibuffer.
+Expands the abbreviation after defining it."
+ (interactive "p")
+ (inverse-add-abbrev
+ (if only-global-abbrevs
+ global-abbrev-table
+ (or local-abbrev-table
+ (error "No per-mode abbrev table.")))
+ "Mode" arg))
+
+(defun inverse-add-global-abbrev (arg)
+ "Define last word before point as a global (mode-independent) abbrev.
+With argument N, defines the Nth word before point.
+Reads the expansion in the minibuffer.
+Expands the abbreviation after defining it."
+ (interactive "p")
+ (inverse-add-abbrev global-abbrev-table "Global" arg))
+
+(defun inverse-add-abbrev (table type arg)
+ (let (name nameloc exp)
+ (save-excursion
+ (forward-word (- arg))
+ (setq name (buffer-substring (point) (progn (forward-word 1)
+ (setq nameloc (point))))))
+ (setq exp (read-string (format "%s expansion for \"%s\": "
+ type name)))
+ (if (or (not (abbrev-expansion name table))
+ (y-or-n-p (format "%s expands to \"%s\"; redefine? "
+ name (abbrev-expansion name table))))
+ (progn
+ (define-abbrev table (downcase name) exp)
+ (save-excursion
+ (goto-char nameloc)
+ (expand-abbrev))))))
+
+(defun abbrev-prefix-mark (&optional arg)
+ "Mark current point as the beginning of an abbrev.
+Abbrev to be expanded starts here rather than at
+beginning of word. This way, you can expand an abbrev
+with a prefix: insert the prefix, use this command,
+then insert the abbrev."
+ (interactive "P")
+ (or arg (expand-abbrev))
+ (setq abbrev-start-location (point-marker)
+ abbrev-start-location-buffer (current-buffer))
+ (insert "-"))
+
+(defun expand-region-abbrevs (start end &optional noquery)
+ "For abbrev occurrence in the region, offer to expand it.
+The user is asked to type y or n for each occurrence.
+A numeric argument means don't query; expand all abbrevs.
+Calling from a program, arguments are START END &optional NOQUERY."
+ (interactive "r")
+ (save-excursion
+ (goto-char (min start end))
+ (let ((lim (- (point-max) (max start end))))
+ (while (and (not (eobp))
+ (progn (forward-word 1)
+ (<= (point) (- (point-max) lim))))
+ (let ((modp (buffer-modified-p)))
+ (if (expand-abbrev)
+ (progn
+ (set-buffer-modified-p modp)
+ (unexpand-abbrev)
+ (if (or noquery (y-or-n-p "Expand this? "))
+ (expand-abbrev)))))))))
diff --git a/lisp/abbrev.elc b/lisp/abbrev.elc
new file mode 100644
index 00000000000..1bbca206bce
--- /dev/null
+++ b/lisp/abbrev.elc
Binary files differ
diff --git a/lisp/abbrevlist.el b/lisp/abbrevlist.el
index 554bacd645f..15b842c6cb6 100644
--- a/lisp/abbrevlist.el
+++ b/lisp/abbrevlist.el
@@ -22,7 +22,7 @@
(provide 'abbrevlist)
(defun list-one-abbrev-table (abbrev-table output-buffer)
- "Display alphabetical listing of ABBREV-TABLE in buffer OUTPUT-BUFFER."
+ "Display alphabetical listing of ABBREV-TABLE in buffer BUFFER."
(with-output-to-temp-buffer output-buffer
(save-excursion
(let ((abbrev-list nil) (first-column 0))
diff --git a/lisp/abbrevlist.elc b/lisp/abbrevlist.elc
new file mode 100644
index 00000000000..22267e91da0
--- /dev/null
+++ b/lisp/abbrevlist.elc
Binary files differ
diff --git a/lisp/ada.el b/lisp/ada.el
index 22c80707b42..6b99beb3fbb 100644
--- a/lisp/ada.el
+++ b/lisp/ada.el
@@ -3,23 +3,6 @@
; (borrows heavily from Mick Jordan's Modula-2 package for GNU,
; as modified by Peter Robinson, Michael Schmidt, and Tom Perrine.)
-;; Copyright (C) 1985, 1986, 1987 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
(setq auto-mode-alist (cons (cons "\\.ada$" 'ada-mode) auto-mode-alist))
@@ -106,30 +89,33 @@
Most control constructs and declarations of Ada can be inserted in the buffer
by typing Control-C followed by a character mnemonic for the construct.
-\\<ada-mode-map>\\[ada-array] array \\[ada-exception-block] exception block
-\\[ada-exception] exception \\[ada-declare-block] declare block
-\\[ada-package-spec] package spec \\[ada-package-body] package body
-\\[ada-procedure-spec] procedure spec \\[ada-subprogram-body] proc/func body
-\\[ada-function-spec] func spec \\[ada-for-loop] for loop
- \\[ada-if] if
- \\[ada-elsif] elsif
- \\[ada-else] else
-\\[ada-private] private \\[ada-loop] loop
-\\[ada-record] record \\[ada-case] case
-\\[ada-subtype] subtype \\[ada-separate] separate
-\\[ada-type] type \\[ada-tabsize] tab spacing for indents
-\\[ada-when] when \\[ada-while] while
- \\[ada-exit] exit
-\\[ada-paired-parens] paired parens \\[ada-inline-comment] inline comment
- \\[ada-header] header spec
-\\[ada-compile] compile \\[ada-bind] bind
-\\[ada-find-listing] find error list
-\\[ada-library-name] name library \\[ada-options-for-bind] options for bind
-
-\\[ada-backward-to-same-indent] and \\[ada-forward-to-same-indent] move backward and forward respectively to the next line
+C-c C-a array C-c b exception block
+C-c C-e exception C-c d declare block
+C-c C-k package spec C-c k package body
+C-c C-p procedure spec C-c p proc/func body
+C-c C-f func spec C-c f for loop
+ C-c i if
+ C-c I elsif
+ C-c e else
+C-c C-v private C-c l loop
+C-c C-r record C-c c case
+C-c C-s subtype C-c s separate
+C-c C-t type C-c t tab spacing for indents
+C-c C-w when C-c w while
+ C-c x exit
+C-c ( paired parens C-c - inline comment
+ C-c h header sec
+C-c C compile C-c B bind
+C-c E find error list
+C-c L name library C-c O options for bind
+
+C-c < and C-c > move backward and forward respectively to the next line
having the same (or lesser) level of indentation.
-Variable `ada-indent' controls the number of spaces for indent/undent."
+Variable ada-indent controls the number of spaces for indent/undent.
+
+\\{ada-mode-map}
+"
(interactive)
(kill-all-local-variables)
(use-local-map ada-mode-map)
@@ -153,7 +139,7 @@ Variable `ada-indent' controls the number of spaces for indent/undent."
(make-local-variable 'comment-start)
(setq comment-start "--")
(make-local-variable 'comment-end)
- (setq comment-end "")
+ (setq comment-end "\n")
(make-local-variable 'comment-column)
(setq comment-column 41)
(make-local-variable 'comment-start-skip)
@@ -165,9 +151,8 @@ Variable `ada-indent' controls the number of spaces for indent/undent."
(run-hooks 'ada-mode-hook))
(defun ada-tabsize (s)
- "Changes spacing used for indentation.
-The prefix argument is used as the new spacing."
- (interactive "p")
+ "changes spacing used for indentation. Reads spacing from minibuffer."
+ (interactive "nnew indentation spacing: ")
(setq ada-indent s))
(defun ada-newline ()
@@ -188,9 +173,9 @@ The prefix argument is used as the new spacing."
(backward-delete-char-untabify ada-indent nil))
(defun ada-go-to-this-indent (step indent-level)
- "Move point repeatedly by STEP lines until the current line has
-given INDENT-LEVEL or less, or the start or end of the buffer is reached.
-Ignore blank lines, statement labels and block or loop names."
+ "Move point repeatedly by <step> lines till the current line
+has given indent-level or less, or the start/end of the buffer is hit.
+Ignore blank lines, statement labels, block/loop names."
(while (and
(zerop (forward-line step))
(or (looking-at "^[ ]*$")
@@ -202,21 +187,21 @@ Ignore blank lines, statement labels and block or loop names."
(defun ada-backward-to-same-indent ()
"Move point backwards to nearest line with same indentation or less.
-If not found, point is left at the top of the buffer."
+If not found, point is left at top of buffer."
(interactive)
(ada-go-to-this-indent -1 (current-indentation))
(back-to-indentation))
(defun ada-forward-to-same-indent ()
"Move point forwards to nearest line with same indentation or less.
-If not found, point is left at the start of the last line in the buffer."
+If not found, point is left at start of last line in buffer."
(interactive)
(ada-go-to-this-indent 1 (current-indentation))
(back-to-indentation))
(defun ada-array ()
- "Insert array type definition. Uses the minibuffer to prompt
-for component type and index subtypes."
+ "Insert array type definition, prompting for component type,
+leaving the user to type in the index subtypes."
(interactive)
(insert "array ()")
(backward-char)
@@ -228,9 +213,8 @@ for component type and index subtypes."
(end-of-line))
(defun ada-case ()
- "Build skeleton case statement.
-Uses the minibuffer to prompt for the selector expression.
-Also builds the first when clause."
+ "Build skeleton case statment, prompting for the selector expression.
+starts up the first when clause, too."
(interactive)
(insert "case ")
(insert (read-string "selector expression: ") " is")
@@ -243,59 +227,57 @@ Also builds the first when clause."
(ada-when))
(defun ada-declare-block ()
- "Insert a block with a declare part.
-Indent for the first declaration."
+ "Insert a block with a declare part and indent for the 1st declaration."
(interactive)
(let ((ada-block-name (read-string "[block name]: ")))
(insert "declare")
(cond
- ( (not (string-equal ada-block-name ""))
- (beginning-of-line)
- (open-line 1)
- (insert ada-block-name ":")
- (next-line 1)
- (end-of-line)))
+ ( (not (string-equal ada-block-name ""))
+ (beginning-of-line)
+ (open-line 1)
+ (insert ada-block-name ":")
+ (next-line 1)
+ (end-of-line)))
(ada-newline)
(ada-newline)
(insert "begin")
(ada-newline)
(ada-newline)
(if (string-equal ada-block-name "")
- (insert "end;")
+ (insert "end;")
(insert "end " ada-block-name ";"))
- )
+ )
(end-of-line -2)
(ada-tab))
(defun ada-exception-block ()
- "Insert a block with an exception part.
-Indent for the first line of code."
+ "Insert a block with an exception part and indent for the 1st line of code."
(interactive)
(let ((block-name (read-string "[block name]: ")))
(insert "begin")
(cond
- ( (not (string-equal block-name ""))
- (beginning-of-line)
- (open-line 1)
- (insert block-name ":")
- (next-line 1)
- (end-of-line)))
+ ( (not (string-equal block-name ""))
+ (beginning-of-line)
+ (open-line 1)
+ (insert block-name ":")
+ (next-line 1)
+ (end-of-line)))
(ada-newline)
(ada-newline)
(insert "exception")
(ada-newline)
(ada-newline)
(cond
- ( (string-equal block-name "")
- (insert "end;"))
- ( t
- (insert "end " block-name ";")))
- )
+ ( (string-equal block-name "")
+ (insert "end;"))
+ ( t
+ (insert "end " block-name ";")))
+ )
(end-of-line -2)
(ada-tab))
(defun ada-exception ()
- "Insert an indented exception part into a block."
+ "Undent and insert an exception part into a block. Reindent."
(interactive)
(ada-untab)
(insert "exception")
@@ -385,7 +367,7 @@ Indent for the first line of code."
(ada-tab))
(defun ada-loop ()
- "Insert a skeleton loop statement. exit statement added by hand."
+ "insert a skeleton loop statement. exit statement added by hand."
(interactive)
(insert "loop ")
(let* ((ada-loop-name (read-string "[loop name]: "))
@@ -440,10 +422,10 @@ Indent for the first line of code."
(ada-tab))
(defun ada-get-arg-list ()
- "Read from the user a procedure or function argument list.
+ "Read from user a procedure or function argument list.
Add parens unless arguments absent, and insert into buffer.
-Individual arguments are arranged vertically if entered one at a time.
-Arguments ending with `;' are presumed single and stacked."
+Individual arguments are arranged vertically if entered one-at-a-time.
+Arguments ending with ';' are presumed single and stacked."
(insert " (")
(let ((ada-arg-indent (current-column))
(ada-args (read-string "[arguments]: ")))
@@ -474,9 +456,9 @@ Arguments ending with `;' are presumed single and stacked."
(ada-get-arg-list))
(defun get-ada-subprogram-name ()
- "Return (without moving point or mark) a pair whose CAR is the name of
-the function or procedure whose spec immediately precedes point, and whose
-CDR is the column number where the procedure/function keyword was found."
+ "Return (without moving point or mark) a pair whose CAR is
+the name of the function or procedure whose spec immediately precedes point,
+and whose CDR is the column nbr the procedure/function keyword was found at."
(save-excursion
(let ((ada-proc-indent 0))
(if (re-search-backward
@@ -495,7 +477,7 @@ CDR is the column number where the procedure/function keyword was found."
(defun ada-subprogram-body ()
"Insert frame for subprogram body.
-Invoke right after `ada-function-spec' or `ada-procedure-spec'."
+Invoke right after ada-function-spec or ada-procedure-spec."
(interactive)
(insert " is")
(let ((ada-subprogram-name-col (get-ada-subprogram-name)))
@@ -510,7 +492,7 @@ Invoke right after `ada-function-spec' or `ada-procedure-spec'."
(ada-tab))
(defun ada-separate ()
- "Finish a body stub with `is separate'."
+ "Finish a body stub with 'is separate'."
(interactive)
(insert " is")
(ada-newline)
@@ -586,9 +568,8 @@ Invoke right after `ada-function-spec' or `ada-procedure-spec'."
(backward-char))
(defun ada-inline-comment ()
- "Start a comment after the end of the line, indented at least
-`comment-column' spaces. If starting after `end-comment-column',
-start a new line."
+ "Start a comment after the end of the line, indented at least COMMENT-COLUMN.
+If starting after END-COMMENT-COLUMN, start a new line."
(interactive)
(end-of-line)
(if (> (current-column) end-comment-column) (newline))
@@ -596,30 +577,30 @@ start a new line."
(insert " -- "))
(defun ada-display-comment ()
-"Inserts three comment lines, making a display comment."
+"Inserts 3 comment lines, making a display comment."
(interactive)
(insert "--\n-- \n--")
(end-of-line 0))
;; Much of this is specific to Ada-Ed
-(defvar ada-lib-dir-name "lib" "*Current Ada program library directory.")
+(defvar ada-lib-dir-name "lib" "*Current ada program library directory.")
(defvar ada-bind-opts "" "*Options to supply for binding.")
(defun ada-library-name (ada-lib-name)
- "Specify name of Ada library directory for later compilations."
- (interactive "DName of Ada library directory: ")
+ "Specify name of ada library directory for later compilations."
+ (interactive "Dname of ada library directory: ")
(setq ada-lib-dir-name ada-lib-name))
(defun ada-options-for-bind ()
- "Specify options, such as -m and -i, needed for `ada-bind'."
- (setq ada-bind-opts (read-string "-m and -i options for `ada-bind': ")))
+ "Specify options, such as -m and -i, needed for adabind."
+ (setq ada-bind-opts (read-string "-m and -i options for adabind: ")))
-(defun ada-compile (arg)
+(defun ada-compile (ada-prefix-arg)
"Save the current buffer and compile it into the current program library.
Initialize the library if a prefix arg is given."
(interactive "P")
- (let* ((ada-init (if (null arg) "" "-n "))
+ (let* ((ada-init (if (null ada-prefix-arg) "" "-n "))
(ada-source-file (buffer-name)))
(compile
(concat "adacomp " ada-init "-l " ada-lib-dir-name " " ada-source-file))))
diff --git a/lisp/ada.elc b/lisp/ada.elc
new file mode 100644
index 00000000000..74c3ddac0c4
--- /dev/null
+++ b/lisp/ada.elc
Binary files differ
diff --git a/lisp/add-log.el b/lisp/add-log.el
new file mode 100644
index 00000000000..74dc3127c26
--- /dev/null
+++ b/lisp/add-log.el
@@ -0,0 +1,87 @@
+;; Change log maintenance commands for Emacs
+;; Copyright (C) 1985 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+(defun add-change-log-entry (whoami file-name &optional other-window)
+ "Find change log file and add an entry for today.
+First arg (interactive prefix) non-nil means prompt for user name and site.
+Second arg is file name of change log.
+Optional third arg OTHER-WINDOW non-nil means visit in other window."
+ (interactive
+ (list current-prefix-arg
+ (let ((default
+ (if (eq system-type 'vax-vms) "$CHANGE_LOG$.TXT" "ChangeLog")))
+ (expand-file-name
+ (read-file-name (format "Log file (default %s): " default)
+ nil default)))))
+ (let* ((default
+ (if (eq system-type 'vax-vms) "$CHANGE_LOG$.TXT" "ChangeLog"))
+ (full-name (if whoami
+ (read-input "Full name: " (user-full-name))
+ (user-full-name)))
+ ;; Note that some sites have room and phone number fields in
+ ;; full name which look silly when inserted. Rather than do
+ ;; anything about that here, let user give prefix argument so that
+ ;; s/he can edit the full name field in prompter if s/he wants.
+ (login-name (if whoami
+ (read-input "Login name: " (user-login-name))
+ (user-login-name)))
+ (site-name (if whoami
+ (read-input "Site name: " (system-name))
+ (system-name))))
+ (if (file-directory-p file-name)
+ (setq file-name (concat (file-name-as-directory file-name)
+ default)))
+ (if other-window (find-file-other-window file-name) (find-file file-name))
+ (or (eq major-mode 'indented-text-mode)
+ (progn
+ (indented-text-mode)
+ (setq left-margin 8)
+ (setq fill-column 74)))
+ (auto-fill-mode 1)
+ (undo-boundary)
+ (goto-char (point-min))
+ (if (not (and (looking-at (substring (current-time-string) 0 10))
+ (save-excursion (re-search-forward "(.*@"
+ (save-excursion
+ (end-of-line) (point))
+ t)
+ (skip-chars-backward "^(")
+ (looking-at login-name))))
+ (progn (insert (current-time-string)
+ " " full-name
+ " (" login-name
+ "@" site-name ")\n\n")))
+ (goto-char (point-min))
+ (forward-line 1)
+ (while (looking-at "\\sW")
+ (forward-line 1))
+ (delete-region (point)
+ (progn
+ (skip-chars-backward "\n")
+ (point)))
+ (open-line 3)
+ (forward-line 2)
+ (indent-to left-margin)
+ (insert "* ")))
+
+(defun add-change-log-entry-other-window ()
+ "Find change log file in other window, and add an entry for today."
+ (interactive)
+ (add-change-log-entry nil default-directory t))
diff --git a/lisp/add-log.elc b/lisp/add-log.elc
new file mode 100644
index 00000000000..277a06860e3
--- /dev/null
+++ b/lisp/add-log.elc
Binary files differ
diff --git a/lisp/array.el b/lisp/array.el
deleted file mode 100644
index d58d558188e..00000000000
--- a/lisp/array.el
+++ /dev/null
@@ -1,957 +0,0 @@
-;;; Array editing commands for Gnu Emacs
-;;; Written by dmb%morgoth@harvard.harvard.edu (address is old)
-;;; (David M. Brown at Goldberg-Zoino & Associates, Inc.)
-;;; Thanks to cph@kleph.ai.mit.edu for assistance
-
-;; Copyright (C) 1987 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;;; To do:
-;;; Smooth initialization process by grokking local variables list
-;;; at end of buffer or parsing buffer using whitespace as delimiters.
-;;; Make 'array-copy-column-right faster.
-
-
-
-;;; Internal information functions.
-
-(defun array-cursor-in-array-range ()
- "Returns t if the cursor is in a valid array cell.
-Its ok to be on a row number line."
- (let ((columns-last-line (% max-column columns-per-line)))
- ;; Requires buffer-line and buffer-column to be current.
- (not (or
- ;; The cursor is too far to the right.
- (>= buffer-column line-length)
- ;; The cursor is below the last row.
- (>= buffer-line (* lines-per-row max-row))
- ;; The cursor is on the last line of the row, the line is smaller
- ;; than the others, and the cursor is after the last array column
- ;; on the line.
- (and (zerop (% (1+ buffer-line) lines-per-row))
- (not (zerop columns-last-line))
- (>= buffer-column (* columns-last-line field-width)))))))
-
-(defun array-current-row ()
- "Return the array row of the field in which the cursor is located."
- ;; Requires buffer-line and buffer-column to be current.
- (and (array-cursor-in-array-range)
- (1+ (floor buffer-line lines-per-row))))
-
-(defun array-current-column ()
- "Return the array column of the field in which the cursor is located."
- ;; Requires buffer-line and buffer-column to be current.
- (and (array-cursor-in-array-range)
- ;; It's not okay to be on a row number line.
- (not (and rows-numbered
- (zerop (% buffer-line lines-per-row))))
- (+
- ;; Array columns due to line differences.
- (* columns-per-line
- (if rows-numbered
- (1- (% buffer-line lines-per-row))
- (% buffer-line lines-per-row)))
- ;; Array columns on the current line.
- (ceiling (1+ buffer-column) field-width))))
-
-(defun array-update-array-position (&optional a-row a-column)
- "Set `array-row' and `array-column' to their current values or
-to the optional arguments A-ROW and A-COLUMN."
- ;; Requires that buffer-line and buffer-column be current.
- (setq array-row (or a-row (array-current-row))
- array-column (or a-column (array-current-column))))
-
-(defun array-update-buffer-position ()
- "Set buffer-line and buffer-column to their current values."
- (setq buffer-line (current-line)
- buffer-column (current-column)))
-
-
-
-;;; Information commands.
-
-(defun array-what-position ()
- "Display the row and column in which the cursor is positioned."
- (interactive)
- (let ((buffer-line (current-line))
- (buffer-column (current-column)))
- (message (format "Array row: %s Array column: %s"
- (prin1-to-string (array-current-row))
- (prin1-to-string (array-current-column))))))
-
-(defun array-display-local-variables ()
- "Display the current state of the local variables in the minibuffer."
- (interactive)
- (let ((buf (buffer-name (current-buffer))))
- (with-output-to-temp-buffer "*Local Variables*"
- (buffer-disable-undo standard-output)
- (terpri)
- (princ (format " Buffer: %s\n\n" buf))
- (princ (format " max-row: %s\n"
- (prin1-to-string max-row)))
- (princ (format " max-column: %s\n"
- (prin1-to-string max-column)))
- (princ (format " columns-per-line: %s\n"
- (prin1-to-string columns-per-line)))
- (princ (format " field-width: %s\n"
- (prin1-to-string field-width)))
- (princ (format " rows-numbered: %s\n"
- (prin1-to-string rows-numbered)))
- (princ (format " lines-per-row: %s\n"
- (prin1-to-string lines-per-row)))
- (princ (format " line-length: %s\n"
- (prin1-to-string line-length))))))
-
-
-
-;;; Internal movement functions.
-
-(defun array-beginning-of-field (&optional go-there)
- "Return the column of the beginning of the current field.
-Optional argument GO-THERE, if non-nil, means go there too."
- ;; Requires that buffer-column be current.
- (let ((goal-column (- buffer-column (% buffer-column field-width))))
- (if go-there
- (move-to-column-untabify goal-column)
- goal-column)))
-
-(defun array-end-of-field (&optional go-there)
- "Return the column of the end of the current array field.
-If optional argument GO-THERE is non-nil, go there too."
- ;; Requires that buffer-column be current.
- (let ((goal-column (+ (- buffer-column (% buffer-column field-width))
- field-width)))
- (if go-there
- (move-to-column-untabify goal-column)
- goal-column)))
-
-(defun array-move-to-cell (a-row a-column)
- "Move to array row A-ROW and array column A-COLUMN.
-Leave point at the beginning of the field and return the new buffer column."
- (let ((goal-line (+ (* lines-per-row (1- a-row))
- (if rows-numbered 1 0)
- (floor (1- a-column) columns-per-line)))
- (goal-column (* field-width (% (1- a-column) columns-per-line))))
- (goto-char (point-min))
- (forward-line goal-line)
- (move-to-column-untabify goal-column)))
-
-(defun array-move-to-row (a-row)
- "Move to array row A-ROW preserving the current array column.
-Leave point at the beginning of the field and return the new array row."
- ;; Requires that buffer-line and buffer-column be current.
- (let ((goal-line (+ (* lines-per-row (1- a-row))
- (% buffer-line lines-per-row)))
- (goal-column (- buffer-column (% buffer-column field-width))))
- (forward-line (- goal-line buffer-line))
- (move-to-column-untabify goal-column)
- a-row))
-
-(defun array-move-to-column (a-column)
- "Move to array column A-COLUMN preserving the current array row.
-Leave point at the beginning of the field and return the new array column."
- ;; Requires that buffer-line and buffer-column be current.
- (let ((goal-line (+ (- buffer-line (% buffer-line lines-per-row))
- (if rows-numbered 1 0)
- (floor (1- a-column) columns-per-line)))
- (goal-column (* field-width (% (1- a-column) columns-per-line))))
- (forward-line (- goal-line buffer-line))
- (move-to-column-untabify goal-column)
- a-column))
-
-(defun array-move-one-row (sign)
- "Move one array row in direction SIGN (1 or -1).
-Leave point at the beginning of the field and return the new array row.
-If requested to move beyond the array bounds, signal an error."
- ;; Requires that buffer-line and buffer-column be current.
- (let ((goal-column (array-beginning-of-field))
- (array-row (or (array-current-row)
- (error "Cursor is not in a valid array cell."))))
- (cond ((and (= array-row max-row) (= sign 1))
- (error "End of array."))
- ((and (= array-row 1) (= sign -1))
- (error "Beginning of array."))
- (t
- (progn
- (forward-line (* sign lines-per-row))
- (move-to-column-untabify goal-column)
- (+ array-row sign))))))
-
-(defun array-move-one-column (sign)
- "Move one array column in direction SIGN (1 or -1).
-Leave point at the beginning of the field and return the new array column.
-If requested to move beyond the array bounds, signal an error."
- ;; Requires that buffer-line and buffer-column be current.
- (let ((array-column (or (array-current-column)
- (error "Cursor is not in a valid array cell."))))
- (cond ((and (= array-column max-column) (= sign 1))
- (error "End of array."))
- ((and (= array-column 1) (= sign -1))
- (error "Beginning of array."))
- (t
- (cond
- ;; Going backward from first column on the line.
- ((and (= sign -1) (= 1 (% array-column columns-per-line)))
- (forward-line -1)
- (move-to-column-untabify
- (* field-width (1- columns-per-line))))
- ;; Going forward from last column on the line.
- ((and (= sign 1) (zerop (% array-column columns-per-line)))
- (forward-line 1))
- ;; Somewhere in the middle of the line.
- (t
- (move-to-column-untabify (+ (array-beginning-of-field)
- (* field-width sign)))))
- (+ array-column sign)))))
-
-(defun array-normalize-cursor ()
- "Move the cursor to the first non-whitespace character in the field and,
-if necessary, scroll horizontally to keep the cursor in view."
- ;; Assumes point is at the beginning of the field.
- (let ((buffer-column (current-column)))
- (skip-chars-forward " \t"
- (1- (save-excursion (array-end-of-field t) (point))))
- (array-maybe-scroll-horizontally)))
-
-(defun array-maybe-scroll-horizontally ()
- "If necessary, scroll horizontally to keep the cursor in view."
- ;; This is only called from array-normalize-cursor so
- ;; buffer-column will always be current.
- (let ((w-hscroll (window-hscroll))
- (w-width (window-width)))
- (cond
- ((and (>= buffer-column w-hscroll)
- (<= buffer-column (+ w-hscroll w-width)))
- ;; It's already visible. Do nothing.
- nil)
- ((> buffer-column (+ w-hscroll w-width))
- ;; It's to the right. Scroll left.
- (scroll-left (- (- buffer-column w-hscroll)
- (/ w-width 2))))
- (t
- ;; It's to the left. Scroll right.
- (scroll-right (+ (- w-hscroll buffer-column)
- (/ w-width 2)))))))
-
-
-
-;;; Movement commands.
-
-(defun array-next-row (&optional arg)
- "Move down one array row, staying in the current array column.
-If optional ARG is given, move down ARG array rows."
- (interactive "p")
- (let ((buffer-line (current-line))
- (buffer-column (current-column)))
- (if (= (abs arg) 1)
- (array-move-one-row arg)
- (array-move-to-row
- (limit-index (+ (or (array-current-row)
- (error "Cursor is not in an array cell."))
- arg)
- max-row))))
- (array-normalize-cursor))
-
-(defun array-previous-row (&optional arg)
- "Move up one array row, staying in the current array column.
-If optional ARG is given, move up ARG array rows."
- (interactive "p")
- (array-next-row (- arg)))
-
-(defun array-forward-column (&optional arg)
- "Move forward one field, staying in the current array row.
-If optional ARG is given, move forward ARG array columns.
-If necessary, keep the cursor in the window by scrolling right or left."
- (interactive "p")
- (let ((buffer-line (current-line))
- (buffer-column (current-column)))
- (if (= (abs arg) 1)
- (array-move-one-column arg)
- (array-move-to-column
- (limit-index (+ (or (array-current-column)
- (error "Cursor is not in an array cell."))
- arg)
- max-column))))
- (array-normalize-cursor))
-
-(defun array-backward-column (&optional arg)
- "Move backward one field, staying in the current array row.
-If optional ARG is given, move backward ARG array columns.
-If necessary, keep the cursor in the window by scrolling right or left."
- (interactive "p")
- (array-forward-column (- arg)))
-
-(defun array-goto-cell (a-row a-column)
- "Go to array row A-ROW and array column A-COLUMN."
- (interactive "nArray row: \nnArray column: ")
- (array-move-to-cell
- (limit-index a-row max-row)
- (limit-index a-column max-column))
- (array-normalize-cursor))
-
-
-
-;;; Internal copying functions.
-
-(defun array-field-string ()
- "Return the field string at the current cursor location."
- ;; Requires that buffer-column be current.
- (buffer-substring
- (save-excursion (array-beginning-of-field t) (point))
- (save-excursion (array-end-of-field t) (point))))
-
-(defun array-copy-once-vertically (sign)
- "Copy the current field into one array row in direction SIGN (1 or -1).
-Leave point at the beginning of the field and return the new array row.
-If requested to move beyond the array bounds, signal an error."
- ;; Requires that buffer-line, buffer-column, and copy-string be current.
- (let ((a-row (array-move-one-row sign)))
- (let ((inhibit-quit t))
- (delete-region (point) (save-excursion (array-end-of-field t) (point)))
- (insert copy-string))
- (move-to-column buffer-column)
- a-row))
-
-(defun array-copy-once-horizontally (sign)
- "Copy the current field into one array column in direction SIGN (1 or -1).
-Leave point at the beginning of the field and return the new array column.
-If requested to move beyond the array bounds, signal an error."
- ;; Requires that buffer-line, buffer-column, and copy-string be current.
- (let ((a-column (array-move-one-column sign)))
- (array-update-buffer-position)
- (let ((inhibit-quit t))
- (delete-region (point) (save-excursion (array-end-of-field t) (point)))
- (insert copy-string))
- (move-to-column buffer-column)
- a-column))
-
-(defun array-copy-to-row (a-row)
- "Copy the current field vertically into every cell up to and including A-ROW.
-Leave point at the beginning of the field."
- ;; Requires that buffer-line, buffer-column, array-row, and
- ;; copy-string be current.
- (let* ((num (- a-row array-row))
- (count (abs num))
- (sign (if (zerop count) () (/ num count))))
- (while (> count 0)
- (array-move-one-row sign)
- (array-update-buffer-position)
- (let ((inhibit-quit t))
- (delete-region (point) (save-excursion (array-end-of-field t) (point)))
- (insert copy-string))
- (move-to-column buffer-column)
- (setq count (1- count)))))
-
-(defun array-copy-to-column (a-column)
- "Copy the current field horizontally into every cell up to and including
-A-COLUMN. Leave point at the beginning of the field."
- ;; Requires that buffer-line, buffer-column, array-column, and
- ;; copy-string be current.
- (let* ((num (- a-column array-column))
- (count (abs num))
- (sign (if (zerop count) () (/ num count))))
- (while (> count 0)
- (array-move-one-column sign)
- (array-update-buffer-position)
- (let ((inhibit-quit t))
- (delete-region (point) (save-excursion (array-end-of-field t) (point)))
- (insert copy-string))
- (move-to-column buffer-column)
- (setq count (1- count)))))
-
-(defun array-copy-to-cell (a-row a-column)
- "Copy the current field into the cell at A-ROW, A-COLUMN.
-Leave point at the beginning of the field."
- ;; Requires that copy-string be current.
- (array-move-to-cell a-row a-column)
- (array-update-buffer-position)
- (delete-region (point) (save-excursion (array-end-of-field t) (point)))
- (insert copy-string)
- (move-to-column buffer-column))
-
-
-
-;;; Commands for copying.
-
-(defun array-copy-down (&optional arg)
- "Copy the current field one array row down.
-If optional ARG is given, copy down through ARG array rows."
- (interactive "p")
- (let* ((buffer-line (current-line))
- (buffer-column (current-column))
- (array-row (or (array-current-row)
- (error "Cursor is not in a valid array cell.")))
- (copy-string (array-field-string)))
- (if (= (abs arg) 1)
- (array-copy-once-vertically arg)
- (array-copy-to-row
- (limit-index (+ array-row arg) max-row))))
- (array-normalize-cursor))
-
-(defun array-copy-up (&optional arg)
- "Copy the current field one array row up.
-If optional ARG is given, copy up through ARG array rows."
- (interactive "p")
- (array-copy-down (- arg)))
-
-(defun array-copy-forward (&optional arg)
- "Copy the current field one array column to the right.
-If optional ARG is given, copy through ARG array columns to the right."
- (interactive "p")
- (let* ((buffer-line (current-line))
- (buffer-column (current-column))
- (array-column (or (array-current-column)
- (error "Cursor is not in a valid array cell.")))
- (copy-string (array-field-string)))
- (if (= (abs arg) 1)
- (array-copy-once-horizontally arg)
- (array-copy-to-column
- (limit-index (+ array-column arg) max-column))))
- (array-normalize-cursor))
-
-(defun array-copy-backward (&optional arg)
- "Copy the current field one array column to the left.
-If optional ARG is given, copy through ARG array columns to the left."
- (interactive "p")
- (array-copy-forward (- arg)))
-
-(defun array-copy-column-forward (&optional arg)
- "Copy the entire current column in to the column to the right.
-If optional ARG is given, copy through ARG array columns to the right."
- (interactive "p")
- (array-update-buffer-position)
- (array-update-array-position)
- (if (not array-column)
- (error "Cursor is not in a valid array cell."))
- (message "Working...")
- (let ((this-row 0))
- (while (< this-row max-row)
- (setq this-row (1+ this-row))
- (array-move-to-cell this-row array-column)
- (array-update-buffer-position)
- (let ((copy-string (array-field-string)))
- (if (= (abs arg) 1)
- (array-copy-once-horizontally arg)
- (array-copy-to-column
- (limit-index (+ array-column arg) max-column))))))
- (message "Working...done")
- (array-move-to-row array-row)
- (array-normalize-cursor))
-
-(defun array-copy-column-backward (&optional arg)
- "Copy the entire current column one column to the left.
-If optional ARG is given, copy through ARG columns to the left."
- (interactive "p")
- (array-copy-column-forward (- arg)))
-
-(defun array-copy-row-down (&optional arg)
- "Copy the entire current row one row down.
-If optional ARG is given, copy through ARG rows down."
- (interactive "p")
- (array-update-buffer-position)
- (array-update-array-position)
- (if (not array-row)
- (error "Cursor is not in a valid array cell."))
- (cond
- ((and (= array-row 1) (= arg -1))
- (error "Beginning of array."))
- ((and (= array-row max-row) (= arg 1))
- (error "End of array."))
- (t
- (let* ((copy-string
- (buffer-substring
- (save-excursion (array-move-to-cell array-row 1)
- (point))
- (save-excursion (array-move-to-cell array-row max-column)
- (forward-line 1)
- (point))))
- (this-row array-row)
- (goal-row (limit-index (+ this-row arg) max-row))
- (num (- goal-row this-row))
- (count (abs num))
- (sign (if (not (zerop count)) (/ num count))))
- (while (> count 0)
- (setq this-row (+ this-row sign))
- (array-move-to-cell this-row 1)
- (let ((inhibit-quit t))
- (delete-region (point)
- (save-excursion
- (array-move-to-cell this-row max-column)
- (forward-line 1)
- (point)))
- (insert copy-string))
- (setq count (1- count)))
- (array-move-to-cell goal-row (or array-column 1)))))
- (array-normalize-cursor))
-
-(defun array-copy-row-up (&optional arg)
- "Copy the entire current array row into the row above.
-If optional ARG is given, copy through ARG rows up."
- (interactive "p")
- (array-copy-row-down (- arg)))
-
-(defun array-fill-rectangle ()
- "Copy the field at mark into every cell between mark and point."
- (interactive)
- ;; Bind arguments.
- (array-update-buffer-position)
- (let ((p-row (or (array-current-row)
- (error "Cursor is not in a valid array cell.")))
- (p-column (or (array-current-column)
- (error "Cursor is not in a valid array cell.")))
- (m-row
- (save-excursion
- (exchange-point-and-mark)
- (array-update-buffer-position)
- (or (array-current-row)
- (error "Mark is not in a valid array cell."))))
- (m-column
- (save-excursion
- (exchange-point-and-mark)
- (array-update-buffer-position)
- (or (array-current-column)
- (error "Mark is not in a valid array cell.")))))
- (message "Working...")
- (let ((top-row (min m-row p-row))
- (bottom-row (max m-row p-row))
- (left-column (min m-column p-column))
- (right-column (max m-column p-column)))
- ;; Do the first row.
- (let ((copy-string
- (save-excursion
- (array-move-to-cell m-row m-column)
- (array-update-buffer-position)
- (array-field-string))))
- (array-copy-to-cell top-row left-column)
- (array-update-array-position top-row left-column)
- (array-update-buffer-position)
- (array-copy-to-column right-column))
- ;; Do the rest of the rows.
- (array-move-to-cell top-row left-column)
- (let ((copy-string
- (buffer-substring
- (point)
- (save-excursion
- (array-move-to-cell top-row right-column)
- (setq buffer-column (current-column))
- (array-end-of-field t)
- (point))))
- (this-row top-row))
- (while (/= this-row bottom-row)
- (setq this-row (1+ this-row))
- (array-move-to-cell this-row left-column)
- (let ((inhibit-quit t))
- (delete-region
- (point)
- (save-excursion
- (array-move-to-cell this-row right-column)
- (setq buffer-column (current-column))
- (array-end-of-field t)
- (point)))
- (insert copy-string)))))
- (message "Working...done")
- (array-goto-cell p-row p-column)))
-
-
-
-;;; Reconfiguration of the array.
-
-(defun array-make-template ()
- "Create the template of an array."
- (interactive)
- ;; If there is a conflict between field-width and init-string, resolve it.
- (let ((check t)
- (len))
- (while check
- (setq init-field (read-input "Initial field value: "))
- (setq len (length init-field))
- (if (/= len field-width)
- (if (y-or-n-p (format "Change field width to %d? " len))
- (progn (setq field-width len)
- (setq check nil)))
- (setq check nil))))
- (goto-char (point-min))
- (message "Working...")
- (let ((this-row 1))
- ;; Loop through the rows.
- (while (<= this-row max-row)
- (if rows-numbered
- (insert (format "%d:\n" this-row)))
- (let ((this-column 1))
- ;; Loop through the columns.
- (while (<= this-column max-column)
- (insert init-field)
- (if (and (zerop (% this-column columns-per-line))
- (/= this-column max-column))
- (newline))
- (setq this-column (1+ this-column))))
- (setq this-row (1+ this-row))
- (newline)))
- (message "Working...done")
- (array-goto-cell 1 1))
-
-(defun array-reconfigure-rows (new-columns-per-line new-rows-numbered)
- "Reconfigure the state of `rows-numbered' and `columns-per-line'.
-NEW-COLUMNS-PER-LINE is the desired value of `columns-per-line' and
-NEW-ROWS-NUMBERED (a character, either ?y or ?n) is the desired value
-of rows-numbered."
- (interactive "nColumns per line: \ncRows numbered? (y or n) ")
- ;; Check on new-columns-per-line
- (let ((check t))
- (while check
- (if (and (>= new-columns-per-line 1)
- (<= new-columns-per-line max-column))
- (setq check nil)
- (setq new-columns-per-line
- (string-to-int
- (read-input
- (format "Columns per line (1 - %d): " max-column)))))))
- ;; Check on new-rows-numbered. It has to be done this way
- ;; because interactive does not have y-or-n-p.
- (cond
- ((eq new-rows-numbered ?y)
- (setq new-rows-numbered t))
- ((eq new-rows-numbered ?n)
- (setq new-rows-numbered nil))
- (t
- (setq new-rows-numbered (y-or-n-p "Rows numbered? "))))
- (message "Working...")
- (array-update-buffer-position)
- (let* ((main-buffer (buffer-name (current-buffer)))
- (temp-buffer (make-temp-name "Array"))
- (temp-max-row max-row)
- (temp-max-column max-column)
- (old-rows-numbered rows-numbered)
- (old-columns-per-line columns-per-line)
- (old-lines-per-row lines-per-row)
- (old-field-width field-width)
- (old-line-length line-length)
- (this-row 1))
- (array-update-array-position)
- ;; Do the cutting in a temporary buffer.
- (copy-to-buffer temp-buffer (point-min) (point-max))
- (set-buffer temp-buffer)
- (goto-char (point-min))
- (while (<= this-row temp-max-row)
- ;; Deal with row number.
- (cond
- ((or (and old-rows-numbered new-rows-numbered)
- (and (not old-rows-numbered) (not new-rows-numbered)))
- ;; Nothing is changed.
- ())
- ((and old-rows-numbered (not new-rows-numbered))
- ;; Delete the row number.
- (kill-line 1))
- (t
- ;; Add the row number.
- (insert-string (format "%d:\n" this-row))))
- ;; Deal with the array columns in this row.
- (cond
- ((= old-columns-per-line new-columns-per-line)
- ;; Nothing is changed. Go to the next row.
- (forward-line (- old-lines-per-row (if old-rows-numbered 1 0))))
- (t
- ;; First expand the row. Then cut it up into new pieces.
- (let ((newlines-to-be-removed
- (floor (1- temp-max-column) old-columns-per-line))
- (newlines-removed 0)
- (newlines-to-be-added
- (floor (1- temp-max-column) new-columns-per-line))
- (newlines-added 0))
- (while (< newlines-removed newlines-to-be-removed)
- (move-to-column-untabify
- (* (1+ newlines-removed) old-line-length))
- (kill-line 1)
- (setq newlines-removed (1+ newlines-removed)))
- (beginning-of-line)
- (while (< newlines-added newlines-to-be-added)
- (move-to-column-untabify (* old-field-width new-columns-per-line))
- (newline)
- (setq newlines-added (1+ newlines-added)))
- (forward-line 1))))
- (setq this-row (1+ this-row)))
- (let ((inhibit-quit t))
- (set-buffer main-buffer)
- (erase-buffer)
- (insert-buffer temp-buffer)
- ;; Update local variables.
- (setq columns-per-line new-columns-per-line)
- (setq rows-numbered new-rows-numbered)
- (setq line-length (* old-field-width new-columns-per-line))
- (setq lines-per-row
- (+ (ceiling temp-max-column new-columns-per-line)
- (if new-rows-numbered 1 0)))
- (array-goto-cell (or array-row 1) (or array-column 1)))
- (kill-buffer temp-buffer))
- (message "Working...done"))
-
-(defun array-expand-rows ()
- "Expand the rows so each fits on one line and remove row numbers."
- (interactive)
- (array-reconfigure-rows max-column ?n))
-
-
-
-;;; Utilities.
-
-(defun limit-index (index limit)
- (cond ((< index 1) 1)
- ((> index limit) limit)
- (t index)))
-
-(defun abs (int)
- "Return the absolute value of INT."
- (if (< int 0) (- int) int))
-
-
-(defun floor (int1 int2)
- "Returns the floor of INT1 divided by INT2.
-INT1 may be negative. INT2 must be positive."
- (if (< int1 0)
- (- (ceiling (- int1) int2))
- (/ int1 int2)))
-
-(defun ceiling (int1 int2)
- "Returns the ceiling of INT1 divided by INT2.
-Assumes that both arguments are nonnegative."
- (+ (/ int1 int2)
- (if (zerop (mod int1 int2))
- 0
- 1)))
-
-(defun xor (pred1 pred2)
- "Returns the logical exclusive or of predicates PRED1 and PRED2."
- (and (or pred1 pred2)
- (not (and pred1 pred2))))
-
-(defun current-line ()
- "Return the current buffer line at point. The first line is 0."
- (save-excursion
- (beginning-of-line)
- (count-lines (point-min) (point))))
-
-(defun move-to-column-untabify (column)
- "Move to COLUMN on the current line, untabifying if necessary.
-Return COLUMN."
- (or (and (= column (move-to-column column))
- column)
- ;; There is a tab in the way.
- (if respect-tabs
- (error "There is a TAB character in the way.")
- (progn
- (untabify-backward)
- (move-to-column column)))))
-
-(defun untabify-backward ()
- "Untabify the preceding tab."
- (save-excursion
- (let ((start (point)))
- (backward-char 1)
- (untabify (point) start))))
-
-
-
-;;; Array mode.
-
-(defvar array-mode-map nil
- "Keymap used in array mode.")
-
-(if array-mode-map
- ()
- (setq array-mode-map (make-keymap))
- ;; Bind keys.
- (define-key array-mode-map "\M-ad" 'array-display-local-variables)
- (define-key array-mode-map "\M-am" 'array-make-template)
- (define-key array-mode-map "\M-ae" 'array-expand-rows)
- (define-key array-mode-map "\M-ar" 'array-reconfigure-rows)
- (define-key array-mode-map "\M-a=" 'array-what-position)
- (define-key array-mode-map "\M-ag" 'array-goto-cell)
- (define-key array-mode-map "\M-af" 'array-fill-rectangle)
- (define-key array-mode-map "\C-n" 'array-next-row)
- (define-key array-mode-map "\C-p" 'array-previous-row)
- (define-key array-mode-map "\C-f" 'array-forward-column)
- (define-key array-mode-map "\C-b" 'array-backward-column)
- (define-key array-mode-map "\M-n" 'array-copy-down)
- (define-key array-mode-map "\M-p" 'array-copy-up)
- (define-key array-mode-map "\M-f" 'array-copy-forward)
- (define-key array-mode-map "\M-b" 'array-copy-backward)
- (define-key array-mode-map "\M-\C-n" 'array-copy-row-down)
- (define-key array-mode-map "\M-\C-p" 'array-copy-row-up)
- (define-key array-mode-map "\M-\C-f" 'array-copy-column-forward)
- (define-key array-mode-map "\M-\C-b" 'array-copy-column-backward))
-
-(put 'array-mode 'mode-class 'special)
-
-(defun array-mode ()
- "Major mode for editing arrays.
-
- Array mode is a specialized mode for editing arrays. An array is
-considered to be a two-dimensional set of strings. The strings are
-NOT recognized as integers or real numbers.
-
- The array MUST reside at the top of the buffer.
-
- TABs are not respected, and may be converted into spaces at any time.
-Setting the variable 'respect-tabs to non-nil will prevent TAB conversion,
-but will cause many functions to give errors if they encounter one.
-
- Upon entering array mode, you will be prompted for the values of
-several variables. Others will be calculated based on the values you
-supply. These variables are all local the the buffer. Other buffer
-in array mode may have different values assigned to the variables.
-The variables are:
-
-Variables you assign:
- max-row: The number of rows in the array.
- max-column: The number of columns in the array.
- columns-per-line: The number of columns in the array per line of buffer.
- field-width: The width of each field, in characters.
- rows-numbered: A logical variable describing whether to ignore
- row numbers in the buffer.
-
-Variables which are calculated:
- line-length: The number of characters in a buffer line.
- lines-per-row: The number of buffer lines used to display each row.
-
- The following commands are available (an asterisk indicates it may
-take a numeric prefix argument):
-
- * \\<array-mode-map>\\[array-forward-column] Move forward one column.
- * \\[array-backward-column] Move backward one column.
- * \\[array-next-row] Move down one row.
- * \\[array-previous-row] Move up one row.
-
- * \\[array-copy-forward] Copy the current field into the column to the right.
- * \\[array-copy-backward] Copy the current field into the column to the left.
- * \\[array-copy-down] Copy the current field into the row below.
- * \\[array-copy-up] Copy the current field into the row above.
-
- * \\[array-copy-column-forward] Copy the current column into the column to the right.
- * \\[array-copy-column-backward] Copy the current column into the column to the left.
- * \\[array-copy-row-down] Copy the current row into the row below.
- * \\[array-copy-row-up] Copy the current row into the row above.
-
- \\[array-fill-rectangle] Copy the field at mark into every cell with row and column
- between that of point and mark.
-
- \\[array-what-position] Display the current array row and column.
- \\[array-goto-cell] Go to a particular array cell.
-
- \\[array-make-template] Make a template for a new array.
- \\[array-reconfigure-rows] Reconfigure the array.
- \\[array-expand-rows] Expand the array (remove row numbers and
- newlines inside rows)
-
- \\[array-display-local-variables] Display the current values of local variables.
-
-Entering array mode calls the function `array-mode-hook'."
-
- (interactive)
- ;; Number of rows in the array.
- (make-local-variable 'max-row)
- ;; Number of columns in the array.
- (make-local-variable 'max-column)
- ;; Number of array columns per line.
- (make-local-variable 'columns-per-line)
- ;; Width of a field in the array.
- (make-local-variable 'field-width)
- ;; Are rows numbered in the buffer?
- (make-local-variable 'rows-numbered)
- ;; Length of a line in the array.
- (make-local-variable 'line-length)
- ;; Number of lines per array row.
- (make-local-variable 'lines-per-row)
- ;; Current line number of point in the buffer.
- (make-local-variable 'buffer-line)
- ;; Current column number of point in the buffer.
- (make-local-variable 'buffer-column)
- ;; Current array row location of point.
- (make-local-variable 'array-row)
- ;; Current array column location of point.
- (make-local-variable 'array-column)
- ;; Current field string being copied.
- (make-local-variable 'copy-string)
- ;; Should TAB conversion be prevented?
- (make-local-variable 'respect-tabs)
- (setq respect-tabs nil)
- (array-init-local-variables)
- (setq major-mode 'array-mode)
- (setq mode-name "Array")
- ;; Update mode-line.
- (progn (save-excursion (set-buffer (other-buffer)))
- (set-buffer-modified-p (buffer-modified-p))
- (sit-for 0))
- (make-variable-buffer-local 'truncate-lines)
- (setq truncate-lines t)
- (setq overwrite-mode t)
- (use-local-map array-mode-map)
- (run-hooks 'array-mode-hook))
-
-
-
-;;; Initialization functions. These are not interactive.
-
-(defun array-init-local-variables ()
- "Initialize the variables associated with the
-array in this buffer."
- (array-init-max-row)
- (array-init-max-column)
- (array-init-columns-per-line)
- (array-init-field-width)
- (array-init-rows-numbered)
- (array-init-line-length)
- (array-init-lines-per-row)
- (message ""))
-
-(defun array-init-max-row (&optional arg)
- "Initialize the value of max-row."
- (setq max-row
- (or arg (string-to-int (read-input "Number of array rows: ")))))
-
-(defun array-init-max-column (&optional arg)
- "Initialize the value of max-column."
- (setq max-column
- (or arg (string-to-int (read-input "Number of array columns: ")))))
-
-(defun array-init-columns-per-line (&optional arg)
- "Initialize the value of columns-per-line."
- (setq columns-per-line
- (or arg (string-to-int (read-input "Array columns per line: ")))))
-
-(defun array-init-field-width (&optional arg)
- "Initialize the value of field-width."
- (setq field-width
- (or arg (string-to-int (read-input "Field width: ")))))
-
-(defun array-init-rows-numbered (&optional arg)
- "Initialize the value of rows-numbered."
- (setq rows-numbered
- (or arg (y-or-n-p "Rows numbered? "))))
-
-(defun array-init-line-length (&optional arg)
- "Initialize the value of line-length."
- (setq line-length
- (or arg
- (* field-width columns-per-line))))
-
-(defun array-init-lines-per-row (&optional arg)
- "Initialize the value of lines-per-row."
- (setq lines-per-row
- (or arg
- (+ (ceiling max-column columns-per-line)
- (if rows-numbered 1 0)))))
diff --git a/lisp/autoinsert.el b/lisp/autoinsert.el
index 61736c9f68b..a185cc077ae 100644
--- a/lisp/autoinsert.el
+++ b/lisp/autoinsert.el
@@ -53,14 +53,14 @@
("\\.h$" . "h-insert.c")
("[Mm]akefile" . "makefile.inc")
("\\.bib$" . "tex-insert.tex"))
- "A list specifying text to insert by default into a new file.
+ "Alist specifying text to insert by default into a new file.
Elements look like (REGEXP . FILENAME); if the new file's name
matches REGEXP, then the file FILENAME is inserted into the buffer.
Only the first matching element is effective.")
;;; Establish a default value for auto-insert-directory
(defvar auto-insert-directory "~/insert/"
- "*Directory from which auto-inserted files are taken.")
+ "Directory from which auto-inserted files are taken.")
(defun insert-auto-insert-files ()
"Insert default contents into a new file.
@@ -80,9 +80,7 @@ Matches the visited file name against the elements of `auto-insert-alist'."
(if insert-file
(let ((file (concat auto-insert-directory insert-file)))
(if (file-readable-p file)
- (progn
- (insert-file-contents file)
- (set-buffer-modified-p nil))
+ (insert-file-contents file)
(message "Auto-insert: file %s not found" file)
(sleep-for 1))))))
diff --git a/lisp/emacs-lisp/backquote.el b/lisp/backquote.el
index 715a794d5fe..fa979a54079 100644
--- a/lisp/emacs-lisp/backquote.el
+++ b/lisp/backquote.el
@@ -91,43 +91,8 @@ a list-value atom"
;;; This is the interface
(defmacro ` (form)
- "(` FORM) is a macro that expands to code to construct FORM.
-Note that this is very slow in interpreted code, but fast if you compile.
-FORM is one or more nested lists, which are `almost quoted':
-They are copied recursively, with non-lists used unchanged in the copy.
- (` a b) == (list 'a 'b) constructs a new list with two elements, `a' and `b'.
- (` a (b c)) == (list 'a (list 'b 'c)) constructs two nested new lists.
-
-However, certain special lists are not copied. They specify substitution.
-Lists that look like (, EXP) are evaluated and the result is substituted.
- (` a (, (+ x 5))) == (list 'a (+ x 5))
-
-Elements of the form (,@ EXP) are evaluated and then all the elements
-of the result are substituted. This result must be a list; it may
-be `nil'.
-
-As an example, a simple macro `push' could be written:
- (defmacro push (v l)
- (` (setq (, l) (cons (,@ (list v l))))))
-or as
- (defmacro push (v l)
- (` (setq (, l) (cons (, v) (, l)))))
-
-LIMITATIONS: \"dotted lists\" are not allowed in FORM.
-The ultimate cdr of each list scanned by ` must be `nil'.
-\(This does not apply to constants inside expressions to be substituted.)
-
-Substitution elements are not allowed as the cdr
-of a cons cell. For example, (` (A . (, B))) does not work.
-Instead, write (` (A (,@ B))).
-
-You cannot construct vectors, only lists. Vectors are treated as
-constants.
-
-BEWARE BEWARE BEWARE
-Inclusion of (,ATOM) rather than (, ATOM)
-or of (,@ATOM) rather than (,@ ATOM)
-will result in errors that will show up very late."
+ "(` FORM) Expands to a form that will generate FORM.
+FORM is `almost quoted' -- see backquote.el for a description."
(bq-make-maker form))
;;; We develop the method for building the desired list from
@@ -190,8 +155,8 @@ See backquote.el for details"
;;; This maintains the invariant that (cons state tailmaker) is the
;;; maker for the elements of the tail we've eaten so far.
(defun bq-iterative-list-builder (form)
- "Called by `bq-make-maker'. Adds a new item form to tailmaker,
-changing state if need be, so tailmaker and state constitute a recipe
+ "Called by bq-make-maker. Adds a new item form to tailmaker,
+changing state if need be, so tailmaker and state constitute a recipie
for making the list so far."
(cond ((atom form)
(funcall (bq-cadr (assq state bq-quotefns)) form))
@@ -321,13 +286,13 @@ for making the list so far."
(rplacd (car tailmaker)
(cons form (bq-cdar tailmaker))))
((= (length tailmaker) 1)
- (setq tailmaker (cons form tailmaker)
- state 'cons))
+ (setq tailmaker (cons form tailmaker))
+ (setq state 'cons))
(t (bq-push (list 'list form) tailmaker))))
(defun bq-evalnil (form)
- (setq tailmaker (list form)
- state 'list))
+ (setq tailmaker (list form))
+ (setq state 'list))
;;; (if (matches (X Y)) ; it must
;;; (progn (setq state 'append)
@@ -335,20 +300,23 @@ for making the list so far."
(defun bq-splicecons (form)
(setq tailmaker
(list form
- (list 'cons (car tailmaker) (bq-cadr tailmaker)))
- state 'append))
+ (list 'cons (car tailmaker) (bq-cadr tailmaker))))
+ (setq state 'append))
(defun bq-splicequote (form)
- (setq tailmaker (list form (list 'quote tailmaker))
- state 'append))
+ (setq tailmaker (list form (list 'quote (list tailmaker))))
+ (setq state 'append))
(defun bq-splicelist (form)
- (setq tailmaker (list form (cons 'list tailmaker))
- state 'append))
+ (setq tailmaker (list form (cons 'list tailmaker)))
+ (setq state 'append))
(defun bq-spliceappend (form)
(bq-push form tailmaker))
(defun bq-splicenil (form)
- (setq state 'append
- tailmaker (list form)))
+ (setq state 'append)
+ (setq tailmaker (list form)))
+
+
+
diff --git a/lisp/backquote.elc b/lisp/backquote.elc
new file mode 100644
index 00000000000..798687f5e9b
--- /dev/null
+++ b/lisp/backquote.elc
Binary files differ
diff --git a/lisp/term/bg-mouse.el b/lisp/bg-mouse.el
index 9b83f5f6c2a..fef1b2d56f2 100644
--- a/lisp/term/bg-mouse.el
+++ b/lisp/bg-mouse.el
@@ -128,8 +128,8 @@ To reinitialize the mouse if the terminal is reset, type ESC : RET"
(yank-pop 1))
(defun bg-yank-or-pop ()
- "Move point to location of BitGraph mouse and yank. If last command
-was a yank, do a yank-pop."
+ "Move point to location of BitGraph mouse and yank or yank-pop.
+Do a yank unless last command was a yank, in which case do a yank-pop."
(interactive "*")
(if (eql last-command 'yank)
(yank-pop 1)
@@ -139,8 +139,8 @@ was a yank, do a yank-pop."
(defconst bg-most-positive-fixnum 8388607)
(defun bg-move-by-percentage ()
- "Go to location in buffer that is the same percentage of the way
-through the buffer as the BitGraph mouse's X position in the window."
+ "Go to location in buffer that is the same percentage of the
+way through the buffer as the BitGraph mouse's X position in the window."
(interactive)
;; check carefully for overflow in intermediate calculations
(goto-char
@@ -179,7 +179,8 @@ of the window"
(defun bg-insert-moused-sexp ()
"Insert a copy of the word (actually sexp) that the mouse is pointing at.
-Sexp is inserted into the buffer at point (where the text cursor is)."
+Sexp is inserted into the buffer at point (where the text cursor is).
+By gildea 7 Feb 89"
(interactive)
(let ((moused-text
(save-excursion
diff --git a/lisp/bibtex.el b/lisp/bibtex.el
new file mode 100644
index 00000000000..6b0e6217cc5
--- /dev/null
+++ b/lisp/bibtex.el
@@ -0,0 +1,426 @@
+;;; Simple BibTeX mode for GNU Emacs
+;;; Bengt Martensson 87-06-28
+;;; changes by Marc Shapiro shapiro@inria.inria.fr 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)
+;;; 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 3-nov-87
+;;; addition for France: DEAthesis
+;;; Skip Montanaro <steinmetz!sprite!montanaro> 7-dec-87, Shapiro 10-dec-87
+;;; before inserting an entry, make sure we are outside of a bib entry
+;;; Marc Shapiro 14-dec-87
+;;; Cosmetic fixes. Fixed small bug in bibtex-move-outside-of-entry.
+
+;;; 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!
+
+;;; 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 vtxxx-keys and DEAthesis. Changed documentation slightly.
+
+(defvar bibtex-mode-syntax-table nil "")
+(defvar bibtex-mode-abbrev-table nil "")
+(define-abbrev-table 'bibtex-mode-abbrev-table ())
+(defvar bibtex-mode-map (make-sparse-keymap) "")
+
+(defun bibtex-mode ()
+ "Major mode for editing bibtex files. Commands:
+\\{bibtex-mode-map}
+
+A command such as \\[bibtex-Book] will outline the fields for a BibTeX
+book entry.
+
+The optional fields are preceded by ""OPT"", thus ignored by BibTeX.
+Use \\[bibtex-remove-opt] to remove ""OPT"" on the current line.
+
+Use \\[bibtex-find-it] to position the dot at the end of the string on the same line.
+Use \\[bibtex-next-position] to move to the next position to fill in. Use \\[kill-current-line]
+to kill the whole line.
+
+M-x bibtex-x-environment binds a mode-specific X menu to control+right
+mouse button.
+M-x bibtex-sun-environment binds a mode-specific Sun menu to right
+mouse button.
+
+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
+ 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 will also have it's own title
+ title
+ The title of the thing being referenced
+ type
+ Type of a Techreport (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)
+ (if (not bibtex-mode-syntax-table)
+ (setq bibtex-mode-syntax-table (copy-syntax-table)))
+ (set-syntax-table bibtex-mode-syntax-table)
+ (modify-syntax-entry ?\$ "$$ ")
+ (modify-syntax-entry ?\% "< ")
+ (modify-syntax-entry ?\f "> ")
+ (modify-syntax-entry ?\n "> ")
+ (modify-syntax-entry ?' "w ")
+ (modify-syntax-entry ?@ "w ")
+ (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]*$")
+
+ (define-key bibtex-mode-map "\t" 'bibtex-find-it)
+ (define-key bibtex-mode-map "\n" 'bibtex-next-position)
+ ;;(define-key bibtex-mode-map "\e[25~" 'bibtex-next-position)
+ (define-key bibtex-mode-map "\C-c\"" 'bibtex-remove-double-quotes)
+ ;;(define-key bibtex-mode-map "\C-c\eOS" 'kill-current-line)
+ (define-key bibtex-mode-map "\C-c\C-k" 'kill-current-line)
+ (define-key bibtex-mode-map "\C-c\C-a" 'bibtex-Article)
+ (define-key bibtex-mode-map "\C-c\C-b" 'bibtex-Book)
+ ;;(define-key bibtex-mode-map "\C-c\C-d" 'bibtex-DEAthesis)
+ (define-key bibtex-mode-map "\C-c\C-c" 'bibtex-InProceedings)
+ (define-key bibtex-mode-map "\C-c\C-i" 'bibtex-InBook)
+ (define-key bibtex-mode-map "\C-ci" 'bibtex-InCollection)
+ (define-key bibtex-mode-map "\C-cI" 'bibtex-InProceedings)
+ (define-key bibtex-mode-map "\C-c\C-m" 'bibtex-Manual)
+ (define-key bibtex-mode-map "\C-cm" 'bibtex-MastersThesis)
+ (define-key bibtex-mode-map "\C-cM" 'bibtex-Misc)
+ (define-key bibtex-mode-map "\C-c\C-o" 'bibtex-remove-opt)
+ (define-key bibtex-mode-map "\C-c\C-p" 'bibtex-PhdThesis)
+ (define-key bibtex-mode-map "\C-cp" 'bibtex-Proceedings)
+ (define-key bibtex-mode-map "\C-c\C-t" 'bibtex-TechReport)
+ (define-key bibtex-mode-map "\C-c\C-s" 'bibtex-string)
+ (define-key bibtex-mode-map "\C-c\C-u" 'bibtex-Unpublished)
+ (define-key bibtex-mode-map "\C-c?" 'describe-mode)
+
+ ; nice alignements
+ (auto-fill-mode 1)
+ (setq left-margin 17)
+
+ (run-hooks 'bibtex-mode-hook))
+
+(defun bibtex-move-outside-of-entry ()
+ "Make sure we are outside of a bib entry"
+ (if (or
+ (= (point) (point-max))
+ (= (point) (point-min))
+ (looking-at "[ \n]*@")
+ )
+ t
+ (progn
+ (backward-paragraph)
+ (forward-paragraph)))
+ (re-search-forward "[ \t\n]*" (point-max) t))
+
+(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 (insert ",\n"))
+ (insert (mapconcat 'bibtex-make-opt-entry optional ",\n"))
+ (up-list -1)
+ (forward-char 1))
+
+(defun bibtex-make-entry (str)
+ (interactive "s")
+ (concat " " str " = \t"""""))
+
+(defun bibtex-make-opt-entry (str)
+ (interactive "s")
+ (concat " OPT" str " = \t"""""))
+
+(defun bibtex-Article ()
+ (interactive)
+ (bibtex-entry "Article" '("author" "title" "journal" "year")
+ '("volume" "number" "pages" "month" "note")))
+
+(defun bibtex-Book ()
+ (interactive)
+ (bibtex-entry "Book" '("author" "title" "publisher" "year")
+ '("editor" "volume" "series" "address"
+ "edition" "month" "note")))
+
+(defun bibtex-Booklet ()
+ (interactive)
+ (bibtex-entry "Booklet" '("title")
+ '("author" "howpublished" "address" "month" "year" "note")))
+
+;;; France: Dipl\^{o}me d'Etudes Approfondies (similar to Master's)
+;(defun bibtex-DEAthesis ()
+; (interactive)
+; (bibtex-entry "DEAthesis" '("author" "title" "school" "year")
+; '("address" "month" "note")))
+
+(defun bibtex-InBook ()
+ (interactive)
+ (bibtex-entry "InBook" '("author" "title" "chapter" "publisher" "year")
+ '("editor" "pages" "volume" "series" "address"
+ "edition" "month" "note")))
+
+(defun bibtex-InCollection ()
+ (interactive)
+ (bibtex-entry "InCollection" '("author" "title" "booktitle"
+ "publisher" "year")
+ '("editor" "chapter" "pages" "address" "month" "note")))
+
+
+(defun bibtex-InProceedings ()
+ (interactive)
+ (bibtex-entry "InProceedings" '("author" "title" "booktitle" "year")
+ '("editor" "pages" "organization" "publisher"
+ "address" "month" "note")))
+
+(defun bibtex-Manual ()
+ (interactive)
+ (bibtex-entry "Manual" '("title")
+ '("author" "organization" "address" "edition" "year"
+ "month" "note")))
+
+(defun bibtex-MastersThesis ()
+ (interactive)
+ (bibtex-entry "MastersThesis" '("author" "title" "school" "year")
+ '("address" "month" "note")))
+
+(defun bibtex-Misc ()
+ (interactive)
+ (bibtex-entry "Misc" '()
+ '("author" "title" "howpublished" "year" "month" "note")))
+
+(defun bibtex-PhdThesis ()
+ (interactive)
+ (bibtex-entry "PhDThesis" '("author" "title" "school" "year")
+ '("address" "month" "note")))
+
+(defun bibtex-Proceedings ()
+ (interactive)
+ (bibtex-entry "Proceedings" '("title" "year")
+ '("editor" "publisher" "organization"
+ "address" "month" "note")))
+(defun bibtex-TechReport ()
+ (interactive)
+ (bibtex-entry "TechReport" '("author" "title" "institution" "year")
+ '("type" "number" "address" "month" "note")))
+
+
+(defun bibtex-Unpublished ()
+ (interactive)
+ (bibtex-entry "Unpublished" '("author" "title" "note")
+ '("year" "month")))
+
+(defun bibtex-string ()
+ (interactive)
+ (bibtex-move-outside-of-entry)
+ (insert "@string{ = """"}\n")
+ (previous-line 1)
+ (forward-char 8))
+
+(defun bibtex-next-position ()
+ "Finds next position to write in."
+ (interactive)
+ (forward-line 1)
+ (bibtex-find-it))
+
+(defun bibtex-find-it ()
+ (interactive)
+ "Find position on current line (if possible) to add entry text."
+ (beginning-of-line)
+ (let ((beg (point)))
+ (end-of-line)
+ (search-backward "," beg t)
+ (backward-char 1)
+ (if (looking-at """")
+ t
+ (forward-char 1))
+ ))
+
+(defun bibtex-remove-opt ()
+ "Removes the 'OPT' starting optional arguments."
+ (interactive)
+ (beginning-of-line)
+ (forward-char 2)
+ (if (looking-at "OPT")
+ (delete-char 3))
+ (bibtex-find-it))
+
+(defun kill-current-line ()
+ "Kills the current line."
+ (interactive)
+ (beginning-of-line)
+ (kill-line 1))
+
+(defun bibtex-remove-double-quotes ()
+ "Removes """" around string."
+ (interactive)
+ (bibtex-find-it)
+ (let
+ ((here (point))
+ (eol (progn (end-of-line) (point))))
+ (beginning-of-line)
+ (if (search-forward """" eol t)
+ (progn
+ (delete-char -1)
+ (if (search-forward """" eol t)
+ (delete-char -1)
+ ))
+ (goto-char here))
+ )
+ )
+
+
+;;; X window menus for bibtex mode
+
+(defun bibtex-x-help (arg)
+ "Mouse commands for BibTeX mode"
+
+ (let ((selection
+ (x-popup-menu
+ arg
+ '("BibTeX commands"
+ ("Document types"
+ ("article in Conference Proceedings" . bibtex-InProceedings)
+ ("article in journal" . bibtex-Article)
+ ("Book" . bibtex-Book)
+ ("Booklet" . bibtex-Booklet)
+ ("Master's Thesis" . bibtex-MastersThesis)
+ ;;("DEA Thesis" . bibtex-DEAthesis)
+ ("PhD. Thesis" . bibtex-PhdThesis)
+ ("Technical Report" . bibtex-TechReport)
+ ("technical Manual" . bibtex-Manual)
+ ("Conference Proceedings" . bibtex-Proceedings)
+ ("in a Book" . bibtex-InBook)
+ ("in a Collection" . bibtex-InCollection)
+ ("miscellaneous" . bibtex-Misc)
+ ("unpublished" . bibtex-Unpublished)
+ )
+ ("others"
+ ("next field" . bibtex-next-position)
+ ("to end of field" . bibtex-find-it)
+ ("remove OPT" . bibtex-remove-opt)
+ ("remove quotes" . bibtex-remove-double-quotes)
+ ("remove this line" . kill-current-line)
+ ("describe BibTeX mode" . describe-mode)
+ ("string" . bibtex-string))))))
+ (and selection (call-interactively selection))))
+
+(defun bibtex-x-environment ()
+ "Set up X menus for BibTeX mode. Call it as bibtex-mode-hook, or interactively"
+ (interactive)
+ (require 'x-mouse)
+ (define-key mouse-map x-button-c-right 'bibtex-x-help)
+ )
+
+;; Please don't send anything to bug-gnu-emacs about these Sunwindows functions
+;; since we aren't interested. See etc/SUN-SUPPORT for the reasons why
+;; we consider this nothing but a distraction from our work.
+
+(defmenu bibtex-sun-entry-menu
+ ("Article In Conf. Proc."
+ (lambda () (eval-in-window *menu-window* (bibtex-InProceedings))))
+ ("Article In Journal"
+ (lambda () (eval-in-window *menu-window* (bibtex-Article))))
+ ("Book"
+ (lambda () (eval-in-window *menu-window* (bibtex-Book))))
+ ("Booklet"
+ (lambda () (eval-in-window *menu-window* (bibtex-Booklet))))
+ ("Master's Thesis"
+ (lambda () (eval-in-window *menu-window* (bibtex-MastersThesis))))
+ ;;("DEA Thesis" bibtex-DEAthesis)
+ ("PhD. Thesis"
+ (lambda () (eval-in-window *menu-window* (bibtex-PhdThesis))))
+ ("Technical Report"
+ (lambda () (eval-in-window *menu-window* (bibtex-TechReport))))
+ ("Technical Manual"
+ (lambda () (eval-in-window *menu-window* (bibtex-Manual))))
+ ("Conference Proceedings"
+ (lambda () (eval-in-window *menu-window* (bibtex-Proceedings))))
+ ("In A Book"
+ (lambda () (eval-in-window *menu-window* (bibtex-InBook))))
+ ("In A Collection"
+ (lambda () (eval-in-window *menu-window* (bibtex-InCollection))))
+ ("Miscellaneous"
+ (lambda () (eval-in-window *menu-window* (bibtex-Misc))))
+ ("Unpublished"
+ (lambda () (eval-in-window *menu-window* (bibtex-Unpublished)))))
+
+(defmenu bibtex-sun-menu
+ ("BibTeX menu")
+ ("add entry" . bibtex-sun-entry-menu)
+ ("add string"
+ (lambda () (eval-in-window *menu-window* (bibtex-string))))
+ ;("next field" bibtex-next-position)
+ ;("to end of field" bibtex-find-it)
+; ("remove OPT"
+; (lambda () (eval-in-window *menu-window* (bibtex-remove-opt))))
+; ("remove quotes"
+; (lambda () (eval-in-window *menu-window* (bibtex-remove-double-quotes))))
+; ("remove this line"
+; (lambda () (eval-in-window *menu-window* (kill-current-line))))
+ ("describe BibTeX mode"
+ (lambda () (eval-in-window *menu-window* (describe-mode))))
+ ("Main Emacs menu" . emacs-menu))
+
+(defun bibtex-sun-menu-eval (window x y)
+ "Pop-up menu of BibTeX commands."
+ (sun-menu-evaluate window (1+ x) (1- y) 'bibtex-sun-menu))
+
+(defun bibtex-sun-environment ()
+ "Set up sun menus for BibTeX mode. Call it as bibtex-mode-hook, or interactively"
+ (interactive)
+ (local-set-mouse '(text right) 'bibtex-sun-menu-eval))
+
diff --git a/lisp/bibtex.elc b/lisp/bibtex.elc
new file mode 100644
index 00000000000..7b21ec06cd6
--- /dev/null
+++ b/lisp/bibtex.elc
Binary files differ
diff --git a/lisp/blackbox.el b/lisp/blackbox.el
new file mode 100644
index 00000000000..938840fe205
--- /dev/null
+++ b/lisp/blackbox.el
@@ -0,0 +1,229 @@
+; Blackbox game in Emacs Lisp
+
+; by F. Thomas May
+; uw-nsr!uw-warp!tom@beaver.cs.washington.edu
+
+(defvar blackbox-mode-map nil "")
+
+(if blackbox-mode-map
+ ()
+ (setq blackbox-mode-map (make-keymap))
+ (suppress-keymap blackbox-mode-map t)
+ (define-key blackbox-mode-map "\C-f" 'bb-right)
+ (define-key blackbox-mode-map "\C-b" 'bb-left)
+ (define-key blackbox-mode-map "\C-p" 'bb-up)
+ (define-key blackbox-mode-map "\C-n" 'bb-down)
+ (define-key blackbox-mode-map "\C-e" 'bb-eol)
+ (define-key blackbox-mode-map "\C-a" 'bb-bol)
+ (define-key blackbox-mode-map " " 'bb-romp)
+ (define-key blackbox-mode-map "\C-m" 'bb-done))
+
+
+;; Blackbox mode is suitable only for specially formatted data.
+(put 'blackbox-mode 'mode-class 'special)
+
+(defun blackbox-mode ()
+ "Major mode for playing blackbox.
+
+SPC -- send in a ray from point, or toggle a ball
+RET -- end game and get score
+
+Precisely,\\{blackbox-mode-map}"
+ (interactive)
+ (kill-all-local-variables)
+ (use-local-map blackbox-mode-map)
+ (setq truncate-lines t)
+ (setq major-mode 'blackbox-mode)
+ (setq mode-name "Blackbox"))
+
+(defun blackbox (num)
+ "Play blackbox. Arg is number of balls."
+ (interactive "P")
+ (switch-to-buffer "*Blackbox*")
+ (blackbox-mode)
+ (setq buffer-read-only t)
+ (buffer-flush-undo (current-buffer))
+ (setq bb-board (bb-init-board (or num 4)))
+ (setq bb-balls-placed nil)
+ (setq bb-x -1)
+ (setq bb-y -1)
+ (setq bb-score 0)
+ (setq bb-detour-count 0)
+ (bb-insert-board)
+ (bb-goto (cons bb-x bb-y)))
+
+(defun bb-init-board (num-balls)
+ (random t)
+ (let (board pos)
+ (while (>= (setq num-balls (1- num-balls)) 0)
+ (while
+ (progn
+ (setq pos (cons (logand (random) 7) (logand (random) 7)))
+ (bb-member pos board)))
+ (setq board (cons pos board)))
+ board))
+
+(defun bb-insert-board ()
+ (let (i (buffer-read-only nil))
+ (erase-buffer)
+ (insert " \n")
+ (setq i 8)
+ (while (>= (setq i (1- i)) 0)
+ (insert " - - - - - - - - \n"))
+ (insert " \n")))
+
+(defun bb-right ()
+ (interactive)
+ (if (= bb-x 8)
+ ()
+ (forward-char 2)
+ (setq bb-x (1+ bb-x))))
+
+(defun bb-left ()
+ (interactive)
+ (if (= bb-x -1)
+ ()
+ (backward-char 2)
+ (setq bb-x (1- bb-x))))
+
+(defun bb-up ()
+ (interactive)
+ (if (= bb-y -1)
+ ()
+ (previous-line 1)
+ (setq bb-y (1- bb-y))))
+
+(defun bb-down ()
+ (interactive)
+ (if (= bb-y 8)
+ ()
+ (next-line 1)
+ (setq bb-y (1+ bb-y))))
+
+(defun bb-eol ()
+ (interactive)
+ (setq bb-x 8)
+ (bb-goto (cons bb-x bb-y)))
+
+(defun bb-bol ()
+ (interactive)
+ (setq bb-x -1)
+ (bb-goto (cons bb-x bb-y)))
+
+(defun bb-romp ()
+ (interactive)
+ (cond
+ ((and
+ (or (= bb-x -1) (= bb-x 8))
+ (or (= bb-y -1) (= bb-y 8))))
+ ((bb-outside-box bb-x bb-y)
+ (bb-trace-ray bb-x bb-y))
+ (t
+ (bb-place-ball bb-x bb-y))))
+
+(defun bb-place-ball (x y)
+ (let ((coord (cons x y)))
+ (cond
+ ((bb-member coord bb-balls-placed)
+ (setq bb-balls-placed (bb-delete coord bb-balls-placed))
+ (bb-update-board "-"))
+ (t
+ (setq bb-balls-placed (cons coord bb-balls-placed))
+ (bb-update-board "O")))))
+
+(defun bb-trace-ray (x y)
+ (let ((result (bb-trace-ray-2
+ t
+ x
+ (cond
+ ((= x -1) 1)
+ ((= x 8) -1)
+ (t 0))
+ y
+ (cond
+ ((= y -1) 1)
+ ((= y 8) -1)
+ (t 0)))))
+ (cond
+ ((eq result 'hit)
+ (bb-update-board "H")
+ (setq bb-score (1+ bb-score)))
+ ((equal result (cons x y))
+ (bb-update-board "R")
+ (setq bb-score (1+ bb-score)))
+ (t
+ (setq bb-detour-count (1+ bb-detour-count))
+ (bb-update-board (format "%d" bb-detour-count))
+ (save-excursion
+ (bb-goto result)
+ (bb-update-board (format "%d" bb-detour-count)))
+ (setq bb-score (+ bb-score 2))))))
+
+(defun bb-trace-ray-2 (first x dx y dy)
+ (cond
+ ((and (not first)
+ (bb-outside-box x y))
+ (cons x y))
+ ((bb-member (cons (+ x dx) (+ y dy)) bb-board)
+ 'hit)
+ ((bb-member (cons (+ x dx dy) (+ y dy dx)) bb-board)
+ (bb-trace-ray-2 nil x (- dy) y (- dx)))
+ ((bb-member (cons (+ x dx (- dy)) (+ y dy (- dx))) bb-board)
+ (bb-trace-ray-2 nil x dy y dx))
+ (t
+ (bb-trace-ray-2 nil (+ x dx) dx (+ y dy) dy))))
+
+(defun bb-done ()
+ (interactive)
+ (let (bogus-balls)
+ (if (not (= (length bb-balls-placed) (length bb-board)))
+ (message "Spud! You have only %d balls in the box."
+ (length bb-balls-placed))
+ (setq bogus-balls (bb-show-bogus-balls bb-balls-placed bb-board))
+ (if (= bogus-balls 0)
+ (message "Right! Your score is %d." bb-score)
+ (setq bb-score (+ bb-score (* 5 bogus-balls)))
+ (message "Veg! You missed %d balls. Your score is %d."
+ bogus-balls bb-score))
+ (bb-goto '(-1 . -1)))))
+
+(defun bb-show-bogus-balls (balls-placed board)
+ (bb-show-bogus-balls-2 balls-placed board "x")
+ (bb-show-bogus-balls-2 board balls-placed "o"))
+
+(defun bb-show-bogus-balls-2 (list-1 list-2 c)
+ (cond
+ ((null list-1)
+ 0)
+ ((bb-member (car list-1) list-2)
+ (bb-show-bogus-balls-2 (cdr list-1) list-2 c))
+ (t
+ (bb-goto (car list-1))
+ (bb-update-board c)
+ (1+ (bb-show-bogus-balls-2 (cdr list-1) list-2 c)))))
+
+(defun bb-outside-box (x y)
+ (or (= x -1) (= x 8) (= y -1) (= y 8)))
+
+(defun bb-goto (pos)
+ (goto-char (+ (* (car pos) 2) (* (cdr pos) 22) 26)))
+
+(defun bb-update-board (c)
+ (let ((buffer-read-only nil))
+ (backward-char (1- (length c)))
+ (delete-char (length c))
+ (insert c)
+ (backward-char 1)))
+
+(defun bb-member (elt list)
+ "Returns non-nil if ELT is an element of LIST. Comparison done with equal."
+ (eval (cons 'or (mapcar (function (lambda (x) (equal x elt))) list))))
+
+(defun bb-delete (item list)
+ "Deletes ITEM from LIST and returns a copy."
+ (cond
+ ((equal item (car list)) (cdr list))
+ (t (cons (car list) (bb-delete item (cdr list))))))
+
+
+
diff --git a/lisp/blackbox.elc b/lisp/blackbox.elc
new file mode 100644
index 00000000000..c2daf947c26
--- /dev/null
+++ b/lisp/blackbox.elc
Binary files differ
diff --git a/lisp/buff-menu.el b/lisp/buff-menu.el
index 77923774da7..101555c9db0 100644
--- a/lisp/buff-menu.el
+++ b/lisp/buff-menu.el
@@ -1,5 +1,5 @@
;; Buffer menu main function and support functions.
-;; Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1986, 1987, 1990 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
@@ -39,14 +39,11 @@
(define-key Buffer-menu-mode-map "\C-k" 'Buffer-menu-delete)
(define-key Buffer-menu-mode-map "x" 'Buffer-menu-execute)
(define-key Buffer-menu-mode-map " " 'next-line)
- (define-key Buffer-menu-mode-map "n" 'next-line)
- (define-key Buffer-menu-mode-map "p" 'previous-line)
(define-key Buffer-menu-mode-map "\177" 'Buffer-menu-backup-unmark)
(define-key Buffer-menu-mode-map "~" 'Buffer-menu-not-modified)
(define-key Buffer-menu-mode-map "?" 'describe-mode)
(define-key Buffer-menu-mode-map "u" 'Buffer-menu-unmark)
- (define-key Buffer-menu-mode-map "m" 'Buffer-menu-mark)
- (define-key Buffer-menu-mode-map "t" 'Buffer-menu-visit-tags-table))
+ (define-key Buffer-menu-mode-map "m" 'Buffer-menu-mark))
;; Buffer Menu mode is suitable only for specially formatted data.
(put 'Buffer-menu-mode 'mode-class 'special)
@@ -55,24 +52,24 @@
"Major mode for editing a list of buffers.
Each line describes one of the buffers in Emacs.
Letters do not insert themselves; instead, they are commands.
-\\<Buffer-menu-mode-map>
-\\[Buffer-menu-mark] -- mark buffer to be displayed.
-\\[Buffer-menu-select] -- select buffer of line point is on.
+m -- mark buffer to be displayed.
+q -- select buffer of line point is on.
Also show buffers marked with m in other windows.
-\\[Buffer-menu-1-window] -- select that buffer in full-screen window.
-\\[Buffer-menu-2-window] -- select that buffer in one window,
+1 -- select that buffer in full-screen window.
+2 -- select that buffer in one window,
together with buffer selected before this one in another window.
-\\[Buffer-menu-this-window] -- select that buffer in place of the buffer menu buffer.
-\\[Buffer-menu-other-window] -- select that buffer in another window,
+f -- select that buffer in place of the buffer menu buffer.
+o -- select that buffer in another window,
so the buffer menu buffer remains visible in its window.
-\\[Buffer-menu-visit-tags-table] -- visit-tags-table this buffer.
-\\[Buffer-menu-not-modified] -- clear modified-flag on that buffer.
-\\[Buffer-menu-save] -- mark that buffer to be saved, and move down.
-\\[Buffer-menu-delete] -- mark that buffer to be deleted, and move down.
-\\[Buffer-menu-delete-backwards] -- mark that buffer to be deleted, and move up.
-\\[Buffer-menu-execute] -- delete or save marked buffers.
-\\[Buffer-menu-unmark] -- remove all kinds of marks from current line.
-\\[Buffer-menu-backup-unmark] -- back up a line and remove marks."
+~ -- clear modified-flag on that buffer.
+s -- mark that buffer to be saved, and move down.
+d or k -- mark that buffer to be deleted, and move down.
+C-d -- mark that buffer to be deleted, and move up.
+x -- delete or save marked buffers.
+u -- remove all kinds of marks from current line.
+Delete -- back up a line and remove marks.
+
+Precisely,\\{Buffer-menu-mode-map}"
(kill-all-local-variables)
(use-local-map Buffer-menu-mode-map)
(setq truncate-lines t)
@@ -112,7 +109,7 @@ Type q immediately to make the buffer menu go away."
"Commands: d, s, x; 1, 2, m, u, q; delete; ~; ? for help."))
(defun Buffer-menu-mark ()
- "Mark buffer on this line for being displayed by \\<Buffer-menu-mode-map>\\[Buffer-menu-select] command."
+ "Mark buffer on this line for being displayed by \\[Buffer-menu-select] command."
(interactive)
(beginning-of-line)
(if (looking-at " [-M]")
@@ -144,7 +141,7 @@ Type q immediately to make the buffer menu go away."
(forward-line -1))
(defun Buffer-menu-delete ()
- "Mark buffer on this line to be deleted by \\<Buffer-menu-mode-map>\\[Buffer-menu-execute] command."
+ "Mark buffer on this line to be deleted by \\[Buffer-menu-execute] command."
(interactive)
(beginning-of-line)
(if (looking-at " [-M]") ;header lines
@@ -155,7 +152,7 @@ Type q immediately to make the buffer menu go away."
(forward-line 1))))
(defun Buffer-menu-delete-backwards ()
- "Mark buffer on this line to be deleted by \\<Buffer-menu-mode-map>\\[Buffer-menu-execute] command
+ "Mark buffer on this line to be deleted by \\[Buffer-menu-execute] command
and then move up one line"
(interactive)
(Buffer-menu-delete)
@@ -163,7 +160,7 @@ and then move up one line"
(if (looking-at " [-M]") (forward-line 1)))
(defun Buffer-menu-save ()
- "Mark buffer on this line to be saved by \\<Buffer-menu-mode-map>\\[Buffer-menu-execute] command."
+ "Mark buffer on this line to be saved by \\[Buffer-menu-execute] command."
(interactive)
(beginning-of-line)
(forward-char 1)
@@ -189,7 +186,7 @@ and then move up one line"
(insert ? )))))
(defun Buffer-menu-execute ()
- "Save and/or delete buffers marked with \\<Buffer-menu-mode-map>\\[Buffer-menu-save] or \\<Buffer-menu-mode-map>\\[Buffer-menu-delete] commands."
+ "Save and/or delete buffers marked with \\[Buffer-menu-save] or \\[Buffer-menu-delete] commands."
(interactive)
(save-excursion
(goto-char (point-min))
@@ -221,8 +218,8 @@ and then move up one line"
(forward-char -1))))))
(defun Buffer-menu-select ()
- "Select this line's buffer; also display buffers marked with `>'.
-You can mark buffers with the \\<Buffer-menu-mode-map>\\[Buffer-menu-mark] command."
+ "Select this line's buffer; also display buffers marked with \">\".
+You can mark buffers with the \\[Buffer-menu-mark] command."
(interactive)
(let ((buff (Buffer-menu-buffer t))
(menu (current-buffer))
@@ -247,14 +244,6 @@ You can mark buffers with the \\<Buffer-menu-mode-map>\\[Buffer-menu-mark] comma
(switch-to-buffer (car others))
(setq others (cdr others)))
(other-window 1))) ;back to the beginning!
-
-(defun Buffer-menu-visit-tags-table ()
- "Visit the tags table in the buffer on this line. See `visit-tags-table'."
- (interactive)
- (let ((file (buffer-file-name (Buffer-menu-buffer t))))
- (if file
- (visit-tags-table file)
- (error "Specified buffer has no file"))))
(defun Buffer-menu-1-window ()
"Select this line's buffer, alone, in full screen."
diff --git a/lisp/buff-menu.elc b/lisp/buff-menu.elc
new file mode 100644
index 00000000000..eebb3eb30bd
--- /dev/null
+++ b/lisp/buff-menu.elc
Binary files differ
diff --git a/lisp/bytecomp.el b/lisp/bytecomp.el
new file mode 100644
index 00000000000..8e7bd46e07c
--- /dev/null
+++ b/lisp/bytecomp.el
@@ -0,0 +1,1165 @@
+;; Compilation of Lisp code into byte code.
+;; Copyright (C) 1985, 1986, 1987 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+(provide 'byte-compile)
+
+(defvar byte-compile-constnum -1
+ "Transfer vector index of last constant allocated.")
+(defvar byte-compile-constants nil
+ "Alist describing contents to put in transfer vector.
+Each element is (CONTENTS . INDEX)")
+(defvar byte-compile-macro-environment nil
+ "Alist of (MACRONAME . DEFINITION) macros defined in the file
+which is being compiled.")
+(defvar byte-compile-pc 0
+ "Index in byte string to store next opcode at.")
+(defvar byte-compile-output nil
+ "Alist describing contents to put in byte code string.
+Each element is (INDEX . VALUE)")
+(defvar byte-compile-depth 0
+ "Current depth of execution stack.")
+(defvar byte-compile-maxdepth 0
+ "Maximum depth of execution stack.")
+
+(defconst byte-varref 8
+ "Byte code opcode for variable reference.")
+(defconst byte-varset 16
+ "Byte code opcode for setting a variable.")
+(defconst byte-varbind 24
+ "Byte code opcode for binding a variable.")
+(defconst byte-call 32
+ "Byte code opcode for calling a function.")
+(defconst byte-unbind 40
+ "Byte code opcode for unbinding special bindings.")
+
+(defconst byte-constant 192
+ "Byte code opcode for reference to a constant.")
+(defconst byte-constant-limit 64
+ "Maximum index usable in byte-constant opcode.")
+
+(defconst byte-constant2 129
+ "Byte code opcode for reference to a constant with vector index >= 0100.")
+
+(defconst byte-goto 130
+ "Byte code opcode for unconditional jump")
+
+(defconst byte-goto-if-nil 131
+ "Byte code opcode for pop value and jump if it's nil.")
+
+(defconst byte-goto-if-not-nil 132
+ "Byte code opcode for pop value and jump if it's not nil.")
+
+(defconst byte-goto-if-nil-else-pop 133
+ "Byte code opcode for examine top-of-stack, jump and don't pop it if it's nil,
+otherwise pop it.")
+
+(defconst byte-goto-if-not-nil-else-pop 134
+ "Byte code opcode for examine top-of-stack, jump and don't pop it if it's not nil,
+otherwise pop it.")
+
+(defconst byte-return 135
+ "Byte code opcode for pop value and return it from byte code interpreter.")
+
+(defconst byte-discard 136
+ "Byte code opcode to discard one value from stack.")
+
+(defconst byte-dup 137
+ "Byte code opcode to duplicate the top of the stack.")
+
+(defconst byte-save-excursion 138
+ "Byte code opcode to make a binding to record the buffer, point and mark.")
+
+(defconst byte-save-window-excursion 139
+ "Byte code opcode to make a binding to record entire window configuration.")
+
+(defconst byte-save-restriction 140
+ "Byte code opcode to make a binding to record the current buffer clipping restrictions.")
+
+(defconst byte-catch 141
+ "Byte code opcode for catch. Takes, on stack, the tag and an expression for the body.")
+
+(defconst byte-unwind-protect 142
+ "Byte code opcode for unwind-protect. Takes, on stack, an expression for the body
+and an expression for the unwind-action.")
+
+(defconst byte-condition-case 143
+ "Byte code opcode for condition-case. Takes, on stack, the variable to bind,
+an expression for the body, and a list of clauses.")
+
+(defconst byte-temp-output-buffer-setup 144
+ "Byte code opcode for entry to with-output-to-temp-buffer.
+Takes, on stack, the buffer name.
+Binds standard-output and does some other things.
+Returns with temp buffer on the stack in place of buffer name.")
+
+(defconst byte-temp-output-buffer-show 145
+ "Byte code opcode for exit from with-output-to-temp-buffer.
+Expects the temp buffer on the stack underneath value to return.
+Pops them both, then pushes the value back on.
+Unbinds standard-output and makes the temp buffer visible.")
+
+(defconst byte-nth 56)
+(defconst byte-symbolp 57)
+(defconst byte-consp 58)
+(defconst byte-stringp 59)
+(defconst byte-listp 60)
+(defconst byte-eq 61)
+(defconst byte-memq 62)
+(defconst byte-not 63)
+(defconst byte-car 64)
+(defconst byte-cdr 65)
+(defconst byte-cons 66)
+(defconst byte-list1 67)
+(defconst byte-list2 68)
+(defconst byte-list3 69)
+(defconst byte-list4 70)
+(defconst byte-length 71)
+(defconst byte-aref 72)
+(defconst byte-aset 73)
+(defconst byte-symbol-value 74)
+(defconst byte-symbol-function 75)
+(defconst byte-set 76)
+(defconst byte-fset 77)
+(defconst byte-get 78)
+(defconst byte-substring 79)
+(defconst byte-concat2 80)
+(defconst byte-concat3 81)
+(defconst byte-concat4 82)
+(defconst byte-sub1 83)
+(defconst byte-add1 84)
+(defconst byte-eqlsign 85)
+(defconst byte-gtr 86)
+(defconst byte-lss 87)
+(defconst byte-leq 88)
+(defconst byte-geq 89)
+(defconst byte-diff 90)
+(defconst byte-negate 91)
+(defconst byte-plus 92)
+(defconst byte-max 93)
+(defconst byte-min 94)
+
+(defconst byte-point 96)
+;(defconst byte-mark 97) no longer generated -- lisp code shouldn't call this very frequently
+(defconst byte-goto-char 98)
+(defconst byte-insert 99)
+(defconst byte-point-max 100)
+(defconst byte-point-min 101)
+(defconst byte-char-after 102)
+(defconst byte-following-char 103)
+(defconst byte-preceding-char 104)
+(defconst byte-current-column 105)
+(defconst byte-indent-to 106)
+;(defconst byte-scan-buffer 107) no longer generated
+(defconst byte-eolp 108)
+(defconst byte-eobp 109)
+(defconst byte-bolp 110)
+(defconst byte-bobp 111)
+(defconst byte-current-buffer 112)
+(defconst byte-set-buffer 113)
+(defconst byte-read-char 114)
+;(defconst byte-set-mark 115) ;obsolete
+(defconst byte-interactive-p 116)
+
+(defun byte-recompile-directory (directory &optional arg)
+ "Recompile every .el file in DIRECTORY that needs recompilation.
+This is if a .elc file exists but is older than the .el file.
+If the .elc file does not exist, offer to compile the .el file
+only if a prefix argument has been specified."
+ (interactive "DByte recompile directory: \nP")
+ (save-some-buffers)
+ (setq directory (expand-file-name directory))
+ (let ((files (directory-files directory nil "\\.el\\'"))
+ (count 0)
+ source dest)
+ (while files
+ (if (and (not (auto-save-file-name-p (car files)))
+ (setq source (expand-file-name (car files) directory))
+ (setq dest (concat (file-name-sans-versions source) "c"))
+ (if (file-exists-p dest)
+ (file-newer-than-file-p source dest)
+ (and arg (y-or-n-p (concat "Compile " source "? ")))))
+ (progn (byte-compile-file source)
+ (setq count (1+ count))))
+ (setq files (cdr files)))
+ (message "Done (Total of %d file%s compiled)"
+ count (if (= count 1) "" "s"))))
+
+(defun byte-compile-file (filename)
+ "Compile a file of Lisp code named FILENAME into a file of byte code.
+The output file's name is made by appending \"c\" to the end of FILENAME."
+ (interactive "fByte compile file: ")
+ ;; Expand now so we get the current buffer's defaults
+ (setq filename (expand-file-name filename))
+ (message "Compiling %s..." filename)
+ (let ((inbuffer (get-buffer-create " *Compiler Input*"))
+ (outbuffer (get-buffer-create " *Compiler Output*"))
+ (byte-compile-macro-environment nil)
+ (case-fold-search nil)
+ sexp)
+ (save-excursion
+ (set-buffer inbuffer)
+ (erase-buffer)
+ (insert-file-contents filename)
+ (goto-char 1)
+ (set-buffer outbuffer)
+ ;; Avoid running hooks; all we really want is the syntax table.
+ (let (emacs-lisp-mode-hook)
+ (emacs-lisp-mode))
+ (erase-buffer)
+ (while (save-excursion
+ (set-buffer inbuffer)
+ (while (progn (skip-chars-forward " \t\n\^l")
+ (looking-at ";"))
+ (forward-line 1))
+ (not (eobp)))
+ (setq sexp (read inbuffer))
+ (print (byte-compile-file-form sexp) outbuffer))
+ (set-buffer outbuffer)
+ (goto-char 1)
+ ;; In each defun or autoload, if there is a doc string,
+ ;; put a backslash-newline at the front of it.
+ (while (search-forward "\n(" nil t)
+ (cond ((looking-at "defun \\|autoload ")
+ (forward-sexp 3)
+ (skip-chars-forward " ")
+ (if (looking-at "\"")
+ (progn (forward-char 1)
+ (insert "\\\n"))))))
+ (goto-char 1)
+ ;; In each defconst or defvar, if there is a doc string
+ ;; and it starts on the same line as the form begins
+ ;; (i.e. if there is no newline in a string in the initial value)
+ ;; then put in backslash-newline at the start of the doc string.
+ (while (search-forward "\n(" nil t)
+ (if (looking-at "defvar \\|defconst ")
+ (let ((this-line (1- (point))))
+ ;;Go to end of initial value expression
+ (if (condition-case ()
+ (progn (forward-sexp 3) t)
+ (error nil))
+ (progn
+ (skip-chars-forward " ")
+ (and (eq this-line
+ (save-excursion (beginning-of-line) (point)))
+ (looking-at "\"")
+ (progn (forward-char 1)
+ (insert "\\\n"))))))))
+ (let ((vms-stmlf-recfm t))
+ (write-region 1 (point-max)
+ (concat (file-name-sans-versions filename) "c")))
+ (kill-buffer (current-buffer))
+ (kill-buffer inbuffer)))
+ t)
+
+
+(defun byte-compile-file-form (form)
+ (cond ((not (listp form))
+ form)
+ ((memq (car form) '(defun defmacro))
+ (let* ((name (car (cdr form)))
+ (tem (assq name byte-compile-macro-environment)))
+ (if (eq (car form) 'defun)
+ (progn
+ (message "Compiling %s (%s)..." filename (nth 1 form))
+ (cond (tem (setcdr tem nil))
+ ((and (fboundp name)
+ (eq (car-safe (symbol-function name)) 'macro))
+ ;; shadow existing macro definition
+ (setq byte-compile-macro-environment
+ (cons (cons name nil)
+ byte-compile-macro-environment))))
+ (prog1 (cons 'defun (byte-compile-lambda (cdr form)))
+ (if (not noninteractive)
+ (message "Compiling %s..." filename))))
+ ;; defmacro
+ (if tem
+ (setcdr tem (cons 'lambda (cdr (cdr form))))
+ (setq byte-compile-macro-environment
+ (cons (cons name (cons 'lambda (cdr (cdr form))))
+ byte-compile-macro-environment)))
+ (cons 'defmacro (byte-compile-lambda (cdr form))))))
+ ((eq (car form) 'require)
+ (eval form)
+ form)
+ (t form)))
+
+(defun byte-compile (funname)
+ "Byte-compile the definition of function FUNNAME (a symbol)."
+ (if (and (fboundp funname)
+ (eq (car-safe (symbol-function funname)) 'lambda))
+ (fset funname (byte-compile-lambda (symbol-function funname)))))
+
+(defun byte-compile-lambda (fun)
+ (let* ((bodyptr (cdr fun))
+ (int (assq 'interactive (cdr bodyptr)))
+ newbody)
+ ;; Skip doc string.
+ (if (and (cdr (cdr bodyptr)) (stringp (car (cdr bodyptr))))
+ (setq bodyptr (cdr bodyptr)))
+ (setq newbody (list (byte-compile-top-level
+ (cons 'progn (cdr bodyptr)))))
+ (if int
+ (setq newbody (cons (if (or (stringp (car (cdr int)))
+ (null (car (cdr int))))
+ int
+ (list 'interactive
+ (byte-compile-top-level (car (cdr int)))))
+ newbody)))
+ (if (not (eq bodyptr (cdr fun)))
+ (setq newbody (cons (nth 2 fun) newbody)))
+ (cons (car fun) (cons (car (cdr fun)) newbody))))
+
+(defun byte-compile-top-level (form)
+ (let ((byte-compile-constants nil)
+ (byte-compile-constnum nil)
+ (byte-compile-pc 0)
+ (byte-compile-depth 0)
+ (byte-compile-maxdepth 0)
+ (byte-compile-output nil)
+ (byte-compile-string nil)
+ (byte-compile-vector nil))
+ (let (vars temp (i -1))
+ (setq temp (byte-compile-find-vars form))
+ (setq form (car temp))
+ (setq vars (nreverse (cdr temp)))
+ (while vars
+ (setq i (1+ i))
+ (setq byte-compile-constants (cons (cons (car vars) i)
+ byte-compile-constants))
+ (setq vars (cdr vars)))
+ (setq byte-compile-constnum i))
+ (byte-compile-form form)
+ (byte-compile-out 'byte-return 0)
+ (setq byte-compile-vector (make-vector (1+ byte-compile-constnum)
+ nil))
+ (while byte-compile-constants
+ (aset byte-compile-vector (cdr (car byte-compile-constants))
+ (car (car byte-compile-constants)))
+ (setq byte-compile-constants (cdr byte-compile-constants)))
+ (setq byte-compile-string (make-string byte-compile-pc 0))
+ (while byte-compile-output
+ (aset byte-compile-string (car (car byte-compile-output))
+ (cdr (car byte-compile-output)))
+ (setq byte-compile-output (cdr byte-compile-output)))
+ (list 'byte-code byte-compile-string
+ byte-compile-vector byte-compile-maxdepth)))
+
+;; Expand all macros in FORM and find all variables it uses.
+;; Return a pair (EXPANDEDFORM . VARS)
+;; VARS is ordered with the variables encountered earliest
+;; at the end.
+;; The body and cases of a condition-case, and the body of a catch,
+;; are not scanned; variables used in them are not reported,
+;; and they are not macroexpanded. This is because they will
+;; be compiled separately when encountered during the main
+;; compilation pass.
+(defun byte-compile-find-vars (form)
+ (let ((all-vars nil))
+ (cons (byte-compile-find-vars-1 form)
+ all-vars)))
+
+;; Walk FORM, making sure all variables it uses are in ALL-VARS,
+;; and also expanding macros.
+;; Return the result of expanding all macros in FORM.
+;; This is a copy; FORM itself is not altered.
+(defun byte-compile-find-vars-1 (form)
+ (cond ((symbolp form)
+ (if (not (memq form all-vars))
+ (setq all-vars (cons form all-vars)))
+ form)
+ ((or (not (consp form)) (eq (car form) 'quote))
+ form)
+ ((memq (car form) '(let let*))
+ (let* ((binds (copy-sequence (car (cdr form))))
+ (body (cdr (cdr form)))
+ (tail binds))
+ (while tail
+ (if (symbolp (car tail))
+ (if (not (memq (car tail) all-vars))
+ (setq all-vars (cons (car tail) all-vars)))
+ (if (consp (car tail))
+ (progn
+ (if (not (memq (car (car tail)) all-vars))
+ (setq all-vars (cons (car (car tail)) all-vars)))
+ (setcar tail
+ (list (car (car tail))
+ (byte-compile-find-vars-1 (car (cdr (car tail)))))))))
+ (setq tail (cdr tail)))
+ (cons (car form)
+ (cons binds
+ (mapcar 'byte-compile-find-vars-1 body)))))
+ ((or (eq (car form) 'function)
+ ;; Because condition-case is compiled by breaking out
+ ;; all its subexpressions and compiling them separately,
+ ;; we regard it here as containing nothing but constants.
+ (eq (car form) 'condition-case))
+ form)
+ ((eq (car form) 'catch)
+ ;; catch is almost like condition case, but we
+ ;; treat its first argument normally.
+ (cons 'catch
+ (cons (byte-compile-find-vars-1 (nth 1 form))
+ (nthcdr 2 form))))
+ ((eq (car form) 'cond)
+ (let* ((clauses (copy-sequence (cdr form)))
+ (tail clauses))
+ (while tail
+ (setcar tail (mapcar 'byte-compile-find-vars-1 (car tail)))
+ (setq tail (cdr tail)))
+ (cons 'cond clauses)))
+ ((not (eq form (setq form (macroexpand form byte-compile-macro-environment))))
+ (byte-compile-find-vars-1 form))
+ ((symbolp (car form))
+ (cons (car form) (mapcar 'byte-compile-find-vars-1 (cdr form))))
+ (t (mapcar 'byte-compile-find-vars-1 form))))
+
+;; This is the recursive entry point for compiling each subform of an expression.
+
+;; Note that handler functions SHOULD NOT increment byte-compile-depth
+;; for the values they are returning! That is done on return here.
+;; Handlers should make sure that the depth on exit is the same as
+;; it was when the handler was called.
+
+(defun byte-compile-form (form)
+ (setq form (macroexpand form byte-compile-macro-environment))
+ (cond ((eq form 'nil)
+ (byte-compile-constant form))
+ ((eq form 't)
+ (byte-compile-constant form))
+ ((symbolp form)
+ (byte-compile-variable-ref 'byte-varref form))
+ ((not (consp form))
+ (byte-compile-constant form))
+ ((not (symbolp (car form)))
+ (if (eq (car-safe (car form)) 'lambda)
+ (let ((vars (nth 1 (car form)))
+ (vals (cdr form))
+ result)
+ (while vars
+ (setq result (cons (list (car vars) (car vals)) result))
+ (setq vars (cdr vars) vals (cdr vals)))
+ (byte-compile-form
+ (cons 'let (cons (nreverse result) (cdr (cdr (car form)))))))
+ (byte-compile-normal-call form)))
+ (t
+ (let ((handler (get (car form) 'byte-compile)))
+ (if handler
+ (funcall handler form)
+ (byte-compile-normal-call form)))))
+ (setq byte-compile-maxdepth
+ (max byte-compile-maxdepth
+ (setq byte-compile-depth (1+ byte-compile-depth)))))
+
+(defun byte-compile-normal-call (form)
+ (byte-compile-push-constant (car form))
+ (let ((copy (cdr form)))
+ (while copy (byte-compile-form (car copy)) (setq copy (cdr copy))))
+ (byte-compile-out 'byte-call (length (cdr form)))
+ (setq byte-compile-depth (- byte-compile-depth (length (cdr form)))))
+
+(defun byte-compile-variable-ref (base-op var)
+ (let ((data (assq var byte-compile-constants)))
+ (if data
+ (byte-compile-out base-op (cdr data))
+ (error (format "Variable %s seen on pass 2 of byte compiler but not pass 1"
+ (prin1-to-string var))))))
+
+;; Use this when the value of a form is a constant,
+;; because byte-compile-depth will be incremented accordingly
+;; on return to byte-compile-form, so it should not be done by the handler.
+(defun byte-compile-constant (const)
+ (let ((data (if (stringp const)
+ (assoc const byte-compile-constants)
+ (assq const byte-compile-constants))))
+ (if data
+ (byte-compile-out-const (cdr data))
+ (setq byte-compile-constants
+ (cons (cons const (setq byte-compile-constnum (1+ byte-compile-constnum)))
+ byte-compile-constants))
+ (byte-compile-out-const byte-compile-constnum))))
+
+;; Use this for a constant that is not the value of its containing form.
+;; Note that the calling function must explicitly decrement byte-compile-depth
+;; (or perhaps call byte-compile-discard to do so)
+;; for the word pushed by this function.
+(defun byte-compile-push-constant (const)
+ (byte-compile-constant const)
+ (setq byte-compile-maxdepth
+ (max byte-compile-maxdepth
+ (setq byte-compile-depth (1+ byte-compile-depth)))))
+
+;; Compile those primitive ordinary functions
+;; which have special byte codes just for speed.
+
+(put 'point 'byte-compile 'byte-compile-no-args)
+(put 'point 'byte-opcode 'byte-point)
+
+(put 'dot 'byte-compile 'byte-compile-no-args)
+(put 'dot 'byte-opcode 'byte-point)
+
+;(put 'mark 'byte-compile 'byte-compile-no-args)
+;(put 'mark 'byte-opcode 'byte-mark)
+
+(put 'point-max 'byte-compile 'byte-compile-no-args)
+(put 'point-max 'byte-opcode 'byte-point-max)
+
+(put 'point-min 'byte-compile 'byte-compile-no-args)
+(put 'point-min 'byte-opcode 'byte-point-min)
+
+(put 'dot-max 'byte-compile 'byte-compile-no-args)
+(put 'dot-max 'byte-opcode 'byte-point-max)
+
+(put 'dot-min 'byte-compile 'byte-compile-no-args)
+(put 'dot-min 'byte-opcode 'byte-point-min)
+
+(put 'following-char 'byte-compile 'byte-compile-no-args)
+(put 'following-char 'byte-opcode 'byte-following-char)
+
+(put 'preceding-char 'byte-compile 'byte-compile-no-args)
+(put 'preceding-char 'byte-opcode 'byte-preceding-char)
+
+(put 'current-column 'byte-compile 'byte-compile-no-args)
+(put 'current-column 'byte-opcode 'byte-current-column)
+
+(put 'eolp 'byte-compile 'byte-compile-no-args)
+(put 'eolp 'byte-opcode 'byte-eolp)
+
+(put 'eobp 'byte-compile 'byte-compile-no-args)
+(put 'eobp 'byte-opcode 'byte-eobp)
+
+(put 'bolp 'byte-compile 'byte-compile-no-args)
+(put 'bolp 'byte-opcode 'byte-bolp)
+
+(put 'bobp 'byte-compile 'byte-compile-no-args)
+(put 'bobp 'byte-opcode 'byte-bobp)
+
+(put 'current-buffer 'byte-compile 'byte-compile-no-args)
+(put 'current-buffer 'byte-opcode 'byte-current-buffer)
+
+(put 'read-char 'byte-compile 'byte-compile-no-args)
+(put 'read-char 'byte-opcode 'byte-read-char)
+
+
+(put 'symbolp 'byte-compile 'byte-compile-one-arg)
+(put 'symbolp 'byte-opcode 'byte-symbolp)
+
+(put 'consp 'byte-compile 'byte-compile-one-arg)
+(put 'consp 'byte-opcode 'byte-consp)
+
+(put 'stringp 'byte-compile 'byte-compile-one-arg)
+(put 'stringp 'byte-opcode 'byte-stringp)
+
+(put 'listp 'byte-compile 'byte-compile-one-arg)
+(put 'listp 'byte-opcode 'byte-listp)
+
+(put 'not 'byte-compile 'byte-compile-one-arg)
+(put 'not 'byte-opcode 'byte-not)
+
+(put 'null 'byte-compile 'byte-compile-one-arg)
+(put 'null 'byte-opcode 'byte-not)
+
+(put 'car 'byte-compile 'byte-compile-one-arg)
+(put 'car 'byte-opcode 'byte-car)
+
+(put 'cdr 'byte-compile 'byte-compile-one-arg)
+(put 'cdr 'byte-opcode 'byte-cdr)
+
+(put 'length 'byte-compile 'byte-compile-one-arg)
+(put 'length 'byte-opcode 'byte-length)
+
+(put 'symbol-value 'byte-compile 'byte-compile-one-arg)
+(put 'symbol-value 'byte-opcode 'byte-symbol-value)
+
+(put 'symbol-function 'byte-compile 'byte-compile-one-arg)
+(put 'symbol-function 'byte-opcode 'byte-symbol-function)
+
+(put '1+ 'byte-compile 'byte-compile-one-arg)
+(put '1+ 'byte-opcode 'byte-add1)
+
+(put '1- 'byte-compile 'byte-compile-one-arg)
+(put '1- 'byte-opcode 'byte-sub1)
+
+(put 'goto-char 'byte-compile 'byte-compile-one-arg)
+(put 'goto-char 'byte-opcode 'byte-goto-char)
+
+(put 'char-after 'byte-compile 'byte-compile-one-arg)
+(put 'char-after 'byte-opcode 'byte-char-after)
+
+(put 'set-buffer 'byte-compile 'byte-compile-one-arg)
+(put 'set-buffer 'byte-opcode 'byte-set-buffer)
+
+;set-mark turns out to be too unimportant for its own opcode.
+;(put 'set-mark 'byte-compile 'byte-compile-one-arg)
+;(put 'set-mark 'byte-opcode 'byte-set-mark)
+
+
+(put 'eq 'byte-compile 'byte-compile-two-args)
+(put 'eq 'byte-opcode 'byte-eq)
+(put 'eql 'byte-compile 'byte-compile-two-args)
+(put 'eql 'byte-opcode 'byte-eq)
+
+(put 'memq 'byte-compile 'byte-compile-two-args)
+(put 'memq 'byte-opcode 'byte-memq)
+
+(put 'cons 'byte-compile 'byte-compile-two-args)
+(put 'cons 'byte-opcode 'byte-cons)
+
+(put 'aref 'byte-compile 'byte-compile-two-args)
+(put 'aref 'byte-opcode 'byte-aref)
+
+(put 'set 'byte-compile 'byte-compile-two-args)
+(put 'set 'byte-opcode 'byte-set)
+
+(put 'fset 'byte-compile 'byte-compile-two-args)
+(put 'fset 'byte-opcode 'byte-fset)
+
+(put '= 'byte-compile 'byte-compile-two-args)
+(put '= 'byte-opcode 'byte-eqlsign)
+
+(put '< 'byte-compile 'byte-compile-two-args)
+(put '< 'byte-opcode 'byte-lss)
+
+(put '> 'byte-compile 'byte-compile-two-args)
+(put '> 'byte-opcode 'byte-gtr)
+
+(put '<= 'byte-compile 'byte-compile-two-args)
+(put '<= 'byte-opcode 'byte-leq)
+
+(put '>= 'byte-compile 'byte-compile-two-args)
+(put '>= 'byte-opcode 'byte-geq)
+
+(put 'get 'byte-compile 'byte-compile-two-args)
+(put 'get 'byte-opcode 'byte-get)
+
+(put 'nth 'byte-compile 'byte-compile-two-args)
+(put 'nth 'byte-opcode 'byte-nth)
+
+(put 'aset 'byte-compile 'byte-compile-three-args)
+(put 'aset 'byte-opcode 'byte-aset)
+
+(defun byte-compile-no-args (form)
+ (if (/= (length form) 1)
+ ;; get run-time wrong-number-of-args error.
+ ;; Would be nice if there were some way to do
+ ;; compile-time warnings.
+ (byte-compile-normal-call form)
+ (byte-compile-out (symbol-value (get (car form) 'byte-opcode)) 0)))
+
+(defun byte-compile-one-arg (form)
+ (if (/= (length form) 2)
+ (byte-compile-normal-call form)
+ (byte-compile-form (car (cdr form))) ;; Push the argument
+ (setq byte-compile-depth (1- byte-compile-depth))
+ (byte-compile-out (symbol-value (get (car form) 'byte-opcode)) 0)))
+
+(defun byte-compile-two-args (form)
+ (if (/= (length form) 3)
+ (byte-compile-normal-call form)
+ (byte-compile-form (car (cdr form))) ;; Push the arguments
+ (byte-compile-form (nth 2 form))
+ (setq byte-compile-depth (- byte-compile-depth 2))
+ (byte-compile-out (symbol-value (get (car form) 'byte-opcode)) 0)))
+
+(defun byte-compile-three-args (form)
+ (if (/= (length form) 4)
+ (byte-compile-normal-call form)
+ (byte-compile-form (car (cdr form))) ;; Push the arguments
+ (byte-compile-form (nth 2 form))
+ (byte-compile-form (nth 3 form))
+ (setq byte-compile-depth (- byte-compile-depth 3))
+ (byte-compile-out (symbol-value (get (car form) 'byte-opcode)) 0)))
+
+(put 'substring 'byte-compile 'byte-compile-substring)
+(defun byte-compile-substring (form)
+ (if (or (> (length form) 4)
+ (< (length form) 2))
+ (byte-compile-normal-call form)
+ (byte-compile-form (nth 1 form))
+ (byte-compile-form (or (nth 2 form) ''nil)) ;Optional arguments
+ (byte-compile-form (or (nth 3 form) ''nil))
+ (setq byte-compile-depth (- byte-compile-depth 3))
+ (byte-compile-out byte-substring 0)))
+
+(put 'interactive-p 'byte-compile 'byte-compile-interactive-p)
+(defun byte-compile-interactive-p (form)
+ (byte-compile-out byte-interactive-p 0))
+
+(put 'list 'byte-compile 'byte-compile-list)
+(defun byte-compile-list (form)
+ (let ((len (length form)))
+ (if (= len 1)
+ (byte-compile-constant nil)
+ (if (< len 6)
+ (let ((args (cdr form)))
+ (while args
+ (byte-compile-form (car args))
+ (setq args (cdr args)))
+ (setq byte-compile-depth (- byte-compile-depth (1- len)))
+ (byte-compile-out (symbol-value
+ (nth (- len 2)
+ '(byte-list1 byte-list2 byte-list3 byte-list4)))
+ 0))
+ (byte-compile-normal-call form)))))
+
+(put 'concat 'byte-compile 'byte-compile-concat)
+(defun byte-compile-concat (form)
+ (let ((len (length form)))
+ (cond ((= len 1)
+ (byte-compile-form ""))
+ ((= len 2)
+ ;; Concat of one arg is not a no-op if arg is not a string.
+ (byte-compile-normal-call form))
+ ((< len 6)
+ (let ((args (cdr form)))
+ (while args
+ (byte-compile-form (car args))
+ (setq args (cdr args)))
+ (setq byte-compile-depth (- byte-compile-depth (1- len)))
+ (byte-compile-out
+ (symbol-value (nth (- len 3)
+ '(byte-concat2 byte-concat3 byte-concat4)))
+ 0)))
+ (t
+ (byte-compile-normal-call form)))))
+
+(put '- 'byte-compile 'byte-compile-minus)
+(defun byte-compile-minus (form)
+ (let ((len (length form)))
+ (cond ((= len 2)
+ (byte-compile-form (car (cdr form)))
+ (setq byte-compile-depth (- byte-compile-depth 1))
+ (byte-compile-out byte-negate 0))
+ ((= len 3)
+ (byte-compile-form (car (cdr form)))
+ (byte-compile-form (nth 2 form))
+ (setq byte-compile-depth (- byte-compile-depth 2))
+ (byte-compile-out byte-diff 0))
+ (t (byte-compile-normal-call form)))))
+
+(put '+ 'byte-compile 'byte-compile-maybe-two-args)
+(put '+ 'byte-opcode 'byte-plus)
+
+(put 'max 'byte-compile 'byte-compile-maybe-two-args)
+(put 'max 'byte-opcode 'byte-max)
+
+(put 'min 'byte-compile 'byte-compile-maybe-two-args)
+(put 'min 'byte-opcode 'byte-min)
+
+(defun byte-compile-maybe-two-args (form)
+ (let ((len (length form)))
+ (if (= len 3)
+ (progn
+ (byte-compile-form (car (cdr form)))
+ (byte-compile-form (nth 2 form))
+ (setq byte-compile-depth (- byte-compile-depth 2))
+ (byte-compile-out (symbol-value (get (car form) 'byte-opcode)) 0))
+ (byte-compile-normal-call form))))
+
+(put 'function 'byte-compile 'byte-compile-function-form)
+(defun byte-compile-function-form (form)
+ (cond ((symbolp (car (cdr form)))
+ (byte-compile-form
+ (list 'symbol-function (list 'quote (nth 1 form)))))
+ (t
+ (byte-compile-constant (byte-compile-lambda (car (cdr form)))))))
+
+(put 'indent-to 'byte-compile 'byte-compile-indent-to)
+(defun byte-compile-indent-to (form)
+ (let ((len (length form)))
+ (if (= len 2)
+ (progn
+ (byte-compile-form (car (cdr form)))
+ (setq byte-compile-depth (- byte-compile-depth 1))
+ (byte-compile-out byte-indent-to 0))
+ (byte-compile-normal-call form))))
+
+(put 'insert 'byte-compile 'byte-compile-insert)
+(defun byte-compile-insert (form)
+ (let ((len (length form)))
+ (if (< len 3)
+ (let ((args (cdr form)))
+ (while args
+ (byte-compile-form (car args))
+ (setq byte-compile-depth (- byte-compile-depth 1))
+ (byte-compile-out byte-insert 0)
+ (setq args (cdr args))))
+ (byte-compile-normal-call form))))
+
+(put 'setq-default 'byte-compile 'byte-compile-setq-default)
+(defun byte-compile-setq-default (form)
+ (byte-compile-form (cons 'set-default (cons (list 'quote (nth 1 form))
+ (nthcdr 2 form)))))
+
+(put 'quote 'byte-compile 'byte-compile-quote)
+(defun byte-compile-quote (form)
+ (byte-compile-constant (car (cdr form))))
+
+(put 'setq 'byte-compile 'byte-compile-setq)
+(defun byte-compile-setq (form)
+ (let ((args (cdr form)))
+ (if args
+ (while args
+ (byte-compile-form (car (cdr args)))
+ (if (null (cdr (cdr args)))
+ (progn
+ (byte-compile-out 'byte-dup 0)
+ (setq byte-compile-maxdepth (max byte-compile-maxdepth (1+ byte-compile-depth)))))
+ (setq byte-compile-depth (1- byte-compile-depth))
+ (byte-compile-variable-ref 'byte-varset (car args))
+ (setq args (cdr (cdr args))))
+ ;; (setq), with no arguments.
+ (byte-compile-constant nil))))
+
+(put 'let 'byte-compile 'byte-compile-let)
+(defun byte-compile-let (form)
+ (let ((varlist (car (cdr form))))
+ (while varlist
+ (if (symbolp (car varlist))
+ (byte-compile-push-constant nil)
+ (byte-compile-form (car (cdr (car varlist)))))
+ (setq varlist (cdr varlist))))
+ (let ((varlist (reverse (car (cdr form)))))
+ (setq byte-compile-depth (- byte-compile-depth (length varlist)))
+ (while varlist
+ (if (symbolp (car varlist))
+ (byte-compile-variable-ref 'byte-varbind (car varlist))
+ (byte-compile-variable-ref 'byte-varbind (car (car varlist))))
+ (setq varlist (cdr varlist))))
+ (byte-compile-body (cdr (cdr form)))
+ (byte-compile-out 'byte-unbind (length (car (cdr form)))))
+
+(put 'let* 'byte-compile 'byte-compile-let*)
+(defun byte-compile-let* (form)
+ (let ((varlist (car (cdr form))))
+ (while varlist
+ (if (symbolp (car varlist))
+ (byte-compile-push-constant nil)
+ (byte-compile-form (car (cdr (car varlist)))))
+ (setq byte-compile-depth (1- byte-compile-depth))
+ (if (symbolp (car varlist))
+ (byte-compile-variable-ref 'byte-varbind (car varlist))
+ (byte-compile-variable-ref 'byte-varbind (car (car varlist))))
+ (setq varlist (cdr varlist))))
+ (byte-compile-body (cdr (cdr form)))
+ (byte-compile-out 'byte-unbind (length (car (cdr form)))))
+
+(put 'save-excursion 'byte-compile 'byte-compile-save-excursion)
+(defun byte-compile-save-excursion (form)
+ (byte-compile-out 'byte-save-excursion 0)
+ (byte-compile-body (cdr form))
+ (byte-compile-out 'byte-unbind 1))
+
+(put 'save-restriction 'byte-compile 'byte-compile-save-restriction)
+(defun byte-compile-save-restriction (form)
+ (byte-compile-out 'byte-save-restriction 0)
+ (byte-compile-body (cdr form))
+ (byte-compile-out 'byte-unbind 1))
+
+(put 'with-output-to-temp-buffer 'byte-compile 'byte-compile-with-output-to-temp-buffer)
+(defun byte-compile-with-output-to-temp-buffer (form)
+ (byte-compile-form (car (cdr form)))
+ (byte-compile-out 'byte-temp-output-buffer-setup 0)
+ (byte-compile-body (cdr (cdr form)))
+ (byte-compile-out 'byte-temp-output-buffer-show 0)
+ (setq byte-compile-depth (1- byte-compile-depth)))
+
+(put 'progn 'byte-compile 'byte-compile-progn)
+(defun byte-compile-progn (form)
+ (byte-compile-body (cdr form)))
+
+(put 'interactive 'byte-compile 'byte-compile-noop)
+(defun byte-compile-noop (form)
+ (byte-compile-constant nil))
+
+(defun byte-compile-body (body)
+ (if (null body)
+ (byte-compile-constant nil)
+ (while body
+ (byte-compile-form (car body))
+ (if (cdr body)
+ (byte-compile-discard)
+ ;; Convention is this will be counted after we return.
+ (setq byte-compile-depth (1- byte-compile-depth)))
+ (setq body (cdr body)))))
+
+(put 'prog1 'byte-compile 'byte-compile-prog1)
+(defun byte-compile-prog1 (form)
+ (byte-compile-form (car (cdr form)))
+ (if (cdr (cdr form))
+ (progn
+ (byte-compile-body (cdr (cdr form)))
+ ;; This discards the value pushed by ..-body
+ ;; (which is not counted now in byte-compile-depth)
+ ;; and decrements byte-compile-depth for the value
+ ;; pushed by byte-compile-form above, which by convention
+ ;; will be counted in byte-compile-depth after we return.
+ (byte-compile-discard))))
+
+(put 'prog2 'byte-compile 'byte-compile-prog2)
+(defun byte-compile-prog2 (form)
+ (byte-compile-form (car (cdr form)))
+ (byte-compile-discard)
+ (byte-compile-form (nth 2 form))
+ (if (cdr (cdr (cdr form)))
+ (progn
+ (byte-compile-body (cdr (cdr (cdr form))))
+ (byte-compile-discard))))
+
+(defun byte-compile-discard ()
+ (byte-compile-out 'byte-discard 0)
+ (setq byte-compile-depth (1- byte-compile-depth)))
+
+(put 'if 'byte-compile 'byte-compile-if)
+(defun byte-compile-if (form)
+ (if (null (nthcdr 3 form))
+ ;; No else-forms
+ (let ((donetag (byte-compile-make-tag)))
+ (byte-compile-form (car (cdr form)))
+ (byte-compile-goto 'byte-goto-if-nil-else-pop donetag)
+ (setq byte-compile-depth (1- byte-compile-depth))
+ (byte-compile-form (nth 2 form))
+ (setq byte-compile-depth (1- byte-compile-depth))
+ (byte-compile-out-tag donetag))
+ (let ((donetag (byte-compile-make-tag)) (elsetag (byte-compile-make-tag)))
+ (byte-compile-form (car (cdr form)))
+ (byte-compile-goto 'byte-goto-if-nil elsetag)
+ (setq byte-compile-depth (1- byte-compile-depth))
+ (byte-compile-form (nth 2 form))
+ (setq byte-compile-depth (1- byte-compile-depth))
+ (byte-compile-goto 'byte-goto donetag)
+ (byte-compile-out-tag elsetag)
+ (byte-compile-body (cdr (cdr (cdr form))))
+ (byte-compile-out-tag donetag))))
+
+(put 'cond 'byte-compile 'byte-compile-cond)
+(defun byte-compile-cond (form)
+ (if (cdr form)
+ (byte-compile-cond-1 (cdr form))
+ (byte-compile-constant nil)))
+
+(defun byte-compile-cond-1 (clauses)
+ (if (or (eq (car (car clauses)) t)
+ (and (eq (car-safe (car (car clauses))) 'quote)
+ (car-safe (cdr-safe (car (car clauses))))))
+ ;; Unconditional clause
+ (if (cdr (car clauses))
+ (byte-compile-body (cdr (car clauses)))
+ (byte-compile-form (car (car clauses))))
+ (if (null (cdr clauses))
+ ;; Only one clause
+ (let ((donetag (byte-compile-make-tag)))
+ (byte-compile-form (car (car clauses)))
+ (cond ((cdr (car clauses))
+ (byte-compile-goto 'byte-goto-if-nil-else-pop donetag)
+ (setq byte-compile-depth (1- byte-compile-depth))
+ (byte-compile-body (cdr (car clauses)))
+ (byte-compile-out-tag donetag))))
+ (let ((donetag (byte-compile-make-tag))
+ (elsetag (byte-compile-make-tag)))
+ (byte-compile-form (car (car clauses)))
+ (if (null (cdr (car clauses)))
+ ;; First clause is a singleton.
+ (progn
+ (byte-compile-goto 'byte-goto-if-not-nil-else-pop donetag)
+ (setq byte-compile-depth (1- byte-compile-depth)))
+ (byte-compile-goto 'byte-goto-if-nil elsetag)
+ (setq byte-compile-depth (1- byte-compile-depth))
+ (byte-compile-body (cdr (car clauses)))
+ (byte-compile-goto 'byte-goto donetag)
+ (byte-compile-out-tag elsetag))
+ (byte-compile-cond-1 (cdr clauses))
+ (byte-compile-out-tag donetag)))))
+
+(put 'and 'byte-compile 'byte-compile-and)
+(defun byte-compile-and (form)
+ (let ((failtag (byte-compile-make-tag))
+ (args (cdr form)))
+ (if (null args)
+ (progn
+ (byte-compile-form t)
+ (setq byte-compile-depth (1- byte-compile-depth)))
+ (while args
+ (byte-compile-form (car args))
+ (setq byte-compile-depth (1- byte-compile-depth))
+ (if (null (cdr args))
+ (byte-compile-out-tag failtag)
+ (byte-compile-goto 'byte-goto-if-nil-else-pop failtag))
+ (setq args (cdr args))))))
+
+(put 'or 'byte-compile 'byte-compile-or)
+(defun byte-compile-or (form)
+ (let ((wintag (byte-compile-make-tag))
+ (args (cdr form)))
+ (if (null args)
+ (byte-compile-constant nil)
+ (while args
+ (byte-compile-form (car args))
+ (setq byte-compile-depth (1- byte-compile-depth))
+ (if (null (cdr args))
+ (byte-compile-out-tag wintag)
+ (byte-compile-goto 'byte-goto-if-not-nil-else-pop wintag))
+ (setq args (cdr args))))))
+
+(put 'while 'byte-compile 'byte-compile-while)
+(defun byte-compile-while (form)
+ (let ((endtag (byte-compile-make-tag))
+ (looptag (byte-compile-make-tag))
+ (args (cdr (cdr form))))
+ (byte-compile-out-tag looptag)
+ (byte-compile-form (car (cdr form)))
+ (byte-compile-goto 'byte-goto-if-nil-else-pop endtag)
+ (byte-compile-body (cdr (cdr form)))
+ (byte-compile-discard)
+ (byte-compile-goto 'byte-goto looptag)
+ (byte-compile-out-tag endtag)))
+
+(put 'catch 'byte-compile 'byte-compile-catch)
+(defun byte-compile-catch (form)
+ (byte-compile-form (car (cdr form)))
+ (byte-compile-push-constant (byte-compile-top-level (cons 'progn (cdr (cdr form)))))
+ (setq byte-compile-depth (- byte-compile-depth 2))
+ (byte-compile-out 'byte-catch 0))
+
+(put 'save-window-excursion 'byte-compile 'byte-compile-save-window-excursion)
+(defun byte-compile-save-window-excursion (form)
+ (byte-compile-push-constant
+ (list (byte-compile-top-level (cons 'progn (cdr form)))))
+ (setq byte-compile-depth (1- byte-compile-depth))
+ (byte-compile-out 'byte-save-window-excursion 0))
+
+(put 'unwind-protect 'byte-compile 'byte-compile-unwind-protect)
+(defun byte-compile-unwind-protect (form)
+ (byte-compile-push-constant
+ (list (byte-compile-top-level (cons 'progn (cdr (cdr form))))))
+ (setq byte-compile-depth (1- byte-compile-depth))
+ (byte-compile-out 'byte-unwind-protect 0)
+ (byte-compile-form (car (cdr form)))
+ (setq byte-compile-depth (1- byte-compile-depth))
+ (byte-compile-out 'byte-unbind 1))
+
+(put 'condition-case 'byte-compile 'byte-compile-condition-case)
+(defun byte-compile-condition-case (form)
+ (byte-compile-push-constant (car (cdr form)))
+ (byte-compile-push-constant (byte-compile-top-level (nth 2 form)))
+ (let ((clauses (cdr (cdr (cdr form))))
+ compiled-clauses)
+ (while clauses
+ (let ((clause (car clauses)))
+ (setq compiled-clauses
+ (cons (list (car clause)
+ (byte-compile-top-level (cons 'progn (cdr clause))))
+ compiled-clauses)))
+ (setq clauses (cdr clauses)))
+ (byte-compile-push-constant (nreverse compiled-clauses)))
+ (setq byte-compile-depth (- byte-compile-depth 3))
+ (byte-compile-out 'byte-condition-case 0))
+
+(defun byte-compile-make-tag ()
+ (cons nil nil))
+
+(defun byte-compile-out-tag (tag)
+ (let ((uses (car tag)))
+ (setcar tag byte-compile-pc)
+ (while uses
+ (byte-compile-store-goto (car uses) byte-compile-pc)
+ (setq uses (cdr uses)))))
+
+(defun byte-compile-goto (opcode tag)
+ (byte-compile-out opcode 0)
+ (if (integerp (car tag))
+ (byte-compile-store-goto byte-compile-pc (car tag))
+ (setcar tag (cons byte-compile-pc (car tag))))
+ (setq byte-compile-pc (+ byte-compile-pc 2)))
+
+(defun byte-compile-store-goto (at-pc to-pc)
+ (setq byte-compile-output
+ (cons (cons at-pc (logand to-pc 255))
+ byte-compile-output))
+ (setq byte-compile-output
+ (cons (cons (1+ at-pc) (lsh to-pc -8))
+ byte-compile-output)))
+
+(defun byte-compile-out (opcode offset)
+ (setq opcode (eval opcode))
+ (if (< offset 6)
+ (byte-compile-out-1 (+ opcode offset))
+ (if (< offset 256)
+ (progn
+ (byte-compile-out-1 (+ opcode 6))
+ (byte-compile-out-1 offset))
+ (byte-compile-out-1 (+ opcode 7))
+ (byte-compile-out-1 (logand offset 255))
+ (byte-compile-out-1 (lsh offset -8)))))
+
+(defun byte-compile-out-const (offset)
+ (if (< offset byte-constant-limit)
+ (byte-compile-out-1 (+ byte-constant offset))
+ (byte-compile-out-1 byte-constant2)
+ (byte-compile-out-1 (logand offset 255))
+ (byte-compile-out-1 (lsh offset -8))))
+
+(defun byte-compile-out-1 (code)
+ (setq byte-compile-output
+ (cons (cons byte-compile-pc code)
+ byte-compile-output))
+ (setq byte-compile-pc (1+ byte-compile-pc)))
+
+;;; by crl@newton.purdue.edu
+;;; Only works noninteractively.
+(defun batch-byte-compile ()
+ "Runs byte-compile-file on the files remaining on the command line.
+Must be used only with -batch, and kills emacs on completion.
+Each file will be processed even if an error occurred previously.
+For example, invoke \"emacs -batch -f batch-byte-compile $emacs/ ~/*.el\""
+ ;; command-line-args-left is what is left of the command line (from startup.el)
+ (if (not noninteractive)
+ (error "batch-byte-compile is to be used only with -batch"))
+ (let ((error nil))
+ (while command-line-args-left
+ (if (file-directory-p (expand-file-name (car command-line-args-left)))
+ (let ((files (directory-files (car command-line-args-left)))
+ source dest)
+ (while files
+ (if (and (string-match ".el$" (car files))
+ (not (auto-save-file-name-p (car files)))
+ (setq source (expand-file-name (car files)
+ (car command-line-args-left)))
+ (setq dest (concat (file-name-sans-versions source) "c"))
+ (file-exists-p dest)
+ (file-newer-than-file-p source dest))
+ (if (null (batch-byte-compile-file source))
+ (setq error t)))
+ (setq files (cdr files))))
+ (if (null (batch-byte-compile-file (car command-line-args-left)))
+ (setq error t)))
+ (setq command-line-args-left (cdr command-line-args-left)))
+ (message "Done")
+ (kill-emacs (if error 1 0))))
+
+(defun batch-byte-compile-file (file)
+ (condition-case err
+ (progn (byte-compile-file file) t)
+ (error
+ (message (if (cdr err)
+ ">>Error occurred processing %s: %s (%s)"
+ ">>Error occurred processing %s: %s")
+ file
+ (get (car err) 'error-message)
+ (prin1-to-string (cdr err)))
+ nil)))
diff --git a/lisp/bytecomp.elc b/lisp/bytecomp.elc
new file mode 100644
index 00000000000..259d23cd4cf
--- /dev/null
+++ b/lisp/bytecomp.elc
Binary files differ
diff --git a/lisp/c-fill.el b/lisp/c-fill.el
new file mode 100644
index 00000000000..457e4c4ab1d
--- /dev/null
+++ b/lisp/c-fill.el
@@ -0,0 +1,269 @@
+;;; 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.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; 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-hook (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 --git a/lisp/c-fill.elc b/lisp/c-fill.elc
new file mode 100644
index 00000000000..ad428dea863
--- /dev/null
+++ b/lisp/c-fill.elc
Binary files differ
diff --git a/lisp/c-mode.el b/lisp/c-mode.el
new file mode 100644
index 00000000000..950de6cdde5
--- /dev/null
+++ b/lisp/c-mode.el
@@ -0,0 +1,662 @@
+;; C code editing commands for Emacs
+;; Copyright (C) 1985, 1986, 1987 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+(defvar c-mode-abbrev-table nil
+ "Abbrev table in use in C-mode buffers.")
+(define-abbrev-table 'c-mode-abbrev-table ())
+
+(defvar c-mode-map ()
+ "Keymap used in C mode.")
+(if c-mode-map
+ ()
+ (setq c-mode-map (make-sparse-keymap))
+ (define-key c-mode-map "{" 'electric-c-brace)
+ (define-key c-mode-map "}" 'electric-c-brace)
+ (define-key c-mode-map ";" 'electric-c-semi)
+ (define-key c-mode-map ":" 'electric-c-terminator)
+ (define-key c-mode-map "\e\C-h" 'mark-c-function)
+ (define-key c-mode-map "\e\C-q" 'indent-c-exp)
+ (define-key c-mode-map "\177" 'backward-delete-char-untabify)
+ (define-key c-mode-map "\t" 'c-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 c-mode-syntax-table nil
+ "Syntax table in use in C-mode buffers.")
+
+(if c-mode-syntax-table
+ ()
+ (setq c-mode-syntax-table (make-syntax-table))
+ (modify-syntax-entry ?\\ "\\" c-mode-syntax-table)
+ (modify-syntax-entry ?/ ". 14" c-mode-syntax-table)
+ (modify-syntax-entry ?* ". 23" c-mode-syntax-table)
+ (modify-syntax-entry ?+ "." c-mode-syntax-table)
+ (modify-syntax-entry ?- "." c-mode-syntax-table)
+ (modify-syntax-entry ?= "." c-mode-syntax-table)
+ (modify-syntax-entry ?% "." c-mode-syntax-table)
+ (modify-syntax-entry ?< "." c-mode-syntax-table)
+ (modify-syntax-entry ?> "." c-mode-syntax-table)
+ (modify-syntax-entry ?& "." c-mode-syntax-table)
+ (modify-syntax-entry ?| "." c-mode-syntax-table)
+ (modify-syntax-entry ?\' "\"" c-mode-syntax-table))
+
+(defconst c-indent-level 2
+ "*Indentation of C statements with respect to containing block.")
+(defconst c-brace-imaginary-offset 0
+ "*Imagined indentation of a C open brace that actually follows a statement.")
+(defconst c-brace-offset 0
+ "*Extra indentation for braces, compared with other text in same context.")
+(defconst c-argdecl-indent 5
+ "*Indentation level of declarations of C function arguments.")
+(defconst c-label-offset -2
+ "*Offset of C label lines and case statements relative to usual indentation.")
+(defconst c-continued-statement-offset 2
+ "*Extra indent for lines not starting new statements.")
+(defconst c-continued-brace-offset 0
+ "*Extra indent for substatements that start with open-braces.
+This is in addition to c-continued-statement-offset.")
+
+(defconst c-auto-newline nil
+ "*Non-nil means automatically newline before and after braces,
+and after colons and semicolons, inserted in C code.")
+
+(defconst c-tab-always-indent t
+ "*Non-nil means TAB in C mode should always reindent the current line,
+regardless of where in the line point is when the TAB command is used.")
+
+(defun c-mode ()
+ "Major mode for editing C code.
+Expression and list commands understand all C brackets.
+Tab indents for C code.
+Comments are delimited with /* ... */.
+Paragraphs are separated by blank lines only.
+Delete converts tabs to spaces as it moves back.
+\\{c-mode-map}
+Variables controlling indentation style:
+ c-tab-always-indent
+ Non-nil means TAB in C mode should always reindent the current line,
+ regardless of where in the line point is when the TAB command is used.
+ c-auto-newline
+ Non-nil means automatically newline before and after braces,
+ and after colons and semicolons, inserted in C code.
+ c-indent-level
+ Indentation of C statements within surrounding block.
+ The surrounding block's indentation is the indentation
+ of the line on which the open-brace appears.
+ c-continued-statement-offset
+ Extra indentation given to a substatement, such as the
+ then-clause of an if or body of a while.
+ c-continued-brace-offset
+ Extra indentation given to a brace that starts a substatement.
+ This is in addition to c-continued-statement-offset.
+ c-brace-offset
+ Extra indentation for line if it starts with an open brace.
+ c-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.
+ c-argdecl-indent
+ Indentation level of declarations of C function arguments.
+ c-label-offset
+ Extra indentation for line that is a label, or case or default.
+
+Settings for K&R and BSD indentation styles are
+ c-indent-level 5 8
+ c-continued-statement-offset 5 8
+ c-brace-offset -5 -8
+ c-argdecl-indent 0 8
+ c-label-offset -5 -8
+
+Turning on C mode calls the value of the variable c-mode-hook with no args,
+if that value is non-nil."
+ (interactive)
+ (kill-all-local-variables)
+ (use-local-map c-mode-map)
+ (setq major-mode 'c-mode)
+ (setq mode-name "C")
+ (setq local-abbrev-table c-mode-abbrev-table)
+ (set-syntax-table c-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-hook)
+ (setq comment-indent-hook 'c-comment-indent)
+ (make-local-variable 'parse-sexp-ignore-comments)
+ (setq parse-sexp-ignore-comments t)
+ (run-hooks 'c-mode-hook))
+
+;; This is used by indent-for-comment
+;; to decide how much to indent a comment in C code
+;; based on its context.
+(defun c-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 electric-c-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 c-auto-newline (progn (c-indent-line) (newline) t) nil)))
+ (progn
+ (insert last-command-char)
+ (c-indent-line)
+ (if c-auto-newline
+ (progn
+ (newline)
+ ;; (newline) may have done auto-fill
+ (setq insertpos (- (point) 2))
+ (c-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 electric-c-semi (arg)
+ "Insert character and correct line's indentation."
+ (interactive "P")
+ (if c-auto-newline
+ (electric-c-terminator arg)
+ (self-insert-command (prefix-numeric-value arg))))
+
+(defun electric-c-terminator (arg)
+ "Insert character and correct line's indentation."
+ (interactive "P")
+ (let (insertpos (end (point)))
+ (if (and (not arg) (eolp)
+ (not (save-excursion
+ (beginning-of-line)
+ (skip-chars-forward " \t")
+ (or (= (following-char) ?#)
+ ;; Colon is special only after a label, or case ....
+ ;; So quickly rule out most other uses of colon
+ ;; and do no indentation for them.
+ (and (eq last-command-char ?:)
+ (not (looking-at "case[ \t]"))
+ (save-excursion
+ (forward-word 1)
+ (skip-chars-forward " \t")
+ (< (point) end)))
+ (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)
+ (c-indent-line)
+ (and c-auto-newline
+ (not (c-inside-parens-p))
+ (progn
+ (newline)
+ (setq insertpos (- (point) 2))
+ (c-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 c-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 c-indent-command (&optional whole-exp)
+ "Indent current line as C code, or in some cases insert a tab character.
+If c-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 C
+ ;; and shift remaining lines of expression the same amount.
+ (let ((shift-amt (c-indent-line))
+ beg end)
+ (save-excursion
+ (if c-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 c-tab-always-indent)
+ (save-excursion
+ (skip-chars-backward " \t")
+ (not (bolp))))
+ (insert-tab)
+ (c-indent-line))))
+
+(defun c-indent-line ()
+ "Indent current line as C code.
+Return the amount the indentation changed by."
+ (let ((indent (calculate-c-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-c-indent-within-comment)))
+ ((looking-at "[ \t]*#")
+ (setq indent 0))
+ (t
+ (skip-chars-forward " \t")
+ (if (listp indent) (setq indent (car indent)))
+ (cond ((or (looking-at "case[ \t]")
+ (and (looking-at "[A-Za-z]")
+ (save-excursion
+ (forward-sexp 1)
+ (looking-at ":"))))
+ (setq indent (max 1 (+ indent c-label-offset))))
+ ((and (looking-at "else\\b")
+ (not (looking-at "else\\s_")))
+ (setq indent (save-excursion
+ (c-backward-to-start-of-if)
+ (current-indentation))))
+ ((= (following-char) ?})
+ (setq indent (- indent c-indent-level)))
+ ((= (following-char) ?{)
+ (setq indent (+ indent c-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-c-indent (&optional parse-start)
+ "Return appropriate indentation for current line as C 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)
+ (if parse-start
+ (goto-char parse-start)
+ (beginning-of-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))
+ ((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.
+ (goto-char indent-point)
+ (skip-chars-forward " \t")
+ (if (= (following-char) ?{)
+ 0 ; Unless it starts a function body
+ (c-backward-to-noncomment (or parse-start (point-min)))
+ ;; 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 accordinglu.
+ (let ((basic-indent
+ (save-excursion
+ (re-search-backward "^[^ \^L\t\n#]" nil 'move)
+ (if (and (looking-at "\\sw\\|\\s_")
+ (looking-at "[^\"\n=(]*(")
+ (progn
+ (goto-char (1- (match-end 0)))
+ (forward-sexp 1)
+ (and (< (point) indent-point)
+ (not (memq (following-char)
+ '(?\, ?\;))))))
+ c-argdecl-indent 0))))
+ ;; Now add a little if this is a continuation line.
+ (+ basic-indent (if (or (bobp)
+ (memq (preceding-char) '(?\) ?\; ?\})))
+ 0 c-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.
+ (goto-char indent-point)
+ (c-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) ?\,)
+ (c-backward-to-start-of-continued-exp containing-sexp))
+ (beginning-of-line)
+ (c-backward-to-noncomment containing-sexp))
+ ;; Now we get the answer.
+ (if (not (memq (preceding-char) '(nil ?\, ?\; ?\} ?\{)))
+ ;; This line is continuation of preceding line's statement;
+ ;; indent c-continued-statement-offset more than the
+ ;; previous line of the statement.
+ (progn
+ (c-backward-to-start-of-continued-exp containing-sexp)
+ (+ c-continued-statement-offset (current-column)
+ (if (save-excursion (goto-char indent-point)
+ (skip-chars-forward " \t")
+ (eq (following-char) ?{))
+ c-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
+ (forward-char 1)
+ (let ((colon-line-end 0))
+ (while (progn (skip-chars-forward " \t\n")
+ (looking-at "#\\|/\\*\\|case[ \t\n].*:\\|[a-zA-Z0-9_$]*:"))
+ ;; Skip over comments and labels following openbrace.
+ (cond ((= (following-char) ?\#)
+ (forward-line 1))
+ ((= (following-char) ?\/)
+ (forward-char 2)
+ (search-forward "*/" nil 'move))
+ ;; case or 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))
+ (- (current-indentation) c-label-offset)
+ (current-column))
+ (if (= (following-char) ?\{) c-brace-offset 0)))))
+ ;; 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 c-indent-level is zero,
+ ;; use c-brace-offset + c-continued-statement-offset instead.
+ ;; For open-braces not the first thing in a line,
+ ;; add in c-brace-imaginary-offset.
+ (+ (if (and (bolp) (zerop c-indent-level))
+ (+ c-brace-offset c-continued-statement-offset)
+ c-indent-level)
+ ;; Move back over whitespace before the openbrace.
+ ;; If openbrace is not first nonwhite thing on the line,
+ ;; add the c-brace-imaginary-offset.
+ (progn (skip-chars-backward " \t")
+ (if (bolp) 0 c-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 calculate-c-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 c-backward-to-noncomment (lim)
+ (let (opoint stop)
+ (while (not stop)
+ (skip-chars-backward " \t\n\f" lim)
+ (setq opoint (point))
+ (if (and (>= (point) (+ 2 lim))
+ (save-excursion
+ (forward-char -2)
+ (looking-at "\\*/")))
+ (search-backward "/*" lim 'move)
+ (setq stop (or (<= (point) lim)
+ (save-excursion
+ (beginning-of-line)
+ (skip-chars-forward " \t")
+ (not (looking-at "#")))))
+ (or stop (beginning-of-line))))))
+
+(defun c-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"))
+
+(defun c-backward-to-start-of-if (&optional limit)
+ "Move to the start of the last ``unbalanced'' if."
+ (or limit (setq limit (save-excursion (beginning-of-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-c-function ()
+ "Put mark at end of C function, point at beginning."
+ (interactive)
+ (push-mark (point))
+ (end-of-defun)
+ (push-mark (point))
+ (beginning-of-defun)
+ (backward-paragraph))
+
+(defun indent-c-exp ()
+ "Indent each line of the C 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
+ (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 inner-loop-done nil)
+ (while (and (not inner-loop-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))
+ (c-indent-line))
+ (if (or (nth 3 state))
+ (forward-line 1)
+ (setq inner-loop-done t)))
+ (if (<= next-depth 0)
+ (setq outer-loop-done t))
+ (if outer-loop-done
+ nil
+ ;; If this line had ..))) (((.. in it, pop out of the levels
+ ;; that ended anywhere in this line, even if the final depth
+ ;; doesn't indicate that they ended.
+ (while (> last-depth (nth 6 state))
+ (setq indent-stack (cdr indent-stack)
+ contain-stack (cdr contain-stack)
+ last-depth (1- last-depth)))
+ (if (/= last-depth next-depth)
+ (setq last-sexp nil))
+ ;; Add levels for any parens that were started in this line.
+ (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) ?{))
+ (c-backward-to-noncomment opoint)
+ (if (not (memq (preceding-char) '(nil ?\, ?\; ?} ?: ?{)))
+ ;; Preceding line did not end in comma or semi;
+ ;; indent this line c-continued-statement-offset
+ ;; more than previous.
+ (progn
+ (c-backward-to-start-of-continued-exp (car contain-stack))
+ (setq this-indent
+ (+ c-continued-statement-offset (current-column)
+ (if at-brace c-continued-brace-offset 0))))
+ ;; Preceding line ended in comma or semi;
+ ;; use the standard indent for this level.
+ (if at-else
+ (progn (c-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-c-indent
+ (if (car indent-stack)
+ (- (car indent-stack))))))
+ (setcar indent-stack
+ (setq this-indent val))))
+ ;; Adjust line indentation according to its contents
+ (if (or (looking-at "case[ \t]")
+ (and (looking-at "[A-Za-z]")
+ (save-excursion
+ (forward-sexp 1)
+ (looking-at ":"))))
+ (setq this-indent (max 1 (+ this-indent c-label-offset))))
+ (if (= (following-char) ?})
+ (setq this-indent (- this-indent c-indent-level)))
+ (if (= (following-char) ?{)
+ (setq this-indent (+ this-indent c-brace-offset)))
+ ;; Put chosen indentation into effect.
+ (or (= (current-column) this-indent)
+ (= (following-char) ?\#)
+ (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)))))))))
+; (message "Indenting C expression...done")
+ )
diff --git a/lisp/c-mode.elc b/lisp/c-mode.elc
new file mode 100644
index 00000000000..83abc2b349a
--- /dev/null
+++ b/lisp/c-mode.elc
Binary files differ
diff --git a/lisp/cal.el b/lisp/cal.el
new file mode 100644
index 00000000000..2c39c4c5147
--- /dev/null
+++ b/lisp/cal.el
@@ -0,0 +1,242 @@
+;; Display a calendar inside GNU Emacs.
+;; Copyright (C) 1988 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+;;
+;; Comments, corrections, and improvements should be sent to
+;; Edward M. Reingold Department of Computer Science
+;; (217) 333-6733 University of Illinois at Urbana-Champaign
+;; reingold@a.cs.uiuc.edu 1304 West Springfield Avenue
+;; Urbana, Illinois 61801
+;;
+;; The author gratefully acknowledges the patient help of Richard Stallman
+;; in making this function into a reasonable piece of code!
+;;
+;; Modification for month-offset arguments suggested and implemented by
+;; Constantine Rasmussen Sun Microsystems, East Coast Division
+;; (617) 671-0404 2 Federal Street; Billerica, Ma. 01824
+;; ARPA: cdr@sun.com USENET: {cbosgd,decvax,hplabs,seismo}!sun!suneast!cdr
+;;
+;; Modification to mark current day with stars suggested by
+;; Franklin Davis Thinking Machines Corp
+;; (617) 876-1111 245 First Street, Cambridge, MA 02142
+;; fad@think.com
+
+(defvar calendar-hook nil
+ "List of functions called after the calendar buffer has been prepared with
+the calendar of the current month. This can be used, for example, to highlight
+today's date with asterisks--a function star-date is included for this purpose.
+The variable offset-calendar-hook is the list of functions called when the
+calendar function was called for a past or future month.")
+
+(defvar offset-calendar-hook nil
+ "List of functions called after the calendar buffer has been prepared with
+the calendar of a past or future month. The variable calendar-hook is the
+list of functions called when the calendar function was called for the
+current month.")
+
+(defun calendar (&optional month-offset)
+ "Display three-month calendar in another window.
+The three months appear side by side, with the current month in the middle
+surrounded by the previous and next months. The cursor is put on today's date.
+
+An optional prefix argument ARG causes the calendar displayed to be
+ARG months in the future if ARG is positive or in the past if ARG is
+negative; in this case the cursor goes on the first day of the month.
+
+The Gregorian calendar is assumed.
+
+After preparing the calendar window, the hooks calendar-hook are run
+when the calendar is for the current month--that is, the was no prefix
+argument. If the calendar is for a future or past month--that is, there
+was a prefix argument--the hooks offset-calendar-hook are run. Thus, for
+example, setting calendar-hooks to 'star-date will cause today's date to be
+replaced by asterisks to highlight it in the window."
+ (interactive "P")
+ (if month-offset (setq month-offset (prefix-numeric-value month-offset)))
+ (let ((today (make-marker)))
+ (save-excursion
+ (set-buffer (get-buffer-create "*Calendar*"))
+ (setq buffer-read-only t)
+ (let*
+ ((buffer-read-only nil)
+ ;; Get today's date and extract the day, month and year.
+ (date (current-time-string))
+ (garbage (string-match
+ " \\([A-Z][a-z][a-z]\\) *\\([0-9]*\\) .* \\([0-9]*\\)$"
+ date))
+ (day (or (and month-offset 1)
+ (string-to-int
+ (substring date (match-beginning 2) (match-end 2)))))
+ (month
+ (cdr (assoc
+ (substring date (match-beginning 1) (match-end 1))
+ '(("Jan" . 1) ("Feb" . 2) ("Mar" . 3) ("Apr" . 4)
+ ("May" . 5) ("Jun" . 6) ("Jul" . 7) ("Aug" . 8)
+ ("Sep" . 9) ("Oct" . 10) ("Nov" . 11) ("Dec" . 12)))))
+ (year (string-to-int
+ (substring date (match-beginning 3) (match-end 3)))))
+ (erase-buffer)
+ ;; If user requested a month in the future or the past,
+ ;; advance the variables MONTH and YEAR to describe that one.
+ (cond
+ (month-offset
+ (let ((year-month (+ (+ (* year 12) (- month 1)) month-offset)))
+ (setq month (+ (% year-month 12) 1))
+ (setq year (/ year-month 12)))))
+ ;; Generate previous month, starting at left margin.
+ (generate-month;; previous month
+ (if (= month 1) 12 (1- month))
+ (if (= month 1) (1- year) year)
+ 0)
+ ;; Generate this month, starting at column 24,
+ ;; and record where today's date appears, in the marker TODAY.
+ (goto-char (point-min))
+ (set-marker today (generate-month month year 24 day))
+ ;; Generate the following month, starting at column 48.
+ (goto-char (point-min))
+ (generate-month
+ (if (= month 12) 1 (1+ month))
+ (if (= month 12) (1+ year) year)
+ 48)))
+ ;; Display the buffer and put cursor on today's date.
+ ;; Do it in another window, but if this buffer is already visible,
+ ;; just select its window.
+ (pop-to-buffer "*Calendar*")
+ (goto-char (marker-position today))
+ ;; Make TODAY point nowhere so it won't slow down buffer editing until GC.
+ (set-marker today nil))
+ ;; Make the window just tall enough for its contents.
+ (let ((h (1- (window-height)))
+ (l (count-lines (point-min) (point-max))))
+ (or (= (+ (window-height (selected-window))
+ (window-height (minibuffer-window)))
+ (screen-height))
+ (<= h l)
+ (shrink-window (- h l))))
+ (if month-offset
+ (run-hooks 'offset-calendar-hook)
+ (run-hooks 'calendar-hook)))
+
+(defun leap-year-p (year)
+ "Returns true if YEAR is a Gregorian leap year, and false if not."
+ (or
+ (and (= (% year 4) 0)
+ (/= (% year 100) 0))
+ (= (% year 400) 0)))
+
+(defun day-number (month day year)
+ "Return day-number within year (origin-1) of the date MONTH DAY YEAR.
+For example, (day-number 1 1 1987) returns the value 1,
+while (day-number 12 31 1980) returns 366."
+;;
+;; an explanation of the calculation can be found in PascAlgorithms by
+;; Edward and Ruth Reingold, Scott-foresman/Little, Brown, 1988.
+;;
+ (let ((day-of-year (+ day (* 31 (1- month)))))
+ (if (> month 2)
+ (progn
+ (setq day-of-year (- day-of-year (/ (+ 23 (* 4 month)) 10)))
+ (if (leap-year-p year)
+ (setq day-of-year (1+ day-of-year)))))
+ day-of-year))
+
+(defun day-of-week (month day year)
+ "Returns the day-of-the-week index of MONTH DAY, YEAR.
+Value is 0 for Sunday, 1 for Monday, etc."
+;;
+;; Done by calculating the number of days elapsed since the (imaginary)
+;; Gregorian date Sunday, December 31, 1 BC and taking that number mod 7.
+;;
+ (%
+ (-
+ (+ (day-number month day year)
+ (* 365 (1- year))
+ (/ (1- year) 4))
+ (let ((correction (* (/ (1- year) 100) 3)))
+ (if (= (% correction 4) 0)
+ (/ correction 4)
+ (1+ (/ correction 4)))))
+ 7))
+
+(defun generate-month (month year indent &optional day)
+ "Produce a calendar for MONTH, YEAR on the Gregorian calendar, inserted
+in the buffer starting at the line on which point is currently located, but
+indented INDENT spaces. The position in the buffer of the optional
+parameter DAY is returned. The indentation is done from the first
+character on the line and does not disturb the first INDENT characters on
+the line."
+ (let* ((first-day-of-month (day-of-week month 1 year))
+ (first-saturday (- 7 first-day-of-month))
+ (last-of-month
+ (if (and (leap-year-p year) (= month 2))
+ 29
+ (aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month))))
+ (month-name
+ (aref ["January" "February" "March" "April" "May" "June"
+ "July" "August" "September" "October" "November" "December"]
+ (1- month))))
+ (insert-indented (format " %s %d" month-name year) indent t)
+ (insert-indented " S M Tu W Th F S" indent t)
+ (insert-indented "" indent);; move point to appropriate spot on line
+ (let ((i 0)) ;; add blank days before the first of the month
+ (while (<= (setq i (1+ i)) first-day-of-month)
+ (insert " ")))
+ (let ((i 0)
+ (day-marker)) ;; put in the days of the month
+ (while (<= (setq i (1+ i)) last-of-month)
+ (insert (format "%2d " i))
+ (and
+ day
+ (= i day) ;; save the location of the specified day
+ (setq day-marker (- (point) 2)))
+ (and (= (% i 7) (% first-saturday 7))
+ (/= i last-of-month)
+ (insert-indented "" 0 t) ;; force onto following line
+ (insert-indented "" indent))) ;; go to proper spot on line
+ day-marker)))
+
+(defun insert-indented (string indent &optional newline)
+ "Insert STRING at column INDENT.
+If the optional parameter NEWLINE is true, leave point at start of next
+line, inserting a newline if there was no next line; otherwise, leave point
+after the inserted text. Value is always `t'."
+ ;; Try to move to that column.
+ (move-to-column indent)
+ ;; If line is too short, indent out to that column.
+ (if (< (current-column) indent)
+ (indent-to indent))
+ (insert string)
+ ;; Advance to next line, if requested.
+ (if newline
+ (progn
+ (end-of-line)
+ (if (eobp)
+ (newline)
+ (forward-line 1))))
+ t)
+
+(defun star-date ()
+ "Replace today's date with asterisks in the calendar window.
+This function can be used with the calendar-hook run after the
+calendar window has been prepared."
+ (let ((buffer-read-only nil))
+ (forward-char 1)
+ (delete-backward-char 2)
+ (insert "**")
+ (backward-char 1)))
+
diff --git a/lisp/cal.elc b/lisp/cal.elc
new file mode 100644
index 00000000000..b51d15fe803
--- /dev/null
+++ b/lisp/cal.elc
Binary files differ
diff --git a/lisp/calendar/appt.el b/lisp/calendar/appt.el
deleted file mode 100644
index 5d11695cdaf..00000000000
--- a/lisp/calendar/appt.el
+++ /dev/null
@@ -1,500 +0,0 @@
-;; Appointment notification functions.
-;; Copyright (C) 1989, 1990 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;;
-;; appt.el - visible and/or audible notification of
-;; appointments from ~/diary file generated from
-;; Edward M. Reingold's calendar.el.
-;;
-;; Version 2.1
-;;
-;; Comments, corrections, and improvements should be sent to
-;; Neil M. Mager
-;; Net <neilm@juliet.ll.mit.edu>
-;; Voice (617) 981-4803
-;;;
-;;; Thanks to Edward M. Reingold for much help and many suggestions,
-;;; And to many others for bug fixes and suggestions.
-;;;
-;;;
-;;; This functions in this file will alert the user of a
-;;; pending appointment based on their diary file.
-;;;
-;;;
-;;; ******* It is necessary to invoke 'display-time' ********
-;;; ******* and 'diary' for this to work properly. ********
-;;;
-;;; A message will be displayed in the mode line of the emacs buffer
-;;; and (if the user desires) the terminal will beep and display a message
-;;; from the diary in the mini-buffer, or the user may select to
-;;; have a message displayed in a new buffer.
-;;;
-;;; The variable 'appt-message-warning-time' allows the
-;;; user to specify how much notice they want before the appointment. The
-;;; variable 'appt-issue-message' specifies whether the user wants
-;;; to to be notified of a pending appointment.
-;;;
-;;; In order to use, the following should be in your .emacs file in addition to
-;;; creating a diary file and invoking calendar:
-;;;
-;;; Set some options
-;;; (setq view-diary-entries-initially t)
-;;; (setq appt-issue-message t)
-;;;
-;;; The following three lines are required:
-;;; (display-time)
-;;; (autoload 'appt-make-list "appt.el" nil t)
-;;; (setq diary-display-hook
-;;; (list 'appt-make-list 'prepare-fancy-diary-buffer))
-;;;
-;;;
-;;; This is an example of what can be in your diary file:
-;;; Monday
-;;; 9:30am Coffee break
-;;; 12:00pm Lunch
-;;;
-;;; Based upon the above lines in your .emacs and diary files,
-;;; the calendar and diary will be displayed when you enter
-;;; emacs and your appointments list will automatically be created.
-;;; You will then be reminded at 9:20am about your coffee break
-;;; and at 11:50am to go to lunch.
-;;;
-;;; Use describe-function on appt-check for a description of other variables
-;;; that can be used to personalize the notification system.
-;;;
-;;; In order to add or delete items from todays list, use appt-add
-;;; and appt-delete.
-;;;
-;;; Additionally, the appointments list is recreated automatically
-;;; at 12:01am for those who do not logout every day or are programming
-;;; late.
-;;;
-;;; Brief internal description - Skip this if your not interested!
-;;;
-;;; The function appt-check is run from the 'loadst' process which is started
-;;; by invoking (display-time). A temporary function below modifies
-;;; display-time-filter
-;;; (from original time.el) to include a hook which will invoke appt-check.
-;;; This will not be necessary in the next version of gnuemacs.
-;;;
-;;;
-;;; The function appt-make-list creates the appointments list which appt-check
-;;; reads. This is all done automatically.
-;;; It is invoked from the function list-diary-entries.
-;;;
-(defvar appt-issue-message t
- "*Non-nil means check for appointments in the diary buffer.
-To be detected, the diary entry must have the time
-as the first thing on a line.")
-
-(defvar appt-message-warning-time 10
- "*Time in minutes before an appointment that the warning begins.")
-
-(defvar appt-audible t
- "*Non-nil means beep to indicate appointment.")
-
-(defvar appt-visible t
- "*Non-nil means display appointment message in echo area.")
-
-(defvar appt-display-mode-line t
- "*Non-nil means display minutes to appointment and time on the mode line.")
-
-(defvar appt-msg-window t
- "*Non-nil means display appointment message in another window.")
-
-(defvar appt-display-duration 5
- "*The number of seconds an appointment message is displayed.")
-
-(defvar appt-display-diary t
- "*Non-nil means to display the next days diary on the screen.
-This will occur at midnight when the appointment list is updated.")
-
-(defvar appt-time-msg-list nil
- "The list of appointments for today.
-Use `appt-add' and `appt-delete' to add and delete appointments from list.
-The original list is generated from the today's `diary-entries-list'.
-The number before each time/message is the time in minutes from midnight.")
-
-(defconst max-time 1439
- "11:59pm in minutes - number of minutes in a day minus 1.")
-
-(defun appt-check ()
- "Check for an appointment and update the mode line.
-Note: the time must be the first thing in the line in the diary
-for a warning to be issued.
-
-The format of the time can be either 24 hour or am/pm.
-Example:
-
- 02/23/89
- 18:00 Dinner
-
- Thursday
- 11:45am Lunch meeting.
-
-The following variables control the action of the notification:
-
-appt-issue-message
- If T, the diary buffer is checked for appointments.
-
-appt-message-warning-time
- Variable used to determine if appointment message
- should be displayed.
-
-appt-audible
- Variable used to determine if appointment is audible.
- Default is t.
-
-appt-visible
- Variable used to determine if appointment message should be
- displayed in the mini-buffer. Default is t.
-
-appt-msg-window
- Variable used to determine if appointment message
- should temporarily appear in another window. Mutually exclusive
- to appt-visible.
-
-appt-display-duration
- The number of seconds an appointment message
- is displayed in another window.
-
-This function is run from the loadst process for display time.
-Therefore, you need to have `(display-time)' in your .emacs file."
-
-
- (let ((min-to-app -1)
- (new-time ""))
- (save-excursion
-
- ;; Get the current time and convert it to minutes
- ;; from midnight. ie. 12:01am = 1, midnight = 0.
-
- (let* ((cur-hour(string-to-int
- (substring (current-time-string) 11 13)))
- (cur-min (string-to-int
- (substring (current-time-string) 14 16)))
- (cur-comp-time (+ (* cur-hour 60) cur-min)))
-
- ;; If the time is 12:01am, we should update our
- ;; appointments to todays list.
-
- (if (= cur-comp-time 1)
- (if (and view-diary-entries-initially appt-display-diary)
- (diary)
- (let ((diary-display-hook 'appt-make-list))
- (diary))))
-
- ;; If there are entries in the list, and the
- ;; user wants a message issued
- ;; get the first time off of the list
- ;; and calculate the number of minutes until
- ;; the appointment.
-
- (if (and appt-issue-message appt-time-msg-list)
- (let ((appt-comp-time (car (car (car appt-time-msg-list)))))
- (setq min-to-app (- appt-comp-time cur-comp-time))
-
- (while (and appt-time-msg-list
- (< appt-comp-time cur-comp-time))
- (setq appt-time-msg-list (cdr appt-time-msg-list))
- (if appt-time-msg-list
- (setq appt-comp-time
- (car (car (car appt-time-msg-list))))))
-
- ;; If we have an appointment between midnight and
- ;; 'appt-message-warning-time' minutes after midnight,
- ;; we must begin to issue a message before midnight.
- ;; Midnight is considered 0 minutes and 11:59pm is
- ;; 1439 minutes. Therefore we must recalculate the minutes
- ;; to appointment variable. It is equal to the number of
- ;; minutes before midnight plus the number of
- ;; minutes after midnight our appointment is.
-
- (if (and (< appt-comp-time appt-message-warning-time)
- (> (+ cur-comp-time appt-message-warning-time)
- max-time))
- (setq min-to-app (+ (- (1+ max-time) cur-comp-time))
- appt-comp-time))
-
- ;; issue warning if the appointment time is
- ;; within appt-message-warning time
-
- (if (and (<= min-to-app appt-message-warning-time)
- (>= min-to-app 0))
- (progn
- (if appt-msg-window
- (progn
- (string-match
- "[0-9]?[0-9]:[0-9][0-9]\\(am\\|pm\\)?"
- display-time-string)
-
- (setq new-time (substring display-time-string
- (match-beginning 0)
- (match-end 0)))
- (appt-disp-window min-to-app new-time
- (car (cdr (car appt-time-msg-list)))))
- ;;; else
-
- (if appt-visible
- (message "%s"
- (car (cdr (car appt-time-msg-list)))))
-
- (if appt-audible
- (beep 1)))
-
- (if appt-display-mode-line
- (progn
- (string-match
- "[0-9]?[0-9]:[0-9][0-9]\\(am\\|pm\\)?"
- display-time-string)
-
- (setq new-time (substring display-time-string
- (match-beginning 0)
- (match-end 0)))
- (setq display-time-string
- (concat "App't in "
- min-to-app " min. " new-time " "))
-
- ;; force mode line updates - from time.el
-
- (save-excursion (set-buffer (other-buffer)))
- (set-buffer-modified-p (buffer-modified-p))
- (sit-for 0)))
-
- (if (= min-to-app 0)
- (setq appt-time-msg-list
- (cdr appt-time-msg-list)))))))))))
-
-
-;; Display appointment message in a separate buffer.
-(defun appt-disp-window (min-to-app new-time appt-msg)
- (require 'electric)
- (save-window-excursion
-
- ;; Make sure we're not in the minibuffer
- ;; before splitting the window.
-
- (if (= (screen-height)
- (nth 3 (window-edges (selected-window))))
- nil
- (appt-select-lowest-window)
- (split-window))
-
- (let* ((this-buffer (current-buffer))
- (appt-disp-buf (set-buffer (get-buffer-create "appt-buf"))))
- (setq mode-line-format
- (concat "-------------------- Appointment in "
- min-to-app " minutes. " new-time " %-"))
- (pop-to-buffer appt-disp-buf)
- (insert-string appt-msg)
- (shrink-window-if-larger-than-buffer (get-buffer-window appt-disp-buf))
- (set-buffer-modified-p nil)
- (if appt-audible
- (beep 1))
- (sit-for appt-display-duration)
- (if appt-audible
- (beep 1))
- (kill-buffer appt-disp-buf))))
-
-;; Select the lowest window on the screen.
-(defun appt-select-lowest-window ()
- (setq lowest-window (selected-window))
- (let* ((bottom-edge (car (cdr (cdr (cdr (window-edges))))))
- (last-window (previous-window))
- (window-search t))
- (while window-search
- (let* ((this-window (next-window))
- (next-bottom-edge (car (cdr (cdr (cdr
- (window-edges this-window)))))))
- (if (< bottom-edge next-bottom-edge)
- (progn
- (setq bottom-edge next-bottom-edge)
- (setq lowest-window this-window)))
-
- (select-window this-window)
- (if (eq last-window this-window)
- (progn
- (select-window lowest-window)
- (setq window-search nil)))))))
-
-
-(defun appt-add (new-appt-time new-appt-msg)
- "Add an appointment for the day at TIME and issue MESSAGE.
-The time should be in either 24 hour format or am/pm format."
-
- (interactive "sTime (hh:mm[am/pm]): \nsMessage: ")
- (if (string-match "[0-9]?[0-9]:[0-9][0-9]\\(am\\|pm\\)?" new-appt-time)
- nil
- (error "Unacceptable time-string"))
-
- (let* ((appt-time-string (concat new-appt-time " " new-appt-msg))
- (appt-time (list (appt-convert-time new-appt-time)))
- (time-msg (cons appt-time (list appt-time-string))))
- (setq appt-time-msg-list (append appt-time-msg-list
- (list time-msg)))
- (setq appt-time-msg-list (appt-sort-list appt-time-msg-list))))
-
-(defun appt-delete ()
- "Delete an appointment from the list of appointments."
- (interactive)
- (let* ((tmp-msg-list appt-time-msg-list))
- (while tmp-msg-list
- (let* ((element (car tmp-msg-list))
- (prompt-string (concat "Delete "
- (prin1-to-string (car (cdr element)))
- " from list? "))
- (test-input (y-or-n-p prompt-string)))
- (setq tmp-msg-list (cdr tmp-msg-list))
- (if test-input
- (setq appt-time-msg-list (delq element appt-time-msg-list)))
- (setq tmp-appt-msg-list nil)))
- (message "")))
-
-
-;; Create the appointments list from todays diary buffer.
-;; The time must be at the beginning of a line for it to be
-;; put in the appointments list.
-;; 02/23/89
-;; 12:00pm lunch
-;; Wednesday
-;; 10:00am group meeting"
-
-(defun appt-make-list ()
- (setq appt-time-msg-list nil)
-
- (save-excursion
- (if diary-entries-list
-
- ;; Cycle through the entry-list (diary-entries-list)
- ;; looking for entries beginning with a time. If
- ;; the entry begins with a time, add it to the
- ;; appt-time-msg-list. Then sort the list.
-
- (let ((entry-list diary-entries-list)
- (new-time-string ""))
- (while (and entry-list
- (calendar-date-equal
- (calendar-current-date) (car (car entry-list))))
- (let ((time-string (substring (prin1-to-string
- (cdr (car entry-list))) 2 -2)))
-
- (while (string-match
- "[0-9]?[0-9]:[0-9][0-9]\\(am\\|pm\\)?.*"
- time-string)
- (let* ((appt-time-string (substring time-string
- (match-beginning 0)
- (match-end 0))))
-
- (if (< (match-end 0) (length time-string))
- (setq new-time-string (substring time-string
- (+ (match-end 0) 1)
- nil))
- (setq new-time-string ""))
-
- (string-match "[0-9]?[0-9]:[0-9][0-9]\\(am\\|pm\\)?"
- time-string)
-
- (let* ((appt-time (list (appt-convert-time
- (substring time-string
- (match-beginning 0)
- (match-end 0)))))
- (time-msg (cons appt-time
- (list appt-time-string))))
- (setq time-string new-time-string)
- (setq appt-time-msg-list (append appt-time-msg-list
- (list time-msg)))))))
- (setq entry-list (cdr entry-list)))))
- (setq appt-time-msg-list (appt-sort-list appt-time-msg-list))
-
- ;; Get the current time and convert it to minutes
- ;; from midnight. ie. 12:01am = 1, midnight = 0,
- ;; so that the elements in the list
- ;; that are earlier than the present time can
- ;; be removed.
-
- (let* ((cur-hour(string-to-int
- (substring (current-time-string) 11 13)))
- (cur-min (string-to-int
- (substring (current-time-string) 14 16)))
- (cur-comp-time (+ (* cur-hour 60) cur-min))
- (appt-comp-time (car (car (car appt-time-msg-list)))))
-
- (while (and appt-time-msg-list (< appt-comp-time cur-comp-time))
- (setq appt-time-msg-list (cdr appt-time-msg-list))
- (if appt-time-msg-list
- (setq appt-comp-time (car (car (car appt-time-msg-list)))))))))
-
-
-;;Simple sort to put the appointments list in order.
-;;Scan the list for the smallest element left in the list.
-;;Append the smallest element left into the new list, and remove
-;;it from the original list.
-(defun appt-sort-list (appt-list)
- (let ((order-list nil))
- (while appt-list
- (let* ((element (car appt-list))
- (element-time (car (car element)))
- (tmp-list (cdr appt-list)))
- (while tmp-list
- (if (< element-time (car (car (car tmp-list))))
- nil
- (setq element (car tmp-list))
- (setq element-time (car (car element))))
- (setq tmp-list (cdr tmp-list)))
- (setq order-list (append order-list (list element)))
- (setq appt-list (delq element appt-list))))
- order-list))
-
-
-(defun appt-convert-time (time2conv)
- "Convert hour:min[am/pm] format to minutes from midnight."
-
- (let ((conv-time 0)
- (hr 0)
- (min 0))
-
- (string-match ":[0-9][0-9]" time2conv)
- (setq min (string-to-int
- (substring time2conv
- (+ (match-beginning 0) 1) (match-end 0))))
-
- (string-match "[0-9]?[0-9]:" time2conv)
- (setq hr (string-to-int
- (substring time2conv
- (match-beginning 0)
- (match-end 0))))
-
- ;; convert the time appointment time into 24 hour time
-
- (if (and (string-match "[p][m]" time2conv) (< hr 12))
- (progn
- (string-match "[0-9]?[0-9]:" time2conv)
- (setq hr (+ 12 hr))))
-
- ;; convert the actual time
- ;; into minutes for comparison
- ;; against the actual time.
-
- (setq conv-time (+ (* hr 60) min))
- conv-time))
-
-
-(setq display-time-hook 'appt-check)
-
-
diff --git a/lisp/case-table.el b/lisp/case-table.el
deleted file mode 100644
index f10580fe575..00000000000
--- a/lisp/case-table.el
+++ /dev/null
@@ -1,101 +0,0 @@
-;; Functions for extending the character set and dealing with case tables.
-;; Copyright (C) 1988 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-
-;; Written by:
-;; TN/ETX/TX/UMG Howard Gayle UUCP : seismo!enea!erix!howard
-;; Telefonaktiebolaget L M Ericsson Phone: +46 8 719 55 65
-;; Ericsson Telecom Telex: 14910 ERIC S
-;; S-126 25 Stockholm FAX : +46 8 719 64 82
-;; Sweden
-
-(defun describe-buffer-case-table ()
- "Describe the case table of the current buffer."
- (interactive)
- (let ((vector (make-vector 256 nil))
- (case-table (current-case-table))
- (i 0))
- (while (< i 256)
- (aset vector i
- (cond ((/= ch (downcase ch))
- (concat "uppercase, matches "
- (text-char-description (downcase ch))))
- ((/= ch (upcase ch))
- (concat "lowercase, matches "
- (text-char-description (upcase ch))))
- (t "case-invariant")))
- (setq i (1+ i))))
- (with-output-to-temp-buffer "*Help*"
- (describe-vector vector)))
-
-(defun invert-case (count)
- "Change the case of the character just after point and move over it.
-With arg, applies to that many chars.
-Negative arg inverts characters before point but does not move."
- (interactive "p")
- (if (< count 0)
- (progn (setq count (min (1- (point)) (- count)))
- (forward-char (- count))))
- (while (> count 0)
- (let ((oc (following-char))) ; Old character.
- (cond ((/= (upcase ch) ch)
- (replace-char (upcase ch)))
- ((/= (downcase ch) ch)
- (replace-char (downcase ch)))))
- (forward-char 1)
- (setq count (1- count))))
-
-(defun set-case-syntax-delims (l r table)
- "Make characters L and R a matching pair of non-case-converting delimiters.
-Sets the entries for L and R in standard-case-table,
-standard-syntax-table, and text-mode-syntax-table to indicate
-left and right delimiters."
- (aset (car table) l l)
- (aset (car table) r r)
- (modify-syntax-entry l (concat "(" (char-to-string r) " ")
- (standard-syntax-table))
- (modify-syntax-entry l (concat "(" (char-to-string r) " ")
- text-mode-syntax-table)
- (modify-syntax-entry r (concat ")" (char-to-string l) " ")
- (standard-syntax-table))
- (modify-syntax-entry r (concat ")" (char-to-string l) " ")
- text-mode-syntax-table))
-
-(defun set-case-syntax-pair (uc lc table)
- "Make characters UC and LC a pair of inter-case-converting letters.
-Sets the entries for characters UC and LC in
-standard-case-table, standard-syntax-table, and
-text-mode-syntax-table to indicate an (uppercase, lowercase)
-pair of letters."
- (aset (car table) uc lc)
- (modify-syntax-entry lc "w " (standard-syntax-table))
- (modify-syntax-entry lc "w " text-mode-syntax-table)
- (modify-syntax-entry uc "w " (standard-syntax-table))
- (modify-syntax-entry uc "w " text-mode-syntax-table))
-
-(defun set-case-syntax (c syntax table)
- "Make characters C case-invariant with syntax SYNTAX.
-Sets the entries for character C in standard-case-table,
-standard-syntax-table, and text-mode-syntax-table to indicate this.
-SYNTAX should be \" \", \"w\", \".\" or \"_\"."
- (aset (car table) c c)
- (modify-syntax-entry c syntax (standard-syntax-table))
- (modify-syntax-entry c syntax text-mode-syntax-table))
-
-(provide 'case-table)
diff --git a/lisp/chistory.el b/lisp/chistory.el
new file mode 100644
index 00000000000..beb3f336d24
--- /dev/null
+++ b/lisp/chistory.el
@@ -0,0 +1,151 @@
+;; chistory -- List command history
+;; Copyright (C) 1985 Free Software Foundation, Inc.
+;; Principal author K. Shane Hartman
+
+;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+(provide 'chistory)
+
+;; This really has nothing to do with list-command-history per se, but
+;; its a nice alternative to C-x ESC (repeat-complex-command) and
+;; functions as a lister if given no pattern. It's not important
+;; enough to warrant a file of its own.
+
+(defun repeat-matching-complex-command (&optional pattern)
+ "Edit and re-evaluate complex command with name matching PATTERN.
+Matching occurrences are displayed, most recent first, until you
+select a form for evaluation. If PATTERN is empty (or nil), every form
+in the command history is offered. The form is placed in the minibuffer
+for editing and the result is evaluated."
+ (interactive "sRedo Command (regexp): ")
+ (if pattern
+ (if (equal (setq pattern
+ (substring pattern
+ (or (string-match "[ \t]*[^ \t]" pattern)
+ (length pattern))))
+ "")
+ (setq pattern nil)))
+ (let ((history command-history)
+ (temp)
+ (what))
+ (while (and history (not what))
+ (setq temp (car history))
+ (if (and (or (not pattern) (string-match pattern (symbol-name (car temp))))
+ (y-or-n-p (format "Redo %s? " (setq temp (prin1-to-string temp)))))
+ (setq what (car history))
+ (setq history (cdr history))))
+ (if (not what)
+ (error "Command history exhausted.")
+ (edit-and-eval-command "Redo: " what))))
+
+(defvar default-command-history-filter-garbage
+ '(command-history-mode
+ list-command-history
+ electric-command-history)
+ "*A list of symbols. If default-list-command-history-filter is
+given a list whose car is an element of this list, then it will return
+non-nil (indicating the list should be discarded from the history).
+Initially, all commands related to the command history are discarded.")
+
+(defvar list-command-history-filter 'default-command-history-filter
+ "If non-nil, should be the name of a function of one argument.
+It is passed each element of the command history when
+\\[list-command-history] is called. If the filter returns non-nil for
+some element, that element is excluded from the history listing. The
+default filter removes commands associated with the command-history.")
+
+(defun default-command-history-filter (frob)
+ "Filter commands matching default-command-history-filter-garbage list
+from the command history."
+ (or (not (consp frob))
+ (memq (car frob) default-command-history-filter-garbage)))
+
+(defvar list-command-history-max 32
+ "*If non-nil, should be a positive number which specifies the maximum
+length of the Command History listing produced by list-command-history.")
+
+(defun list-command-history ()
+ "List history of commands typed to minibuffer.
+The number of commands listed is controlled by list-command-history-max.
+Calls value of list-command-history-filter (if non-nil) on each history
+element to judge if that element should be excluded from the list.
+
+The buffer is left in Command History mode."
+ (interactive)
+ (with-output-to-temp-buffer
+ "*Command History*"
+ (let ((history command-history)
+ (buffer-read-only nil)
+ (count (or list-command-history-max -1)))
+ (while (and (/= count 0) history)
+ (if (and (boundp 'list-command-history-filter)
+ list-command-history-filter
+ (funcall list-command-history-filter (car history)))
+ nil
+ (setq count (1- count))
+ (prin1 (car history))
+ (terpri))
+ (setq history (cdr history))))
+ (save-excursion
+ (set-buffer "*Command History*")
+ (goto-char (point-min))
+ (if (eobp)
+ (error "No command history.")
+ (Command-history-setup)))))
+
+(defun Command-history-setup (&optional majormode modename keymap)
+ (set-buffer "*Command History*")
+ (use-local-map (or keymap command-history-map))
+ (lisp-mode-variables nil)
+ (set-syntax-table emacs-lisp-mode-syntax-table)
+ (setq buffer-read-only t)
+ (use-local-map (or keymap command-history-map))
+ (setq major-mode (or majormode 'command-history-mode))
+ (setq mode-name (or modename "Command History")))
+
+(defvar command-history-hook nil
+ "If non-nil, its value is called on entry to command-history-mode.")
+
+(defvar command-history-map nil)
+(if command-history-map
+ nil
+ (setq command-history-map (make-keymap))
+ (lisp-mode-commands command-history-map)
+ (suppress-keymap command-history-map)
+ (define-key command-history-map "\n" 'next-line)
+ (define-key command-history-map "\r" 'next-line)
+ (define-key command-history-map "\177" 'previous-line))
+
+(defun command-history-mode ()
+ "Major mode for examining commands from command-history.
+The number of commands listed is controlled by list-command-history-max.
+The command history is filtered by list-command-history-filter if non-nil.
+
+Like Emacs-Lisp Mode except that characters do not insert themselves and
+Digits provide prefix arguments. Tab does not indent.
+\\{command-history-map}
+Calls the value of command-history-hook if that is non-nil
+The Command History listing is recomputed each time this mode is
+invoked."
+ (interactive)
+ (list-command-history)
+ (pop-to-buffer "*Command History*")
+ (run-hooks 'command-history-hook))
+
+
+
diff --git a/lisp/chistory.elc b/lisp/chistory.elc
new file mode 100644
index 00000000000..22a728b4ad3
--- /dev/null
+++ b/lisp/chistory.elc
Binary files differ
diff --git a/lisp/cl-indent.el b/lisp/cl-indent.el
new file mode 100644
index 00000000000..ae3b538f914
--- /dev/null
+++ b/lisp/cl-indent.el
@@ -0,0 +1,461 @@
+;; Lisp mode, and its idiosyncratic commands.
+;; Copyright (C) 1987 Free Software Foundation, Inc.
+;; Written by Richard Mlynarik July 1987
+
+;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;>> 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
+
+
+;;; Hairy lisp indentation.
+
+(defvar 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.")
+
+(defvar lisp-tag-indentation 1
+ "*Indentation of tags relative to containing list.
+This variable is used by the function lisp-indent-tagbody.")
+
+(defvar 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
+he 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.")
+
+
+(defun common-lisp-indent-hook (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 contining 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-hook))
+ (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-hook)))
+ ((and (null method))
+ ;; backwards compatibility
+ (setq method (get tem 'lisp-indent-hook)))))
+ (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)))
+ ((eql (char-after (1- containing-sexp)) ?\#)
+ ;; "#(...)"
+ (setq calculated (1+ sexp-column)))
+ ((null method))
+ ((integerp method)
+ ;; convenient top-level hack.
+ ;; (also compatible with lisp-indent-hook)
+ ;; 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 them free variable references!!
+ function 'common-lisp-indent-hook 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.
+; (message "trying %s for %s %s" method p function) (sit-for 1)
+ (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 <lisp-body-indent>)
+ (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 wierd 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 () <newline> <body-forms>)) 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)))))
+
+
+(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)
+ (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)
+ (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-hook
+ (if (symbolp (cdr (car l)))
+ (get (cdr (car l)) 'common-lisp-indent-hook)
+ (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-hook 1)
+;(put 'defwrapper'common-lisp-indent-hook ...)
+;(put 'def 'common-lisp-indent-hook ...)
+;(put 'defflavor 'common-lisp-indent-hook ...)
+;(put 'defsubst 'common-lisp-indent-hook ...)
+
+;;(put 'define-restart-name 'common-lisp-indent-hook '1)
+;(put 'with-restart 'common-lisp-indent-hook '((1 4 ((* 1))) (2 &body)))
+;(put 'restart-case 'common-lisp-indent-hook '((1 4) (* 2 ((0 1) (* 1)))))
+;(put 'define-condition 'common-lisp-indent-hook '((1 6) (2 6 ((* 1))) (3 4 ((* 1))) (4 &body)))
+;(put 'with-condition-handler 'common-lisp-indent-hook '((1 4 ((* 1))) (2 &body)))
+;(put 'condition-case 'common-lisp-indent-hook '((1 4) (* 2 ((0 1) (1 3) (2 &body)))))
+
+
+;;;; Turn it on.
+;(setq lisp-indent-hook 'common-lisp-indent-hook)
+
+;; To disable this stuff, (setq lisp-indent-hook 'lisp-indent-hook)
+
diff --git a/lisp/cl-indent.elc b/lisp/cl-indent.elc
new file mode 100644
index 00000000000..f8391c84d2d
--- /dev/null
+++ b/lisp/cl-indent.elc
Binary files differ
diff --git a/lisp/cl.el b/lisp/cl.el
index a4386f3c8bb..0aab4dbc13a 100644
--- a/lisp/cl.el
+++ b/lisp/cl.el
@@ -1,22 +1,21 @@
;; Common-Lisp extensions for GNU Emacs Lisp.
-;; Copyright (C) 1987, 1988, 1989 Free Software Foundation, Inc.
+;; Copyright (C) 1987, 1988 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 1, or (at your option)
+;; any later version.
+
;; 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.
+;; 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, 675 Mass Ave, Cambridge, MA 02139, USA.
;;;;
;;;; These are extensions to Emacs Lisp that provide some form of
@@ -44,7 +43,6 @@
;;;; to quiroz@cs.rochester.edu
(provide 'cl)
-(defvar cl-version "2.0 beta 29 October 1989")
;;;; GLOBAL
@@ -57,33 +55,65 @@
;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986
;;;; (quiroz@cs.rochester.edu)
-;;; Too many pieces of the rest of this package use psetq. So it is unwise to
-;;; use here anything but plain Emacs Lisp! There is a neater recursive form
-;;; for the algorithm that deals with the bodies.
-
-(defmacro psetq (&rest body)
- "(psetq {var value }...) => nil
-Like setq, but all the values are computed before any assignment is made."
- (let ((length (length body)))
- (cond ((/= (% length 2) 0)
- (error "psetq needs an even number of arguments, %d given"
- length))
- ((null body)
- '())
- (t
- (list 'prog1 nil
- (let ((setqs '())
- (bodyforms (reverse body)))
- (while bodyforms
- (let* ((value (car bodyforms))
- (place (cadr bodyforms)))
- (setq bodyforms (cddr bodyforms))
- (if (null setqs)
- (setq setqs (list 'setq place value))
- (setq setqs (list 'setq place
- (list 'prog1 value
- setqs))))))
- setqs))))))
+(defmacro psetq (&rest pairs)
+ "(psetq {VARIABLE VALUE}...): In parallel, set each VARIABLE to its VALUE.
+All the VALUEs are evaluated, and then all the VARIABLEs are set.
+Aside from order of evaluation, this is the same as `setq'."
+ (let ((nforms (length pairs)) ;count of args
+ ;; next are used to destructure the call
+ symbols ;even numbered args
+ forms ;odd numbered args
+ ;; these are used to generate code
+ bindings ;for the let
+ newsyms ;list of gensyms
+ assignments ;for the setq
+ ;; auxiliary indices
+ i)
+ ;; check there is a reasonable number of forms
+ (if (/= (% nforms 2) 0)
+ (error "Odd number of arguments to `psetq'"))
+
+ ;; destructure the args
+ (let ((ptr pairs) ;traverses the args
+ var ;visits each symbol position
+ )
+ (while ptr
+ (setq var (car ptr)) ;next variable
+ (if (not (symbolp var))
+ (error "`psetq' expected a symbol, found '%s'."
+ (prin1-to-string var)))
+ (setq symbols (cons var symbols))
+ (setq forms (cons (car (cdr ptr)) forms))
+ (setq ptr (cdr (cdr ptr)))))
+
+ ;; assign new symbols to the bindings
+ (let ((ptr forms) ;traverses the forms
+ form ;each form goes here
+ newsym ;gensym for current value of form
+ )
+ (while ptr
+ (setq form (car ptr))
+ (setq newsym (gensym))
+ (setq bindings (cons (list newsym form) bindings))
+ (setq newsyms (cons newsym newsyms))
+ (setq ptr (cdr ptr))))
+ (setq newsyms (nreverse newsyms)) ;to sync with symbols
+
+ ;; pair symbols with newsyms for assignment
+ (let ((ptr1 symbols) ;traverses original names
+ (ptr2 newsyms) ;traverses new symbols
+ )
+ (while ptr1
+ (setq assignments
+ (cons (car ptr1) (cons (car ptr2) assignments)))
+ (setq ptr1 (cdr ptr1))
+ (setq ptr2 (cdr ptr2))))
+
+ ;; generate code
+ (list 'let
+ bindings
+ (cons 'setq assignments)
+ nil)))
;;; utilities
;;;
@@ -108,8 +138,8 @@ symbols, the pairings list and the newsyms list are returned."
(defun zip-lists (evens odds)
"Merge two lists EVENS and ODDS, taking elts from each list alternatingly.
EVENS and ODDS are two lists. ZIP-LISTS constructs a new list, whose
-even numbered elements (0,2,...) come from EVENS and whose odd numbered
-elements (1,3,...) come from ODDS.
+even numbered elements (0,2,...) come from EVENS and whose odd
+numbered elements (1,3,...) come from ODDS.
The construction stops when the shorter list is exhausted."
(do* ((p0 evens (cdr p0))
(p1 odds (cdr p1))
@@ -138,7 +168,7 @@ elements to start with."
(setq odds (cons next odds))))
(defun reassemble-argslists (argslists)
- "(reassemble-argslists ARGSLISTS) => a list of lists
+ "(reassemble-argslists ARGSLISTS).
ARGSLISTS is a list of sequences. Return a list of lists, the first
sublist being all the entries coming from ELT 0 of the original
sublists, the next those coming from ELT 1 and so on, until the
@@ -148,9 +178,45 @@ shortest list is exhausted."
(dotimes (i minlen (nreverse result))
;; capture all the elements at index i
(setq result
- (cons (mapcar (function (lambda (sublist) (elt sublist i)))
+ (cons (mapcar
+ (function (lambda (sublist) (elt sublist i)))
argslists)
result)))))
+
+;;; to help parsing keyword arguments
+
+(defun build-klist (argslist acceptable)
+ "Decode a keyword argument list ARGSLIST for keywords in ACCEPTABLE.
+ARGSLIST is a list, presumably the &rest argument of a call, whose
+even numbered elements must be keywords.
+ACCEPTABLE is a list of keywords, the only ones that are truly acceptable.
+The result is an alist containing the arguments named by the keywords
+in ACCEPTABLE, or nil if something failed."
+
+ ;; check legality of the arguments, then destructure them
+ (unless (and (listp argslist)
+ (evenp (length argslist)))
+ (error "Odd number of keyword-args"))
+ (unless (and (listp acceptable)
+ (every 'keywordp acceptable))
+ (error "Second arg should be a list of keywords"))
+ (multiple-value-bind
+ (keywords forms)
+ (unzip-list argslist)
+ (unless (every 'keywordp keywords)
+ (error "Expected keywords, found `%s'"
+ (prin1-to-string keywords)))
+ (do* ;pick up the pieces
+ ((auxlist ;auxiliary a-list, may
+ (pairlis keywords forms)) ;contain repetitions and junk
+ (ptr acceptable (cdr ptr)) ;pointer in acceptable
+ (this (car ptr) (car ptr)) ;current acceptable keyword
+ (auxval nil) ;used to move values around
+ (alist '())) ;used to build the result
+ ((endp ptr) alist)
+ ;; if THIS appears in auxlist, use its value
+ (when (setq auxval (assoc this auxlist))
+ (setq alist (cons auxval alist))))))
;;; Checking that a list of symbols contains no duplicates is a common
@@ -163,14 +229,14 @@ shortest list is exhausted."
;;; 4th pass.
(defun duplicate-symbols-p (list)
"Find all symbols appearing more than once in LIST.
-Return a list of all such duplicates; nil if there are no duplicates."
+Return a list of all such duplicates; `nil' if there are no duplicates."
(let ((duplicates '()) ;result built here
(propname (gensym)) ;we use a fresh property
)
;; check validity
(unless (and (listp list)
(every 'symbolp list))
- (error "a list of symbols is needed"))
+ (error "A list of symbols is needed"))
;; pass 1: mark
(dolist (x list)
(put x propname 0))
@@ -200,46 +266,51 @@ Return a list of all such duplicates; nil if there are no duplicates."
(defmacro defkeyword (x &optional docstring)
"Make symbol X a keyword (symbol whose value is itself).
-Optional second arg DOCSTRING is a documentation string for it."
- (cond ((symbolp x)
- (list 'defconst x (list 'quote x) docstring))
- (t
- (error "`%s' is not a symbol" (prin1-to-string x)))))
+Optional second argument is a documentation string for it."
+ (cond
+ ((symbolp x)
+ (list 'defconst x (list 'quote x)))
+ (t
+ (error "`%s' is not a symbol" (prin1-to-string x)))))
(defun keywordp (sym)
- "Return t if SYM is a keyword."
- (if (and (symbolp sym) (char-equal (aref (symbol-name sym) 0) ?\:))
- ;; looks like one, make sure value is right
- (set sym sym)
- nil))
+ "Return `t' if SYM is a keyword."
+ (cond
+ ((and (symbolp sym)
+ (char-equal (aref (symbol-name sym) 0) ?\:))
+ ;; looks like one, make sure value is right
+ (set sym sym))
+ (t
+ nil)))
(defun keyword-of (sym)
"Return a keyword that is naturally associated with symbol SYM.
If SYM is keyword, the value is SYM.
Otherwise it is a keyword whose name is `:' followed by SYM's name."
- (cond ((keywordp sym)
- sym)
- ((symbolp sym)
- (let ((newsym (intern (concat ":" (symbol-name sym)))))
- (set newsym newsym)))
- (t
- (error "expected a symbol, not `%s'" (prin1-to-string sym)))))
+ (cond
+ ((keywordp sym)
+ sym)
+ ((symbolp sym)
+ (let ((newsym (intern (concat ":" (symbol-name sym)))))
+ (set newsym newsym)))
+ (t
+ (error "Expected a symbol, not `%s'" (prin1-to-string sym)))))
;;; Temporary symbols.
;;;
(defvar *gentemp-index* 0
- "Integer used by `gentemp' to produce new names.")
+ "Integer used by gentemp to produce new names.")
(defvar *gentemp-prefix* "T$$_"
- "Names generated by `gentemp begin' with this string by default.")
+ "Names generated by gentemp begin with this string by default.")
(defun gentemp (&optional prefix oblist)
"Generate a fresh interned symbol.
-There are two optional arguments, PREFIX and OBLIST. PREFIX is the string
-that begins the new name, OBLIST is the obarray used to search for old
-names. The defaults are just right, YOU SHOULD NEVER NEED THESE ARGUMENTS
-IN YOUR OWN CODE."
+There are 2 optional arguments, PREFIX and OBLIST. PREFIX is the
+string that begins the new name, OBLIST is the obarray used to search for
+old names. The defaults are just right, YOU SHOULD NEVER NEED THESE
+ARGUMENTS IN YOUR OWN CODE."
(if (null prefix)
(setq prefix *gentemp-prefix*))
(if (null oblist)
@@ -254,15 +325,16 @@ IN YOUR OWN CODE."
newsymbol))
(defvar *gensym-index* 0
- "Integer used by `gensym' to produce new names.")
+ "Integer used by gensym to produce new names.")
(defvar *gensym-prefix* "G$$_"
- "Names generated by `gensym' begin with this string by default.")
+ "Names generated by gensym begin with this string by default.")
(defun gensym (&optional prefix)
"Generate a fresh uninterned symbol.
-Optional arg PREFIX is the string that begins the new name. Most people
-take just the default, except when debugging needs suggest otherwise."
+There is an optional argument, PREFIX. PREFIX is the
+string that begins the new name. Most people take just the default,
+except when debugging needs suggest otherwise."
(if (null prefix)
(setq prefix *gensym-prefix*))
(let ((newsymbol nil)
@@ -286,10 +358,10 @@ take just the default, except when debugging needs suggest otherwise."
;;;; (quiroz@cs.rochester.edu)
;;; indentation info
-(put 'case 'lisp-indent-function 1)
-(put 'ecase 'lisp-indent-function 1)
-(put 'when 'lisp-indent-function 1)
-(put 'unless 'lisp-indent-function 1)
+(put 'case 'lisp-indent-hook 1)
+(put 'ecase 'lisp-indent-hook 1)
+(put 'when 'lisp-indent-hook 1)
+(put 'unless 'lisp-indent-hook 1)
;;; WHEN and UNLESS
;;; These two forms are simplified ifs, with a single branch.
@@ -316,7 +388,7 @@ HEAD -> t = catch all, must be last clause
-> otherwise = same as t
-> nil = illegal
-> atom = activated if (eql EXPR HEAD)
- -> list of atoms = activated if (memq EXPR HEAD)
+ -> list of atoms = activated if (member EXPR HEAD)
BODY -> list of forms, implicit PROGN is built around it.
EXPR is evaluated only once."
(let* ((newsym (gentemp))
@@ -334,12 +406,12 @@ EXPR is evaluated only once."
;; check that no 't clause is present.
;; case-clausify would put one such at the beginning of clauses
(if (eq (caar clauses) t)
- (error "no clause-head should be `t' or `otherwise' for `ecase'"))
+ (error "No clause-head should be `t' or `otherwise' for `ecase'"))
;; insert error-catching clause
(setq clauses
(cons
(list 't (list 'error
- "ecase on %s = %s failed to take any branch"
+ "ecase on %s = %s failed to take any branch."
(list 'quote expr)
(list 'prin1-to-string newsym)))
clauses))
@@ -362,28 +434,29 @@ reverse order."
(let ((head (car curclause))
(body (cdr curclause)))
;; construct a cond-clause according to the head
- (cond ((null head)
- (error "case clauses cannot have null heads: `%s'"
- (prin1-to-string curclause)))
- ((or (eq head 't)
- (eq head 'otherwise))
- ;; check it is the last clause
- (if (not (endp nextpos))
- (error "clause with `t' or `otherwise' head must be last"))
- ;; accept this clause as a 't' for cond
- (setq result (cons (cons 't body) result)))
- ((atom head)
- (setq result
- (cons (cons (list 'eql newsym (list 'quote head)) body)
- result)))
- ((listp head)
- (setq result
- (cons (cons (list 'memq newsym (list 'quote head)) body)
- result)))
- (t
- ;; catch-all for this parser
- (error "don't know how to parse case clause `%s'"
- (prin1-to-string head)))))))
+ (cond
+ ((null head)
+ (error "Case clauses cannot have null heads: `%s'"
+ (prin1-to-string curclause)))
+ ((or (eq head 't)
+ (eq head 'otherwise))
+ ;; check it is the last clause
+ (if (not (endp nextpos))
+ (error "Clause with `t' or `otherwise' head must be last"))
+ ;; accept this clause as a 't' for cond
+ (setq result (cons (cons 't body) result)))
+ ((atom head)
+ (setq result
+ (cons (cons (list 'eql newsym (list 'quote head)) body)
+ result)))
+ ((listp head)
+ (setq result
+ (cons (cons (list 'member newsym (list 'quote head)) body)
+ result)))
+ (t
+ ;; catch-all for this parser
+ (error "Don't know how to parse case clause `%s'."
+ (prin1-to-string head)))))))
;;;; end of cl-conditionals.el
@@ -405,29 +478,26 @@ reverse order."
;;;; (quiroz@cs.rochester.edu)
;;; some lisp-indentation information
-(put 'do 'lisp-indent-function 2)
-(put 'do* 'lisp-indent-function 2)
-(put 'dolist 'lisp-indent-function 1)
-(put 'dotimes 'lisp-indent-function 1)
-(put 'do-symbols 'lisp-indent-function 1)
-(put 'do-all-symbols 'lisp-indent-function 1)
+(put 'do 'lisp-indent-hook 2)
+(put 'do* 'lisp-indent-hook 2)
+(put 'dolist 'lisp-indent-hook 1)
+(put 'dotimes 'lisp-indent-hook 1)
+(put 'do-symbols 'lisp-indent-hook 1)
+(put 'do-all-symbols 'lisp-indent-hook 1)
(defmacro do (stepforms endforms &rest body)
- "(do STEPFORMS ENDFORMS . BODY): Iterate BODY, stepping some local
-variables. STEPFORMS must be a list of symbols or lists. In the second
-case, the lists must start with a symbol and contain up to two more forms.
-In the STEPFORMS, a symbol is the same as a (symbol). The other two forms
+ "(do STEPFORMS ENDFORMS . BODY): Iterate BODY, stepping some local variables.
+STEPFORMS must be a list of symbols or lists. In the second case, the
+lists must start with a symbol and contain up to two more forms. In
+the STEPFORMS, a symbol is the same as a (symbol). The other 2 forms
are the initial value (def. NIL) and the form to step (def. itself).
-
The values used by initialization and stepping are computed in parallel.
-The ENDFORMS are a list (CONDITION . ENDBODY). If the CONDITION evaluates
-to true in any iteration, ENDBODY is evaluated and the last form in it is
-returned.
-
-The BODY (which may be empty) is evaluated at every iteration, with the
-symbols of the STEPFORMS bound to the initial or stepped values."
-
+The ENDFORMS are a list (CONDITION . ENDBODY). If the CONDITION
+evaluates to true in any iteration, ENDBODY is evaluated and the last
+form in it is returned.
+The BODY (which may be empty) is evaluated at every iteration, with
+the symbols of the STEPFORMS bound to the initial or stepped values."
;; check the syntax of the macro
(and (check-do-stepforms stepforms)
(check-do-endforms endforms))
@@ -445,16 +515,13 @@ symbols of the STEPFORMS bound to the initial or stepped values."
(defmacro do* (stepforms endforms &rest body)
"`do*' is to `do' as `let*' is to `let'.
STEPFORMS must be a list of symbols or lists. In the second case, the
-lists must start with a symbol and contain up to two more forms. In the
-STEPFORMS, a symbol is the same as a (symbol). The other two forms are
-the initial value (def. NIL) and the form to step (def. itself).
-
+lists must start with a symbol and contain up to two more forms. In
+the STEPFORMS, a symbol is the same as a (symbol). The other 2 forms
+are the initial value (def. NIL) and the form to step (def. itself).
Initializations and steppings are done in the sequence they are written.
-
-The ENDFORMS are a list (CONDITION . ENDBODY). If the CONDITION evaluates
-to true in any iteration, ENDBODY is evaluated and the last form in it is
-returned.
-
+The ENDFORMS are a list (CONDITION . ENDBODY). If the CONDITION
+evaluates to true in any iteration, ENDBODY is evaluated and the last
+form in it is returned.
The BODY (which may be empty) is evaluated at every iteration, with
the symbols of the STEPFORMS bound to the initial or stepped values."
;; check the syntax of the macro
@@ -475,53 +542,65 @@ the symbols of the STEPFORMS bound to the initial or stepped values."
(defun check-do-stepforms (forms)
"True if FORMS is a valid stepforms for the do[*] macro (q.v.)"
- (if (nlistp forms)
- (error "init/step form for do[*] should be a list, not `%s'"
- (prin1-to-string forms))
+ (cond
+ ((nlistp forms)
+ (error "Init/Step form for do[*] should be a list, not `%s'"
+ (prin1-to-string forms)))
+ (t ;valid list
+ ;; each entry must be a symbol, or a list whose car is a symbol
+ ;; and whose length is no more than three
(mapcar
(function
(lambda (entry)
- (if (not (or (symbolp entry)
- (and (listp entry)
- (symbolp (car entry))
- (< (length entry) 4))))
- (error "init/step must be %s, not `%s'"
- "symbol or (symbol [init [step]])"
- (prin1-to-string entry)))))
- forms)))
+ (cond
+ ((or (symbolp entry)
+ (and (listp entry)
+ (symbolp (car entry))
+ (< (length entry) 4)))
+ t)
+ (t
+ (error
+ "Init/Step must be symbol or (symbol [init [step]]), not `%s'"
+ (prin1-to-string entry))))))
+ forms))))
(defun check-do-endforms (forms)
"True if FORMS is a valid endforms for the do[*] macro (q.v.)"
- (if (nlistp forms)
- (error "termination form for do macro should be a list, not `%s'"
- (prin1-to-string forms))))
+ (cond
+ ((listp forms)
+ t)
+ (t
+ (error "Termination form for do macro should be a list, not `%s'"
+ (prin1-to-string forms)))))
(defun extract-do-inits (forms)
"Returns a list of the initializations (for do) in FORMS
-(a stepforms, see the do macro).
-FORMS is assumed syntactically valid."
+-a stepforms, see the do macro-. Forms is assumed syntactically valid."
(mapcar
(function
(lambda (entry)
- (cond ((symbolp entry)
- (list entry nil))
- ((listp entry)
- (list (car entry) (cadr entry))))))
+ (cond
+ ((symbolp entry)
+ (list entry nil))
+ ((listp entry)
+ (list (car entry) (cadr entry))))))
forms))
-
+
;;; There used to be a reason to deal with DO differently than with
;;; DO*. The writing of PSETQ has made it largely unnecessary.
(defun extract-do-steps (forms)
- "EXTRACT-DO-STEPS FORMS => an s-expr.
-FORMS is the stepforms part of a DO macro (q.v.). This function constructs
-an s-expression that does the stepping at the end of an iteration."
+ "EXTRACT-DO-STEPS FORMS => an s-expr
+FORMS is the stepforms part of a DO macro (q.v.). This function
+constructs an s-expression that does the stepping at the end of an
+iteration."
(list (cons 'psetq (select-stepping-forms forms))))
(defun extract-do*-steps (forms)
- "EXTRACT-DO*-STEPS FORMS => an s-expr.
-FORMS is the stepforms part of a DO* macro (q.v.). This function constructs
-an s-expression that does the stepping at the end of an iteration."
+ "EXTRACT-DO*-STEPS FORMS => an s-expr
+FORMS is the stepforms part of a DO* macro (q.v.). This function
+constructs an s-expression that does the stepping at the end of an
+iteration."
(list (cons 'setq (select-stepping-forms forms))))
(defun select-stepping-forms (forms)
@@ -532,30 +611,34 @@ an s-expression that does the stepping at the end of an iteration."
)
(while ptr ;(not (endp entry)) might be safer
(setq entry (car ptr))
- (cond ((and (listp entry) (= (length entry) 3))
- (setq result (append ;append in reverse order!
- (list (caddr entry) (car entry))
- result))))
+ (cond
+ ((and (listp entry)
+ (= (length entry) 3))
+ (setq result (append ;append in reverse order!
+ (list (caddr entry) (car entry))
+ result))))
(setq ptr (cdr ptr))) ;step in the list of forms
+ ;;put things back in the
+ ;;correct order before return
(nreverse result)))
;;; Other iterative constructs
(defmacro dolist (stepform &rest body)
"(dolist (VAR LIST [RESULTFORM]) . BODY): do BODY for each elt of LIST.
-The RESULTFORM defaults to nil. The VAR is bound to successive elements
-of the value of LIST and remains bound (to the nil value) when the
+The RESULTFORM defaults to nil. The VAR is bound to successive
+elements of the value of LIST and remains bound (to the nil value) when the
RESULTFORM is evaluated."
;; check sanity
(cond
((nlistp stepform)
- (error "stepform for `dolist' should be (VAR LIST [RESULT]), not `%s'"
+ (error "Stepform for `dolist' should be (VAR LIST [RESULT]), not `%s'"
(prin1-to-string stepform)))
((not (symbolp (car stepform)))
- (error "first component of stepform should be a symbol, not `%s'"
+ (error "First component of stepform should be a symbol, not `%s'"
(prin1-to-string (car stepform))))
((> (length stepform) 3)
- (error "too many components in stepform `%s'"
+ (error "Too many components in stepform `%s'"
(prin1-to-string stepform))))
;; generate code
(let* ((var (car stepform))
@@ -571,23 +654,23 @@ RESULTFORM is evaluated."
resultform))))
(defmacro dotimes (stepform &rest body)
- "(dotimes (VAR COUNTFORM [RESULTFORM]) . BODY): Repeat BODY, counting in VAR.
+ "(dotimes (VAR COUNTFORM [RESULTFORM]) . BODY): Repeat BODY, counting in VAR.
The COUNTFORM should return a positive integer. The VAR is bound to
-successive integers from 0 to COUNTFORM - 1 and the BODY is repeated for
+successive integers from 0 to COUNTFORM-1 and the BODY is repeated for
each of them. At the end, the RESULTFORM is evaluated and its value
-returned. During this last evaluation, the VAR is still bound, and its
-value is the number of times the iteration occurred. An omitted RESULTFORM
+returned. During this last evaluation, the VAR is still bound, and its
+value is the number of times the iteration occurred. An omitted RESULTFORM
defaults to nil."
;; check sanity
(cond
((nlistp stepform)
- (error "stepform for `dotimes' should be (VAR COUNT [RESULT]), not `%s'"
+ (error "Stepform for `dotimes' should be (VAR COUNT [RESULT]), not `%s'"
(prin1-to-string stepform)))
((not (symbolp (car stepform)))
- (error "first component of stepform should be a symbol, not `%s'"
+ (error "First component of stepform should be a symbol, not `%s'"
(prin1-to-string (car stepform))))
((> (length stepform) 3)
- (error "too many components in stepform `%s'"
+ (error "Too many components in stepform `%s'"
(prin1-to-string stepform))))
;; generate code
(let* ((var (car stepform))
@@ -612,13 +695,13 @@ See also the function `mapatoms'."
;; check sanity
(cond
((nlistp stepform)
- (error "stepform for `do-symbols' should be (VAR OBARRAY [RESULT]), not `%s'"
+ (error "Stepform for `do-symbols' should be (VAR OBARRAY [RESULT]), not `%s'"
(prin1-to-string stepform)))
((not (symbolp (car stepform)))
- (error "first component of stepform should be a symbol, not `%s'"
+ (error "First component of stepform should be a symbol, not `%s'"
(prin1-to-string (car stepform))))
((> (length stepform) 3)
- (error "too many components in stepform `%s'"
+ (error "Too many components in stepform `%s'"
(prin1-to-string stepform))))
;; generate code
(let* ((var (car stepform))
@@ -648,12 +731,12 @@ Normally BODY uses `throw' or `signal' to cause an exit.
The forms in BODY should be lists, as non-lists are reserved for new features."
;; check that the body doesn't have atomic forms
(if (nlistp body)
- (error "body of `loop' should be a list of lists or nil")
+ (error "Body of `loop' should be a list of lists or nil")
;; ok, it is a list, check for atomic components
(mapcar
(function (lambda (component)
(if (nlistp component)
- (error "components of `loop' should be lists"))))
+ (error "Components of `loop' should be lists"))))
body)
;; build the infinite loop
(cons 'while (cons 't body))))
@@ -668,101 +751,52 @@ The forms in BODY should be lists, as non-lists are reserved for new features."
;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986
;;;; (quiroz@cs.rochester.edu)
-(defvar *cl-valid-named-list-accessors*
- '(first rest second third fourth fifth sixth seventh eighth ninth tenth))
-(defvar *cl-valid-nth-offsets*
- '((second . 1)
- (third . 2)
- (fourth . 3)
- (fifth . 4)
- (sixth . 5)
- (seventh . 6)
- (eighth . 7)
- (ninth . 8)
- (tenth . 9)))
-
-(defun byte-compile-named-list-accessors (form)
- "Generate code for (<accessor> FORM), where <accessor> is one of the named
-list accessors: first, second, ..., tenth, rest."
- (let* ((fun (car form))
- (arg (cadr form))
- (valid *cl-valid-named-list-accessors*)
- (offsets *cl-valid-nth-offsets*))
- (if (or (null (cdr form)) (cddr form))
- (error "%s needs exactly one argument, seen `%s'"
- fun (prin1-to-string form)))
- (if (not (memq fun valid))
- (error "`%s' not in {first, ..., tenth, rest}" fun))
- (cond ((eq fun 'first)
- (byte-compile-form arg)
- (setq byte-compile-depth (1- byte-compile-depth))
- (byte-compile-out byte-car 0))
- ((eq fun 'rest)
- (byte-compile-form arg)
- (setq byte-compile-depth (1- byte-compile-depth))
- (byte-compile-out byte-cdr 0))
- (t ;one of the others
- (byte-compile-constant (cdr (assoc fun offsets)))
- (byte-compile-form arg)
- (setq byte-compile-depth (1- byte-compile-depth))
- (byte-compile-out byte-nth 0)
- ))))
+
;;; Synonyms for list functions
(defun first (x)
"Synonym for `car'"
(car x))
-(put 'first 'byte-compile 'byte-compile-named-list-accessors)
(defun second (x)
"Return the second element of the list LIST."
(nth 1 x))
-(put 'second 'byte-compile 'byte-compile-named-list-accessors)
(defun third (x)
"Return the third element of the list LIST."
(nth 2 x))
-(put 'third 'byte-compile 'byte-compile-named-list-accessors)
(defun fourth (x)
"Return the fourth element of the list LIST."
(nth 3 x))
-(put 'fourth 'byte-compile 'byte-compile-named-list-accessors)
(defun fifth (x)
"Return the fifth element of the list LIST."
(nth 4 x))
-(put 'fifth 'byte-compile 'byte-compile-named-list-accessors)
(defun sixth (x)
"Return the sixth element of the list LIST."
(nth 5 x))
-(put 'sixth 'byte-compile 'byte-compile-named-list-accessors)
(defun seventh (x)
"Return the seventh element of the list LIST."
(nth 6 x))
-(put 'seventh 'byte-compile 'byte-compile-named-list-accessors)
(defun eighth (x)
"Return the eighth element of the list LIST."
(nth 7 x))
-(put 'eighth 'byte-compile 'byte-compile-named-list-accessors)
(defun ninth (x)
"Return the ninth element of the list LIST."
(nth 8 x))
-(put 'ninth 'byte-compile 'byte-compile-named-list-accessors)
(defun tenth (x)
"Return the tenth element of the list LIST."
(nth 9 x))
-(put 'tenth 'byte-compile 'byte-compile-named-list-accessors)
(defun rest (x)
"Synonym for `cdr'"
(cdr x))
-(put 'rest 'byte-compile 'byte-compile-named-list-accessors)
(defun endp (x)
"t if X is nil, nil if X is a cons; error otherwise."
@@ -774,7 +808,7 @@ list accessors: first, second, ..., tenth, rest."
(defun last (x)
"Returns the last link in the list LIST."
(if (nlistp x)
- (error "arg to `last' must be a list"))
+ (error "Arg to `last' must be a list"))
(do ((current-cons x (cdr current-cons))
(next-cons (cdr x) (cdr next-cons)))
((endp next-cons) current-cons)))
@@ -786,17 +820,30 @@ list accessors: first, second, ..., tenth, rest."
(slow x (cdr slow)) ;slow pointer, leaps by 1
(ready nil)) ;indicates termination
(ready n)
- (cond ((endp fast)
- (setq ready t)) ;return n
- ((endp (cdr fast))
- (setq n (+ n 1))
- (setq ready t)) ;return n+1
- ((and (eq fast slow) (> n 0))
- (setq n nil)
- (setq ready t)) ;return nil
- (t
- (setq n (+ n 2)))))) ;just advance counter
-
+ (cond
+ ((endp fast)
+ (setq ready t)) ;return n
+ ((endp (cdr fast))
+ (setq n (+ n 1))
+ (setq ready t)) ;return n+1
+ ((and (eq fast slow) (> n 0))
+ (setq n nil)
+ (setq ready t)) ;return nil
+ (t
+ (setq n (+ n 2)))))) ;just advance counter
+
+(defun member (item list)
+ "Look for ITEM in LIST; return first link in LIST whose car is `eql' to ITEM."
+ (let ((ptr list)
+ (done nil)
+ (result '()))
+ (while (not (or done (endp ptr)))
+ (cond ((eql item (car ptr))
+ (setq done t)
+ (setq result ptr)))
+ (setq ptr (cdr ptr)))
+ result))
+
(defun butlast (list &optional n)
"Return a new list like LIST but sans the last N elements.
N defaults to 1. If the list doesn't have N elements, nil is returned."
@@ -818,9 +865,11 @@ Thus, (list* 1 2 3 '(a b)) returns (1 2 3 a b)."
"Return a list which contains ITEM but is otherwise like LIST.
If ITEM occurs in LIST, the value is LIST. Otherwise it is (cons ITEM LIST).
When comparing ITEM against elements, `eql' is used."
- (if (memq item list)
- list
- (cons item list)))
+ (cond
+ ((member item list)
+ list)
+ (t
+ (cons item list))))
(defun ldiff (list sublist)
"Return a new list like LIST but sans SUBLIST.
@@ -831,175 +880,119 @@ SUBLIST must be one of the links in LIST; otherwise the value is LIST itself."
(reverse result))
(setq result (cons (car curcons) result))))
-;;; The popular c[ad]*r functions and other list accessors.
-
-;;; To implement this efficiently, a new byte compile handler is used to
-;;; generate the minimal code, saving one function call.
-
-(defun byte-compile-ca*d*r (form)
- "Generate code for a (c[ad]+r argument). This realizes the various
-combinations of car and cdr whose names are supported in this implementation.
-To use this functionality for a given function,just give its name a
-'byte-compile property of 'byte-compile-ca*d*r"
- (let* ((fun (car form))
- (arg (cadr form))
- (seq (mapcar (function (lambda (letter)
- (if (= letter ?a)
- 'byte-car 'byte-cdr)))
- (cdr (nreverse (cdr (append (symbol-name fun) nil)))))))
- ;; SEQ is a list of byte-car and byte-cdr in the correct order.
- (if (null seq)
- (error "internal: `%s' cannot be compiled by byte-compile-ca*d*r"
- (prin1-to-string form)))
- (if (or (null (cdr form)) (cddr form))
- (error "%s needs exactly one argument, seen `%s'"
- fun (prin1-to-string form)))
- (byte-compile-form arg)
- (setq byte-compile-depth (1- byte-compile-depth))
- ;; the rest of this code doesn't change the stack depth!
- (while seq
- (byte-compile-out (car seq) 0)
- (setq seq (cdr seq)))))
+;;; The popular c[ad]*r functions.
(defun caar (X)
"Return the car of the car of X."
(car (car X)))
-(put 'caar 'byte-compile 'byte-compile-ca*d*r)
(defun cadr (X)
"Return the car of the cdr of X."
(car (cdr X)))
-(put 'cadr 'byte-compile 'byte-compile-ca*d*r)
(defun cdar (X)
"Return the cdr of the car of X."
(cdr (car X)))
-(put 'cdar 'byte-compile 'byte-compile-ca*d*r)
(defun cddr (X)
"Return the cdr of the cdr of X."
(cdr (cdr X)))
-(put 'cddr 'byte-compile 'byte-compile-ca*d*r)
(defun caaar (X)
"Return the car of the car of the car of X."
(car (car (car X))))
-(put 'caaar 'byte-compile 'byte-compile-ca*d*r)
(defun caadr (X)
"Return the car of the car of the cdr of X."
(car (car (cdr X))))
-(put 'caadr 'byte-compile 'byte-compile-ca*d*r)
(defun cadar (X)
"Return the car of the cdr of the car of X."
(car (cdr (car X))))
-(put 'cadar 'byte-compile 'byte-compile-ca*d*r)
(defun cdaar (X)
"Return the cdr of the car of the car of X."
(cdr (car (car X))))
-(put 'cdaar 'byte-compile 'byte-compile-ca*d*r)
(defun caddr (X)
"Return the car of the cdr of the cdr of X."
(car (cdr (cdr X))))
-(put 'caddr 'byte-compile 'byte-compile-ca*d*r)
(defun cdadr (X)
"Return the cdr of the car of the cdr of X."
(cdr (car (cdr X))))
-(put 'cdadr 'byte-compile 'byte-compile-ca*d*r)
(defun cddar (X)
"Return the cdr of the cdr of the car of X."
(cdr (cdr (car X))))
-(put 'cddar 'byte-compile 'byte-compile-ca*d*r)
(defun cdddr (X)
"Return the cdr of the cdr of the cdr of X."
(cdr (cdr (cdr X))))
-(put 'cdddr 'byte-compile 'byte-compile-ca*d*r)
-
+
(defun caaaar (X)
"Return the car of the car of the car of the car of X."
(car (car (car (car X)))))
-(put 'caaaar 'byte-compile 'byte-compile-ca*d*r)
(defun caaadr (X)
"Return the car of the car of the car of the cdr of X."
(car (car (car (cdr X)))))
-(put 'caaadr 'byte-compile 'byte-compile-ca*d*r)
(defun caadar (X)
"Return the car of the car of the cdr of the car of X."
(car (car (cdr (car X)))))
-(put 'caadar 'byte-compile 'byte-compile-ca*d*r)
(defun cadaar (X)
"Return the car of the cdr of the car of the car of X."
(car (cdr (car (car X)))))
-(put 'cadaar 'byte-compile 'byte-compile-ca*d*r)
(defun cdaaar (X)
"Return the cdr of the car of the car of the car of X."
(cdr (car (car (car X)))))
-(put 'cdaaar 'byte-compile 'byte-compile-ca*d*r)
(defun caaddr (X)
"Return the car of the car of the cdr of the cdr of X."
(car (car (cdr (cdr X)))))
-(put 'caaddr 'byte-compile 'byte-compile-ca*d*r)
(defun cadadr (X)
"Return the car of the cdr of the car of the cdr of X."
(car (cdr (car (cdr X)))))
-(put 'cadadr 'byte-compile 'byte-compile-ca*d*r)
(defun cdaadr (X)
"Return the cdr of the car of the car of the cdr of X."
(cdr (car (car (cdr X)))))
-(put 'cdaadr 'byte-compile 'byte-compile-ca*d*r)
(defun caddar (X)
"Return the car of the cdr of the cdr of the car of X."
(car (cdr (cdr (car X)))))
-(put 'caddar 'byte-compile 'byte-compile-ca*d*r)
(defun cdadar (X)
"Return the cdr of the car of the cdr of the car of X."
(cdr (car (cdr (car X)))))
-(put 'cdadar 'byte-compile 'byte-compile-ca*d*r)
(defun cddaar (X)
"Return the cdr of the cdr of the car of the car of X."
(cdr (cdr (car (car X)))))
-(put 'cddaar 'byte-compile 'byte-compile-ca*d*r)
(defun cadddr (X)
"Return the car of the cdr of the cdr of the cdr of X."
(car (cdr (cdr (cdr X)))))
-(put 'cadddr 'byte-compile 'byte-compile-ca*d*r)
-
+
(defun cddadr (X)
"Return the cdr of the cdr of the car of the cdr of X."
(cdr (cdr (car (cdr X)))))
-(put 'cddadr 'byte-compile 'byte-compile-ca*d*r)
(defun cdaddr (X)
"Return the cdr of the car of the cdr of the cdr of X."
(cdr (car (cdr (cdr X)))))
-(put 'cdaddr 'byte-compile 'byte-compile-ca*d*r)
(defun cdddar (X)
"Return the cdr of the cdr of the cdr of the car of X."
(cdr (cdr (cdr (car X)))))
-(put 'cdddar 'byte-compile 'byte-compile-ca*d*r)
(defun cddddr (X)
"Return the cdr of the cdr of the cdr of the cdr of X."
(cdr (cdr (cdr (cdr X)))))
-(put 'cddddr 'byte-compile 'byte-compile-ca*d*r)
;;; some inverses of the accessors are needed for setf purposes
@@ -1008,16 +1001,17 @@ To use this functionality for a given function,just give its name a
(rplaca (nthcdr n list) newval))
(defun setnthcdr (n list newval)
- "(setnthcdr N LIST NEWVAL) => NEWVAL
+ "SETNTHCDR N LIST NEWVAL => NEWVAL
As a side effect, sets the Nth cdr of LIST to NEWVAL."
- (cond ((< n 0)
- (error "N must be 0 or greater, not %d" n))
- ((= n 0)
- (rplaca list (car newval))
- (rplacd list (cdr newval))
- newval)
- (t
- (rplacd (nthcdr (- n 1) list) newval))))
+ (cond
+ ((< n 0)
+ (error "N must be 0 or greater, not %d" n))
+ ((= n 0)
+ (rplaca list (car newval))
+ (rplacd list (cdr newval))
+ newval)
+ (t
+ (rplacd (nthcdr (- n 1) list) newval))))
;;; A-lists machinery
@@ -1031,7 +1025,7 @@ Does not copy ALIST."
optional 3rd arg ALIST is nconc'd at the end. KEYS and DATA must
have the same length."
(unless (= (length keys) (length data))
- (error "keys and data should be the same length"))
+ (error "Keys and data should be the same length"))
(do* ;;collect keys and data in front of alist
((kptr keys (cdr kptr)) ;traverses the keys
(dptr data (cdr dptr)) ;traverses the data
@@ -1041,6 +1035,7 @@ have the same length."
((endp kptr) result)
(setq result (acons key item result))))
+;;;; end of cl-lists.el
;;;; SEQUENCES
;;;; Emacs Lisp provides many of the 'sequences' functionality of
@@ -1136,50 +1131,8 @@ A sequence means either a list or a vector."
(unless applyval
(setq ready t)
(setq result t)))))
-
-;;; More sequence functions that don't need keyword arguments
-(defun concatenate (type &rest sequences)
- "(concatenate TYPE &rest SEQUENCES) => a sequence
-The sequence returned is of type TYPE (must be 'list, 'string, or 'vector) and
-contains the concatenation of the elements of all the arguments, in the order
-given."
- (let ((sequences (append sequences '(()))))
- (case type
- (list
- (apply (function append) sequences))
- (string
- (apply (function concat) sequences))
- (vector
- (apply (function vector) (apply (function append) sequences)))
- (t
- (error "type for concatenate `%s' not 'list, 'string or 'vector"
- (prin1-to-string type))))))
-
-(defun map (type function &rest sequences)
- "(map TYPE FUNCTION &rest SEQUENCES) => a sequence
-The FUNCTION is called on each set of elements from the SEQUENCES \(stopping
-when the shortest sequence is terminated\) and the results are possibly
-returned in a sequence of type TYPE \(one of 'list, 'vector, 'string, or nil\)
-giving NIL for TYPE gets rid of the values."
- (if (not (memq type (list 'list 'string 'vector nil)))
- (error "type for map `%s' not 'list, 'string, 'vector or nil"
- (prin1-to-string type)))
- (let ((argslists (reassemble-argslists sequences))
- results)
- (if (null type)
- (while argslists ;don't bother accumulating
- (apply function (car argslists))
- (setq argslists (cdr argslists)))
- (setq results (mapcar (function (lambda (args) (apply function args)))
- argslists))
- (case type
- (list
- results)
- (string
- (funcall (function concat) results))
- (vector
- (apply (function vector) results))))))
+
;;; an inverse of elt is needed for setf purposes
@@ -1187,16 +1140,20 @@ giving NIL for TYPE gets rid of the values."
"In SEQUENCE, set the Nth element to NEWVAL. Returns NEWVAL.
A sequence means either a list or a vector."
(let ((l (length seq)))
- (if (or (< n 0) (>= n l))
- (error "N(%d) should be between 0 and %d" n l)
- ;; only two cases need be considered valid, as strings are arrays
- (cond ((listp seq)
- (setnth n seq newval))
- ((arrayp seq)
- (aset seq n newval))
- (t
- (error "SEQ should be a sequence, not `%s'"
- (prin1-to-string seq)))))))
+ (cond
+ ((or (< n 0)
+ (>= n l))
+ (error "N(%d) should be between 0 and %d" n l))
+ (t
+ ;; only two cases need be considered
+ (cond
+ ((listp seq)
+ (setnth n seq newval))
+ ((arrayp seq)
+ (aset seq n newval))
+ (t
+ (error "SEQ should be a sequence, not `%s'"
+ (prin1-to-string seq))))))))
;;; Testing with keyword arguments.
;;;
@@ -1207,335 +1164,68 @@ A sequence means either a list or a vector."
;;; constructs an association list. That association list is used to
;;; test for satisfaction and matching.
-;;; DON'T USE MEMBER, NOR ANY FUNCTION THAT COULD TAKE KEYWORDS HERE!!!
-
-(defun build-klist (argslist acceptable &optional allow-other-keys)
- "Decode a keyword argument list ARGSLIST for keywords in ACCEPTABLE.
-ARGSLIST is a list, presumably the &rest argument of a call, whose
-even numbered elements must be keywords.
-ACCEPTABLE is a list of keywords, the only ones that are truly acceptable.
-The result is an alist containing the arguments named by the keywords
-in ACCEPTABLE, or an error is signalled, if something failed.
-If the third argument (an optional) is non-nil, other keys are acceptable."
- ;; check legality of the arguments, then destructure them
- (unless (and (listp argslist)
- (evenp (length argslist)))
- (error "build-klist: odd number of keyword-args"))
- (unless (and (listp acceptable)
- (every 'keywordp acceptable))
- (error "build-klist: second arg should be a list of keywords"))
- (multiple-value-bind
- (keywords forms)
- (unzip-list argslist)
- (unless (every 'keywordp keywords)
- (error "build-klist: expected keywords, found `%s'"
- (prin1-to-string keywords)))
- (unless (or allow-other-keys
- (every (function (lambda (keyword)
- (memq keyword acceptable)))
- keywords))
- (error "bad keyword[s]: %s not in %s"
- (prin1-to-string (mapcan (function (lambda (keyword)
- (if (memq keyword acceptable)
- nil
- (list keyword))))
- keywords))
- (prin1-to-string acceptable)))
- (do* ;;pick up the pieces
- ((auxlist ;auxiliary a-list, may
- (pairlis keywords forms)) ;contain repetitions and junk
- (ptr acceptable (cdr ptr)) ;pointer in acceptable
- (this (car ptr) (car ptr)) ;current acceptable keyword
- (auxval nil) ;used to move values around
- (alist '())) ;used to build the result
- ((endp ptr) alist)
- ;; if THIS appears in auxlist, use its value
- (when (setq auxval (assq this auxlist))
- (setq alist (cons auxval alist))))))
-
-
-(defun extract-from-klist (klist key &optional default)
- "(extract-from-klist KLIST KEY [DEFAULT]) => value of KEY or DEFAULT
+(defun extract-from-klist (key klist &optional default)
+ "EXTRACT-FROM-KLIST KEY KLIST [DEFAULT] => value of KEY or DEFAULT
Extract value associated with KEY in KLIST (return DEFAULT if nil)."
- (let ((retrieved (cdr (assq key klist))))
+ (let ((retrieved (cdr (assoc key klist))))
(or retrieved default)))
-(defun keyword-argument-supplied-p (klist key)
- "(keyword-argument-supplied-p KLIST KEY) => nil or something
-NIL if KEY (a keyword) does not appear in the KLIST."
- (assq key klist))
-
(defun add-to-klist (key item klist)
- "(ADD-TO-KLIST KEY ITEM KLIST) => new KLIST
+ "ADD-TO-KLIST KEY ITEM KLIST => new KLIST
Add association (KEY . ITEM) to KLIST."
(setq klist (acons key item klist)))
(defun elt-satisfies-test-p (item elt klist)
- "(elt-satisfies-test-p ITEM ELT KLIST) => t or nil
+ "ELT-SATISFIES-TEST-P ITEM ELT KLIST => t or nil
KLIST encodes a keyword-arguments test, as in CH. 14 of CLtL.
True if the given ITEM and ELT satisfy the test."
- (let ((test (extract-from-klist klist :test))
- (test-not (extract-from-klist klist :test-not))
- (keyfn (extract-from-klist klist :key 'identity)))
- (cond (test
- (funcall test item (funcall keyfn elt)))
- (test-not
- (not (funcall test-not item (funcall keyfn elt))))
- (t ;should never happen
- (error "neither :test nor :test-not in `%s'"
- (prin1-to-string klist))))))
+ (let ((test (extract-from-klist :test klist))
+ (test-not (extract-from-klist :test-not klist))
+ (keyfn (extract-from-klist :key klist 'identity)))
+ (cond
+ (test
+ (funcall test item (funcall keyfn elt)))
+ (test-not
+ (not (funcall test-not item (funcall keyfn elt))))
+ (t ;should never happen
+ (error "Neither :test nor :test-not in `%s'"
+ (prin1-to-string klist))))))
(defun elt-satisfies-if-p (item klist)
- "(elt-satisfies-if-p ITEM KLIST) => t or nil
+ "ELT-SATISFIES-IF-P ITEM KLIST => t or nil
True if an -if style function was called and ITEM satisfies the
predicate under :predicate in KLIST."
- (let ((predicate (extract-from-klist klist :predicate))
- (keyfn (extract-from-klist klist :key 'identity)))
+ (let ((predicate (extract-from-klist :predicate klist))
+ (keyfn (extract-from-klist :key 'identity)))
(funcall predicate item (funcall keyfn elt))))
(defun elt-satisfies-if-not-p (item klist)
- "(elt-satisfies-if-not-p ITEM KLIST) => t or nil
+ "ELT-SATISFIES-IF-NOT-P ITEM KLIST => t or nil
KLIST encodes a keyword-arguments test, as in CH. 14 of CLtL.
True if an -if-not style function was called and ITEM does not satisfy
the predicate under :predicate in KLIST."
- (let ((predicate (extract-from-klist klist :predicate))
- (keyfn (extract-from-klist klist :key 'identity)))
+ (let ((predicate (extract-from-klist :predicate klist))
+ (keyfn (extract-from-klist :key 'identity)))
(not (funcall predicate item (funcall keyfn elt)))))
-
+
(defun elts-match-under-klist-p (e1 e2 klist)
- "(elts-match-under-klist-p E1 E2 KLIST) => t or nil
+ "ELTS-MATCH-UNDER-KLIST-P E1 E2 KLIST => t or nil
KLIST encodes a keyword-arguments test, as in CH. 14 of CLtL.
True if elements E1 and E2 match under the tests encoded in KLIST."
- (let ((test (extract-from-klist klist :test))
- (test-not (extract-from-klist klist :test-not))
- (keyfn (extract-from-klist klist :key 'identity)))
- (if (and test test-not)
- (error "both :test and :test-not in `%s'"
- (prin1-to-string klist)))
- (cond (test
- (funcall test (funcall keyfn e1) (funcall keyfn e2)))
- (test-not
- (not (funcall test-not (funcall keyfn e1) (funcall keyfn e2))))
- (t ;should never happen
- (error "neither :test nor :test-not in `%s'"
- (prin1-to-string klist))))))
-
-;;; This macro simplifies using keyword args. It is less clumsy than using
-;;; the primitives build-klist, etc... For instance, member could be written
-;;; this way:
-
-;;; (defun member (item list &rest kargs)
-;;; (with-keyword-args kargs (test test-not (key 'identity))
-;;; ...))
-
-;;; Suggested by Robert Potter (potter@cs.rochester.edu, 15 Nov 1989)
-
-(defmacro with-keyword-args (keyargslist vardefs &rest body)
- "(WITH-KEYWORD-ARGS KEYARGSLIST VARDEFS . BODY)
-KEYARGSLIST can be either a symbol or a list of one or two symbols.
-In the second case, the second symbol is either T or NIL, indicating whether
-keywords other than the mentioned ones are tolerable.
-
-VARDEFS is a list. Each entry is either a VAR (symbol) or matches
-\(VAR [DEFAULT [KEYWORD]]). Just giving VAR is the same as giving
-\(VAR nil :VAR).
-
-The BODY is executed in an environment where each VAR (a symbol) is bound to
-the value present in the KEYARGSLIST provided, or to the DEFAULT. The value
-is searched by using the keyword form of VAR (i.e., :VAR) or the optional
-keyword if provided.
-
-Notice that this macro doesn't distinguish between a default value given
-explicitly by the user and one provided by default. See also the more
-primitive functions build-klist, add-to-klist, extract-from-klist,
-keyword-argument-supplied-p, elt-satisfies-test-p, elt-satisfies-if-p,
-elt-satisfies-if-not-p, elts-match-under-klist-p. They provide more complete,
-if clumsier, control over this feature."
- (let (allow-other-keys)
- (if (listp keyargslist)
- (if (> (length keyargslist) 2)
- (error
- "`%s' should be SYMBOL, (SYMBOL), or (SYMBOL t-OR-nil)"
- (prin1-to-string keyargslist))
- (setq allow-other-keys (cadr keyargslist)
- keyargslist (car keyargslist))
- (if (not (and
- (symbolp keyargslist)
- (memq allow-other-keys '(t nil))))
- (error
- "first subform should be SYMBOL, (SYMBOL), or (SYMBOL t-OR-nil)"
- )))
- (if (symbolp keyargslist)
- (setq allow-other-keys nil)
- (error
- "first subform should be SYMBOL, (SYMBOL), or (SYMBOL t-OR-nil)")))
- (let (vars defaults keywords forms
- (klistname (gensym "KLIST_")))
- (mapcar (function (lambda (entry)
- (if (symbolp entry) ;defaulty case
- (setq entry (list entry nil (keyword-of entry))))
- (let* ((l (length entry))
- (v (car entry))
- (d (cadr entry))
- (k (caddr entry)))
- (if (or (< l 1) (> l 3))
- (error
- "`%s' must match (VAR [DEFAULT [KEYWORD]])"
- (prin1-to-string entry)))
- (if (or (null v) (not (symbolp v)))
- (error
- "bad variable `%s': must be non-null symbol"
- (prin1-to-string v)))
- (setq vars (cons v vars))
- (setq defaults (cons d defaults))
- (if (< l 3)
- (setq k (keyword-of v)))
- (if (and (= l 3)
- (or (null k)
- (not (keywordp k))))
- (error
- "bad keyword `%s'" (prin1-to-string k)))
- (setq keywords (cons k keywords))
- (setq forms (cons (list v (list 'extract-from-klist
- klistname
- k
- d))
- forms)))))
- vardefs)
- (append
- (list 'let* (nconc (list (list klistname
- (list 'build-klist keyargslist
- (list 'quote keywords)
- allow-other-keys)))
- (nreverse forms)))
- body))))
-(put 'with-keyword-args 'lisp-indent-function 1)
-
-
-;;; REDUCE
-;;; It is here mostly as an example of how to use KLISTs.
-;;;
-;;; First of all, you need to declare the keywords (done elsewhere in this
-;;; file):
-;;; (defkeyword :from-end "syntax of sequence functions")
-;;; (defkeyword :start "syntax of sequence functions")
-;;; etc...
-;;;
-;;; Then, you capture all the possible keyword arguments with a &rest
-;;; argument. You can pass that list downward again, of course, but
-;;; internally you need to parse it into a KLIST (an alist, really). One uses
-;;; (build-klist REST-ARGS ACCEPTABLE-KEYWORDS [ALLOW-OTHER]). You can then
-;;; test for presence by using (keyword-argument-supplied-p KLIST KEY) and
-;;; extract a value with (extract-from-klist KLIST KEY [DEFAULT]).
-
-(defun reduce (function sequence &rest kargs)
- "Apply FUNCTION (a function of two arguments) to succesive pairs of elements
-from SEQUENCE. Some keyword arguments are valid after FUNCTION and SEQUENCE:
-:from-end If non-nil, process the values backwards
-:initial-value If given, prefix it to the SEQUENCE. Suffix, if :from-end
-:start Restrict reduction to the subsequence from this index
-:end Restrict reduction to the subsequence BEFORE this index.
-If the sequence is empty and no :initial-value is given, the FUNCTION is
-called on zero (not two) arguments. Otherwise, if there is exactly one
-element in the combination of SEQUENCE and the initial value, that element is
-returned."
- (let* ((klist (build-klist kargs '(:from-end :start :end :initial-value)))
- (length (length sequence))
- (from-end (extract-from-klist klist :from-end))
- (initial-value-given (keyword-argument-supplied-p
- klist :initial-value))
- (start (extract-from-klist kargs :start 0))
- (end (extract-from-klist kargs :end length)))
- (setq sequence (cl$subseq-as-list sequence start end))
- (if from-end
- (setq sequence (reverse sequence)))
- (if initial-value-given
- (setq sequence (cons (extract-from-klist klist :initial-value)
- sequence)))
- (if (null sequence)
- (funcall function) ;only use of 0 arguments
- (let* ((result (car sequence))
- (sequence (cdr sequence)))
- (while sequence
- (setq result (if from-end
- (funcall function (car sequence) result)
- (funcall function result (car sequence)))
- sequence (cdr sequence)))
- result))))
-
-(defun cl$subseq-as-list (sequence start end)
- "(cl$subseq-as-list SEQUENCE START END) => a list"
- (let ((list (append sequence nil))
- (length (length sequence))
- result)
- (if (< start 0)
- (error "start should be >= 0, not %d" start))
- (if (> end length)
- (error "end should be <= %d, not %d" length end))
- (if (and (zerop start) (= end length))
- list
- (let ((i start)
- (vector (apply 'vector list)))
- (while (/= i end)
- (setq result (cons (elt vector i) result))
- (setq i (+ i 1)))
- (nreverse result)))))
+ (let ((test (extract-from-klist :test klist))
+ (test-not (extract-from-klist :test-not klist))
+ (keyfn (extract-from-klist :key klist 'identity)))
+ (cond
+ (test
+ (funcall test (funcall keyfn e1) (funcall keyfn e2)))
+ (test-not
+ (not (funcall test-not (funcall keyfn e1) (funcall keyfn e2))))
+ (t ;should never happen
+ (error "Neither :test nor :test-not in `%s'"
+ (prin1-to-string klist))))))
;;;; end of cl-sequences.el
-;;;; Some functions with keyword arguments
-;;;;
-;;;; Both list and sequence functions are considered here together. This
-;;;; doesn't fit any more with the original split of functions in files.
-
-(defun member (item list &rest kargs)
- "Look for ITEM in LIST; return first tail of LIST the car of whose first
-cons cell tests the same as ITEM. Admits arguments :key, :test, and :test-not."
- (if (null kargs) ;treat this fast for efficiency
- (memq item list)
- (let* ((klist (build-klist kargs '(:test :test-not :key)))
- (test (extract-from-klist klist :test))
- (testnot (extract-from-klist klist :test-not))
- (key (extract-from-klist klist :key 'identity)))
- ;; another workaround allegledly for speed
- (if (and (or (eq test 'eq) (eq test 'eql)
- (eq test (symbol-function 'eq))
- (eq test (symbol-function 'eql)))
- (null testnot)
- (or (eq key 'identity) ;either by default or so given
- (eq key (function identity)) ;could this happen?
- (eq key (symbol-function 'identity)) ;sheer paranoia
- ))
- (memq item list)
- (if (and test testnot)
- (error ":test and :test-not both specified for member"))
- (if (not (or test testnot))
- (setq test 'eql))
- ;; final hack: remove the indirection through the function names
- (if testnot
- (if (symbolp testnot)
- (setq testnot (symbol-function testnot)))
- (if (symbolp test)
- (setq test (symbol-function test))))
- (if (symbolp key)
- (setq key (symbol-function key)))
- ;; ok, go for it
- (let ((ptr list)
- (done nil)
- (result '()))
- (if testnot
- (while (not (or done (endp ptr)))
- (cond ((not (funcall testnot item (funcall key (car ptr))))
- (setq done t)
- (setq result ptr)))
- (setq ptr (cdr ptr)))
- (while (not (or done (endp ptr)))
- (cond ((funcall test item (funcall key (car ptr)))
- (setq done t)
- (setq result ptr)))
- (setq ptr (cdr ptr))))
- result)))))
-
;;;; MULTIPLE VALUES
;;;; This package approximates the behavior of the multiple-values
;;;; forms of Common Lisp.
@@ -1543,12 +1233,15 @@ cons cell tests the same as ITEM. Admits arguments :key, :test, and :test-not."
;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986
;;;; (quiroz@cs.rochester.edu)
+
+
;;; Lisp indentation information
-(put 'multiple-value-bind 'lisp-indent-function 2)
-(put 'multiple-value-setq 'lisp-indent-function 2)
-(put 'multiple-value-list 'lisp-indent-function nil)
-(put 'multiple-value-call 'lisp-indent-function 1)
-(put 'multiple-value-prog1 'lisp-indent-function 1)
+(put 'multiple-value-bind 'lisp-indent-hook 2)
+(put 'multiple-value-setq 'lisp-indent-hook 2)
+(put 'multiple-value-list 'lisp-indent-hook nil)
+(put 'multiple-value-call 'lisp-indent-hook 1)
+(put 'multiple-value-prog1 'lisp-indent-hook 1)
+
;;; Global state of the package is kept here
(defvar *mvalues-values* nil
@@ -1573,6 +1266,7 @@ the first value."
(setq *mvalues-count* (length *mvalues-values*))
(car *mvalues-values*))
+
(defun values-list (&optional val-forms)
"Produce multiple values (zero or mode). Each element of LIST is one value.
This is equivalent to (apply 'values LIST)."
@@ -1582,6 +1276,7 @@ This is equivalent to (apply 'values LIST)."
(setq *mvalues-values* val-forms)
(setq *mvalues-count* (length *mvalues-values*))
(car *mvalues-values*))
+
;;; Callers that want to see the multiple values use these macros.
@@ -1665,7 +1360,7 @@ Forms a list of pairs `(,(nth i vars) (nth i vals)) for i from 0 to
the length of VARS (a list of symbols). VALS is just a fresh symbol."
(if (or (nlistp vars)
(notevery 'symbolp vars))
- (error "expected a list of symbols, not `%s'"
+ (error "Expected a list of symbols, not `%s'"
(prin1-to-string vars)))
(let* ((nvars (length vars))
(clauses '()))
@@ -1703,50 +1398,55 @@ the length of VARS (a list of symbols). VALS is just a fresh symbol."
(defun abs (number)
"Return the absolute value of NUMBER."
- (if (< number 0)
- (- number)
- number))
+ (cond
+ ((< number 0)
+ (- 0 number))
+ (t ;number is >= 0
+ number)))
(defun signum (number)
"Return -1, 0 or 1 according to the sign of NUMBER."
- (cond ((< number 0)
- -1)
- ((> number 0)
- 1)
- (t ;exactly zero
- 0)))
+ (cond
+ ((< number 0)
+ -1)
+ ((> number 0)
+ 1)
+ (t ;exactly zero
+ 0)))
(defun gcd (&rest integers)
"Return the greatest common divisor of all the arguments.
The arguments must be integers. With no arguments, value is zero."
(let ((howmany (length integers)))
- (cond ((= howmany 0)
- 0)
- ((= howmany 1)
- (abs (car integers)))
- ((> howmany 2)
- (apply (function gcd)
- (cons (gcd (nth 0 integers) (nth 1 integers))
- (nthcdr 2 integers))))
- (t ;howmany=2
- ;; essentially the euclidean algorithm
- (when (zerop (* (nth 0 integers) (nth 1 integers)))
- (error "a zero argument is invalid for `gcd'"))
- (do* ((absa (abs (nth 0 integers))) ; better to operate only
- (absb (abs (nth 1 integers))) ;on positives.
- (dd (max absa absb)) ; setup correct order for the
- (ds (min absa absb)) ;succesive divisions.
- ;; intermediate results
- (q 0)
- (r 0)
- ;; final results
- (done nil) ; flag: end of iterations
- (result 0)) ; final value
- (done result)
- (setq q (/ dd ds))
- (setq r (% dd ds))
- (cond ((zerop r) (setq done t) (setq result ds))
- (t (setq dd ds) (setq ds r))))))))
+ (cond
+ ((= howmany 0)
+ 0)
+ ((= howmany 1)
+ (abs (car integers)))
+ ((> howmany 2)
+ (apply (function gcd)
+ (cons (gcd (nth 0 integers) (nth 1 integers))
+ (nthcdr 2 integers))))
+ (t ;howmany=2
+ ;; essentially the euclidean algorithm
+ (when (zerop (* (nth 0 integers) (nth 1 integers)))
+ (error "A zero argument is invalid for `gcd'"))
+ (do* ((absa (abs (nth 0 integers))) ; better to operate only
+ (absb (abs (nth 1 integers))) ;on positives.
+ (dd (max absa absb)) ; setup correct order for the
+ (ds (min absa absb)) ;succesive divisions.
+ ;; intermediate results
+ (q 0)
+ (r 0)
+ ;; final results
+ (done nil) ; flag: end of iterations
+ (result 0)) ; final value
+ (done result)
+ (setq q (/ dd ds))
+ (setq r (% dd ds))
+ (cond
+ ((zerop r) (setq done t) (setq result ds))
+ ( t (setq dd ds) (setq ds r))))))))
(defun lcm (integer &rest more)
"Return the least common multiple of all the arguments.
@@ -1756,43 +1456,48 @@ The arguments must be integers and there must be at least one of them."
(b (nth 0 more))
prod ; intermediate product
(yetmore (nthcdr 1 more)))
- (cond ((zerop howmany)
- (abs a))
- ((> howmany 1) ; recursive case
- (apply (function lcm)
- (cons (lcm a b) yetmore)))
- (t ; base case, just 2 args
- (setq prod (* a b))
- (cond
- ((zerop prod)
- 0)
- (t
- (/ (abs prod) (gcd a b))))))))
+ (cond
+ ((zerop howmany)
+ (abs a))
+ ((> howmany 1) ; recursive case
+ (apply (function lcm)
+ (cons (lcm a b) yetmore)))
+ (t ; base case, just 2 args
+ (setq prod (* a b))
+ (cond
+ ((zerop prod)
+ 0)
+ (t
+ (/ (abs prod) (gcd a b))))))))
(defun isqrt (number)
"Return the integer square root of NUMBER.
NUMBER must not be negative. Result is largest integer less than or
equal to the real square root of the argument."
- ;; The method used here is essentially the Newtonian iteration
- ;; x[n+1] <- (x[n] + Number/x[n]) / 2
- ;; suitably adapted to integer arithmetic.
- ;; Thanks to Philippe Schnoebelen <phs@lifia.imag.fr> for suggesting the
- ;; termination condition.
- (cond ((minusp number)
- (error "argument to `isqrt' (%d) must not be negative"
- number))
- ((zerop number)
- 0)
- (t ;so (>= number 0)
- (do* ((approx 1) ;any positive integer will do
- (new 0) ;init value irrelevant
- (done nil))
- (done (if (> (* approx approx) number)
- (- approx 1)
- approx))
- (setq new (/ (+ approx (/ number approx)) 2)
- done (or (= new approx) (= new (+ approx 1)))
- approx new)))))
+ (cond
+ ((minusp number)
+ (error "Argument to `isqrt' must not be negative"))
+ ((zerop number)
+ 0)
+ ((<= number 3)
+ 1)
+ (t
+ ;; This is some sort of newtonian iteration, trying not to get in
+ ;; an infinite loop. That's why I catch 0, 1, 2 and 3 as special
+ ;; cases, so then rounding won't make this iteration loop.
+ (do* ((approx (/ number 2) iter)
+ (done nil)
+ (iter 0))
+ (done (if (> (* approx approx) number)
+ (- approx 1) ;reached from above
+ approx))
+ (setq iter
+ (/ (+ approx
+ (/ number approx)
+ (if (>= (% number approx) (/ approx 2))
+ 1 0))
+ 2))
+ (setq done (eql approx iter))))))
(defun floor (number &optional divisor)
"Divide DIVIDEND by DIVISOR, rounding toward minus infinity.
@@ -1805,15 +1510,16 @@ DIVISOR defaults to 1. The remainder is produced as a second value."
(multiple-value-bind
(q r s)
(safe-idiv number divisor)
- (cond ((zerop s)
- (values 0 0))
- ((plusp s)
- (values q r))
- (t ;opposite-signs case
- (if (zerop r)
- (values (- q) 0)
- (let ((q (- (+ q 1))))
- (values q (- number (* q divisor)))))))))))
+ (cond
+ ((zerop s)
+ (values 0 0))
+ ((plusp s)
+ (values q r))
+ (t
+ (unless (zerop r)
+ (setq q (- 0 (+ q 1)))
+ (setq r (- number (* q divisor))))
+ (values q r)))))))
(defun ceiling (number &optional divisor)
"Divide DIVIDEND by DIVISOR, rounding toward plus infinity.
@@ -1826,12 +1532,16 @@ DIVISOR defaults to 1. The remainder is produced as a second value."
(multiple-value-bind
(q r s)
(safe-idiv number divisor)
- (cond ((zerop s)
- (values 0 0))
- ((plusp s)
- (values (+ q 1) (- r divisor)))
- (t
- (values (- q) (+ number (* q divisor)))))))))
+ (cond
+ ((zerop s)
+ (values 0 0))
+ ((minusp s)
+ (values q r))
+ (t
+ (unless (zerop r)
+ (setq q (+ q 1))
+ (setq r (- number (* q divisor))))
+ (values q r)))))))
(defun truncate (number &optional divisor)
"Divide DIVIDEND by DIVISOR, rounding toward zero.
@@ -1844,35 +1554,41 @@ DIVISOR defaults to 1. The remainder is produced as a second value."
(multiple-value-bind
(q r s)
(safe-idiv number divisor)
- (cond ((zerop s)
- (values 0 0))
- ((plusp s) ;same as floor
- (values q r))
- (t ;same as ceiling
- (values (- q) (+ number (* q divisor)))))))))
+ (cond
+ ((zerop s)
+ (values 0 0))
+ ((plusp s)
+ (values q r))
+ (t
+ (unless (zerop r)
+ (setq q (- 0 q))
+ (setq r (- number (* q divisor))))
+ (values q r)))))))
(defun round (number &optional divisor)
"Divide DIVIDEND by DIVISOR, rounding to nearest integer.
DIVISOR defaults to 1. The remainder is produced as a second value."
- (cond ((and (null divisor) ; trivial case
- (numberp number))
- (values number 0))
- (t ; do the division
- (multiple-value-bind
- (q r s)
- (safe-idiv number divisor)
- (setq r (abs r))
- ;; adjust magnitudes first, and then signs
- (let ((other-r (- (abs divisor) r)))
- (cond ((> r other-r)
- (setq q (+ q 1)))
- ((and (= r other-r)
- (oddp q))
- ;; round to even is mandatory
- (setq q (+ q 1))))
- (setq q (* s q))
- (setq r (- number (* q divisor)))
- (values q r))))))
+ (cond
+ ((and (null divisor) ; trivial case
+ (numberp number))
+ (values number 0))
+ (t ; do the division
+ (multiple-value-bind
+ (q r s)
+ (safe-idiv number divisor)
+ (setq r (abs r))
+ ;; adjust magnitudes first, and then signs
+ (let ((other-r (- (abs divisor) r)))
+ (cond
+ ((> r other-r)
+ (setq q (+ q 1)))
+ ((and (= r other-r)
+ (oddp q))
+ ;; round to even is mandatory
+ (setq q (+ q 1))))
+ (setq q (* s q))
+ (setq r (- number (* q divisor)))
+ (values q r))))))
(defun mod (number divisor)
"Return remainder of X by Y (rounding quotient toward minus infinity).
@@ -1893,15 +1609,13 @@ That is, the remainder goes with the quotient produced by `truncate'."
;;; computations when working with negatives, so the idea here is to
;;; make sure we know what is coming back to the caller in all cases.
-;;; Signum computation fixed by mad@math.keio.JUNET (MAEDA Atusi)
-
(defun safe-idiv (a b)
"SAFE-IDIV A B => Q R S
Q=|A|/|B|, R is the rest, S is the sign of A/B."
(unless (and (numberp a) (numberp b))
- (error "arguments to `safe-idiv' must be numbers"))
+ (error "Arguments to `safe-idiv' must be numbers"))
(when (zerop b)
- (error "cannot divide %d by zero" a))
+ (error "Cannot divide %d by zero" a))
(let* ((absa (abs a))
(absb (abs b))
(q (/ absa absb))
@@ -1938,54 +1652,55 @@ than one PLACE and VALUE, each PLACE is set from its VALUE before
the next PLACE is evaluated."
(let ((nforms (length pairs)))
;; check the number of subforms
- (cond ((/= (% nforms 2) 0)
- (error "odd number of arguments to `setf'"))
- ((= nforms 0)
- nil)
- ((> nforms 2)
- ;; this is the recursive case
- (cons 'progn
- (do* ;collect the place-value pairs
- ((args pairs (cddr args))
- (place (car args) (car args))
- (value (cadr args) (cadr args))
- (result '()))
- ((endp args) (nreverse result))
- (setq result
- (cons (list 'setf place value)
- result)))))
- (t ;i.e., nforms=2
- ;; this is the base case (SETF PLACE VALUE)
- (let* ((place (car pairs))
- (value (cadr pairs))
- (head nil)
- (updatefn nil))
- ;; dispatch on the type of the PLACE
- (cond ((symbolp place)
- (list 'setq place value))
- ((and (listp place)
- (setq head (car place))
- (symbolp head)
- (setq updatefn (get head :setf-update-fn)))
- (if (or (and (consp updatefn) (eq (car updatefn) 'lambda))
- (and (symbolp updatefn)
- (fboundp updatefn)
- (let ((defn (symbol-function updatefn)))
- (or (subrp defn)
- (and (consp defn)
- (eq (car defn) 'lambda))))))
- (cons updatefn (append (cdr place) (list value)))
- (multiple-value-bind
- (bindings newsyms)
- (pair-with-newsyms (append (cdr place) (list value)))
- ;; this let gets new symbols to ensure adequate
- ;; order of evaluation of the subforms.
- (list 'let
- bindings
- (cons updatefn newsyms)))))
- (t
- (error "no `setf' update-function for `%s'"
- (prin1-to-string place)))))))))
+ (cond
+ ((/= (% nforms 2) 0)
+ (error "Odd number of arguments to `setf'"))
+ ((= nforms 0)
+ nil)
+ ((> nforms 2)
+ ;; this is the recursive case
+ (cons 'progn
+ (do* ;collect the place-value pairs
+ ((args pairs (cddr args))
+ (place (car args) (car args))
+ (value (cadr args) (cadr args))
+ (result '()))
+ ((endp args) (nreverse result))
+ (setq result
+ (cons (list 'setf place value)
+ result)))))
+ (t ;i.e., nforms=2
+ ;; this is the base case (SETF PLACE VALUE)
+ (let* ((place (car pairs))
+ (value (cadr pairs))
+ (head nil)
+ (updatefn nil))
+ ;; dispatch on the type of the PLACE
+ (cond
+ ((symbolp place)
+ (list 'setq place value))
+ ((and (listp place)
+ (setq head (car place))
+ (symbolp head)
+ (setq updatefn (get head :setf-update-fn)))
+ (if (or (and (consp updatefn) (eq (car updatefn) 'lambda))
+ (and (symbolp updatefn)
+ (fboundp updatefn)
+ (let ((defn (symbol-function updatefn)))
+ (or (subrp defn)
+ (and (consp defn) (eq (car defn) 'lambda))))))
+ (cons updatefn (append (cdr place) (list value)))
+ (multiple-value-bind
+ (bindings newsyms)
+ (pair-with-newsyms (append (cdr place) (list value)))
+ ;; this let* gets new symbols to ensure adequate order of
+ ;; evaluation of the subforms.
+ (list 'let
+ bindings
+ (cons updatefn newsyms)))))
+ (t
+ (error "No `setf' update-function for `%s'"
+ (prin1-to-string place)))))))))
(defmacro defsetf (accessfn updatefn &optional docstring)
"Define how `setf' works on a certain kind of generalized variable.
@@ -1998,15 +1713,11 @@ updating called for."
;; reject ill-formed requests. too bad one can't test for functionp
;; or macrop.
(when (not (symbolp accessfn))
- (error "first argument of `defsetf' must be a symbol, not `%s'"
+ (error "First argument of `defsetf' must be a symbol, not `%s'"
(prin1-to-string accessfn)))
;; update properties
- (list 'progn
- (list 'put (list 'quote accessfn)
- :setf-update-fn (list 'function updatefn))
- (list 'put (list 'quote accessfn) :setf-update-doc docstring)
- ;; any better thing to return?
- (list 'quote accessfn)))
+ (put accessfn :setf-update-fn updatefn)
+ (put accessfn :setf-update-doc docstring))
;;; This section provides the "default" setfs for Common-Emacs-Lisp
;;; The user will not normally add anything to this, although
@@ -2035,11 +1746,14 @@ updating called for."
(apply 'list* (butlast (cdr args)))
(last args)))
(newupdater nil)) ; its update-fn, if any
- (if (and (symbolp fnform)
- (setq newupdater (get fnform :setf-update-fn)))
- (apply newupdater applyargs)
- (error "can't `setf' to `%s'"
- (prin1-to-string fnform)))))
+ (cond
+ ((and (symbolp fnform)
+ (setq newupdater (get fnform :setf-update-fn)))
+ ;; just do it
+ (apply newupdater applyargs))
+ (t
+ (error "Can't `setf' to `%s'"
+ (prin1-to-string fnform))))))
"`apply' is a special case for `setf'")
@@ -2219,21 +1933,22 @@ updating called for."
(lambda (list val) (setcdr (cddr list) val))
"`setf' inversion for `cddddr'")
-(defsetf get put "`setf' inversion for `get' is `put'")
+
+(defsetf get
+ put
+ "`setf' inversion for `get' is `put'")
-(defsetf symbol-function fset
+(defsetf symbol-function
+ fset
"`setf' inversion for `symbol-function' is `fset'")
-(defsetf symbol-plist setplist
+(defsetf symbol-plist
+ setplist
"`setf' inversion for `symbol-plist' is `setplist'")
-(defsetf symbol-value set
+(defsetf symbol-value
+ set
"`setf' inversion for `symbol-value' is `set'")
-
-(defsetf point goto-char
- "To set (point) to N, use (goto-char N)")
-
-;; how about defsetfing other Emacs forms?
;;; Modify macros
;;;
@@ -2275,39 +1990,31 @@ updating called for."
;;; sides. The evaluations are done in an environment where they
;;; appear to occur in parallel.
-(defmacro psetf (&rest body)
- "(psetf {var value }...) => nil
-Like setf, but all the values are computed before any assignment is made."
- (let ((length (length body)))
- (cond ((/= (% length 2) 0)
- (error "psetf needs an even number of arguments, %d given"
- length))
- ((null body)
- '())
- (t
- (list 'prog1 nil
- (let ((setfs '())
- (bodyforms (reverse body)))
- (while bodyforms
- (let* ((value (car bodyforms))
- (place (cadr bodyforms)))
- (setq bodyforms (cddr bodyforms))
- (if (null setfs)
- (setq setfs (list 'setf place value))
- (setq setfs (list 'setf place
- (list 'prog1 value
- setfs))))))
- setfs))))))
+(defmacro psetf (&rest pairs)
+ "(psetf {PLACE VALUE}...): Set several generalized variables in parallel.
+All the VALUEs are computed, and then all the PLACEs are stored as in `setf'.
+See also `psetq', `shiftf' and `rotatef'."
+ (unless (evenp (length pairs))
+ (error "Odd number of arguments to `psetf'"))
+ (multiple-value-bind
+ (places forms)
+ (unzip-list pairs)
+ ;; obtain fresh symbols to simulate the parallelism
+ (multiple-value-bind
+ (bindings newsyms)
+ (pair-with-newsyms forms)
+ (list 'let
+ bindings
+ (cons 'setf (zip-lists places newsyms))
+ nil))))
;;; SHIFTF and ROTATEF
;;;
(defmacro shiftf (&rest forms)
- "(shiftf PLACE1 PLACE2... NEWVALUE)
-Set PLACE1 to PLACE2, PLACE2 to PLACE3...
+ "(shiftf PLACE1 PLACE2... NEWVALUE): set PLACE1 to PLACE2, PLACE2 to PLACE3...
Each PLACE is set to the old value of the following PLACE,
-and the last PLACE is set to the value NEWVALUE.
-Returns the old value of PLACE1."
+and the last PLACE is set to the value NEWVALUE."
(unless (> (length forms) 1)
(error "`shiftf' needs more than one argument"))
(let ((places (butlast forms))
@@ -2325,18 +2032,20 @@ Returns the old value of PLACE1."
(defmacro rotatef (&rest places)
"(rotatef PLACE...) sets each PLACE to the old value of the following PLACE.
The last PLACE is set to the old value of the first PLACE.
-Thus, the values rotate through the PLACEs. Returns nil."
- (if (null places)
- nil
- (multiple-value-bind
- (bindings newsyms)
- (pair-with-newsyms places)
- (list
- 'let bindings
- (cons 'setf
- (zip-lists places
- (append (cdr newsyms) (list (car newsyms)))))
- nil))))
+Thus, the values rotate through the PLACEs."
+ (cond
+ ((null places)
+ nil)
+ (t
+ (multiple-value-bind
+ (bindings newsyms)
+ (pair-with-newsyms places)
+ (list
+ 'let bindings
+ (cons 'setf
+ (zip-lists places
+ (append (cdr newsyms) (list (car newsyms)))))
+ nil)))))
;;;; STRUCTS
;;;; This file provides the structures mechanism. See the
@@ -2364,27 +2073,16 @@ Thus, the values rotate through the PLACEs. Returns nil."
(defkeyword :structure-slots "List of the slot's names")
(defkeyword :structure-indices "List of (KEYWORD-NAME . INDEX)")
(defkeyword :structure-initforms "List of (KEYWORD-NAME . INITFORM)")
-(defkeyword :structure-includes
- "() or list of a symbol, that this struct includes")
-(defkeyword :structure-included-in
- "List of the structs that include this")
(defmacro defstruct (&rest args)
"(defstruct NAME [DOC-STRING] . SLOTS) define NAME as structure type.
NAME must be a symbol, the name of the new structure. It could also
-be a list (NAME . OPTIONS).
-
-Each option is either a symbol, or a list of a keyword symbol taken from the
-list \{:conc-name, :copier, :constructor, :predicate, :include,
-:print-function, :type, :initial-offset\}. The meanings of these are as in
-CLtL, except that no BOA-constructors are provided, and the options
-\{:print-fuction, :type, :initial-offset\} are ignored quietly. All these
-structs are named, in the sense that their names can be used for type
-discrimination.
-
-The DOC-STRING is established as the `structure-doc' property of NAME.
-
+be a list (NAME . OPTIONS), but not all options are supported currently.
+As of Dec. 1986, this is supporting :conc-name, :copier and :predicate
+completely, :include arguably completely and :constructor only to
+change the name of the default constructor. No BOA constructors allowed.
+The DOC-STRING is established as the 'structure-doc' property of NAME.
The SLOTS are one or more of the following:
SYMBOL -- meaning the SYMBOL is the name of a SLOT of NAME
list of SYMBOL and VALUE -- meaning that VALUE is the initial value of
@@ -2398,11 +2096,10 @@ them. `setf' of the accessors sets their values."
;; Names for the member functions come from the options. The
;; slots* stuff collects info about the slots declared explicitly.
(multiple-value-bind
- (conc-name constructor copier predicate
- moreslotsn moreslots moreinits included)
+ (conc-name constructor copier predicate moreslotsn moreslots moreinits)
(parse$defstruct$options name options slots)
;; The moreslots* stuff refers to slots gained as a consequence
- ;; of (:include clauses). -- Oct 89: Only one :include tolerated
+ ;; of (:include clauses).
(when (and (numberp moreslotsn)
(> moreslotsn 0))
(setf slotsn (+ slotsn moreslotsn))
@@ -2419,74 +2116,18 @@ them. `setf' of the accessors sets their values."
(let (properties functions keywords accessors alterators returned)
;; compute properties of NAME
(setq properties
- (append
- (list
- (list 'put (list 'quote name) :structure-doc
- docstring)
- (list 'put (list 'quote name) :structure-slotsn
- slotsn)
- (list 'put (list 'quote name) :structure-slots
- (list 'quote slots))
- (list 'put (list 'quote name) :structure-initforms
- (list 'quote initlist))
- (list 'put (list 'quote name) :structure-indices
- (list 'quote (extract$indices initlist))))
- ;; If this definition :includes another defstruct,
- ;; modify both property lists.
- (cond (included
- (list
- (list 'put
- (list 'quote name)
- :structure-includes
- (list 'quote included))
- (list 'pushnew
- (list 'quote name)
- (list 'get (list 'quote (car included))
- :structure-included-in))))
- (t
- (list
- (let ((old (gensym)))
- (list 'let
- (list (list old
- (list 'car
- (list 'get
- (list 'quote name)
- :structure-includes))))
- (list 'when old
- (list 'put
- old
- :structure-included-in
- (list 'delq
- (list 'quote name)
- ;; careful with destructive
- ;;manipulation!
- (list
- 'append
- (list
- 'get
- old
- :structure-included-in)
- '())
- )))))
- (list 'put
- (list 'quote name)
- :structure-includes
- '()))))
- ;; If this definition used to be :included in another, warn
- ;; that things make break. On the other hand, the redefinition
- ;; may be trivial, so don't call it an error.
- (let ((old (gensym)))
- (list
- (list 'let
- (list (list old (list 'get
- (list 'quote name)
- :structure-included-in)))
- (list 'when old
- (list 'message
- "`%s' redefined. Should redefine `%s'?"
- (list 'quote name)
- (list 'prin1-to-string old))))))))
-
+ (list
+ (list 'put (list 'quote name) :structure-doc
+ docstring)
+ (list 'put (list 'quote name) :structure-slotsn
+ slotsn)
+ (list 'put (list 'quote name) :structure-slots
+ (list 'quote slots))
+ (list 'put (list 'quote name) :structure-initforms
+ (list 'quote initlist))
+ (list 'put (list 'quote name) :structure-indices
+ (list 'quote (extract$indices initlist)))))
+
;; Compute functions associated with NAME. This is not
;; handling BOA constructors yet, but here would be the place.
(setq functions
@@ -2500,34 +2141,18 @@ them. `setf' of the accessors sets their values."
(list 'fset (list 'quote copier)
(list 'function
(list 'lambda (list 'struct)
- (list 'copy-sequence 'struct))))
- (let ((typetag (gensym)))
- (list 'fset (list 'quote predicate)
- (list
- 'function
- (list
- 'lambda (list 'thing)
- (list 'and
- (list 'vectorp 'thing)
- (list 'let
- (list (list typetag
- (list 'elt 'thing 0)))
- (list 'or
- (list
- 'and
- (list 'eq
- typetag
- (list 'quote name))
- (list '=
- (list 'length 'thing)
- (1+ slotsn)))
- (list
- 'memq
- typetag
- (list 'get
- (list 'quote name)
- :structure-included-in))))))
- )))))
+ (list 'copy-vector 'struct))))
+ (list 'fset (list 'quote predicate)
+ (list 'function
+ (list 'lambda (list 'thing)
+ (list 'and
+ (list 'vectorp 'thing)
+ (list 'eq
+ (list 'elt 'thing 0)
+ (list 'quote name))
+ (list '=
+ (list 'length 'thing)
+ (1+ slotsn))))))))
;; compute accessors for NAME's slots
(multiple-value-setq
(accessors alterators keywords)
@@ -2545,7 +2170,7 @@ them. `setf' of the accessors sets their values."
accessors alterators returned))))))
(defun parse$defstruct$args (args)
- "(parse$defstruct$args ARGS) => NAME OPTIONS DOCSTRING SLOTSN SLOTS INITLIST
+ "PARSE$DEFSTRUCT$ARGS ARGS => NAME OPTIONS DOCSTRING SLOTSN SLOTS INITLIST
NAME=symbol, OPTIONS=list of, DOCSTRING=string, SLOTSN=count of slots,
SLOTS=list of their names, INITLIST=alist (keyword . initform)."
(let (name ;args=(symbol...) or ((symbol...)...)
@@ -2556,15 +2181,16 @@ SLOTS=list of their names, INITLIST=alist (keyword . initform)."
(slots '()) ;list of slot names
(initlist '())) ;list of (slot keyword . initform)
;; extract name and options
- (cond ((symbolp (car args)) ;simple name
- (setq name (car args)
- options '()))
- ((and (listp (car args)) ;(name . options)
- (symbolp (caar args)))
- (setq name (caar args)
- options (cdar args)))
- (t
- (error "first arg to `defstruct' must be symbol or (symbol ...)")))
+ (cond
+ ((symbolp (car args)) ;simple name
+ (setq name (car args)
+ options '()))
+ ((and (listp (car args)) ;(name . options)
+ (symbolp (caar args)))
+ (setq name (caar args)
+ options (cdar args)))
+ (t
+ (error "First arg to `defstruct' must be symbol or (symbol ...)")))
(setq slotargs (cdr args))
;; is there a docstring?
(when (stringp (car slotargs))
@@ -2577,7 +2203,7 @@ SLOTS=list of their names, INITLIST=alist (keyword . initform)."
(values name options docstring slotsn slots initlist))))
(defun process$slots (slots)
- "(process$slots SLOTS) => SLOTSN SLOTSLIST INITLIST
+ "PROCESS$SLOTS SLOTS => SLOTSN SLOTSLIST INITLIST
Converts a list of symbols or lists of symbol and form into the last 3
values returned by PARSE$DEFSTRUCT$ARGS."
(let ((slotsn (length slots)) ;number of slots
@@ -2587,35 +2213,28 @@ values returned by PARSE$DEFSTRUCT$ARGS."
((ptr slots (cdr ptr))
(this (car ptr) (car ptr)))
((endp ptr))
- (cond ((symbolp this)
- (setq slotslist (cons this slotslist))
- (setq initlist (acons (keyword-of this) nil initlist)))
- ((and (listp this)
- (symbolp (car this)))
- (let ((name (car this))
- (form (cadr this)))
- ;; this silently ignores any slot options. bad...
- (setq slotslist (cons name slotslist))
- (setq initlist (acons (keyword-of name) form initlist))))
- (t
- (error "slot should be symbol or (symbol ...), not `%s'"
- (prin1-to-string this)))))
+ (cond
+ ((symbolp this)
+ (setq slotslist (cons this slotslist))
+ (setq initlist (acons (keyword-of this) nil initlist)))
+ ((and (listp this)
+ (symbolp (car this)))
+ (let ((name (car this))
+ (form (cadr this)))
+ ;; this silently ignores any slot options. bad...
+ (setq slotslist (cons name slotslist))
+ (setq initlist (acons (keyword-of name) form initlist))))
+ (t
+ (error "Slot should be symbol or (symbol ...), not `%s'"
+ (prin1-to-string this)))))
(values slotsn (nreverse slotslist) (nreverse initlist))))
(defun parse$defstruct$options (name options slots)
- "(parse$defstruct$options name OPTIONS SLOTS) => many values
-A defstruct named NAME, with options list OPTIONS, has already slots SLOTS.
-Parse the OPTIONS and return the updated form of the struct's slots and other
-information. The values returned are:
-
- CONC-NAME is the string to use as prefix/suffix in the methods,
- CONST is the name of the official constructor,
- COPIER is the name of the structure copier,
- PRED is the name of the type predicate,
- MORESLOTSN is the number of slots added by :include,
- MORESLOTS is the list of slots added by :include,
- MOREINITS is the list of initialization forms added by :include,
- INCLUDED is nil, or the list of the symbol added by :include"
+ "PARSE$DEFSTRUCT$OPTIONS NAME OPTIONS SLOTS => CONC-NAME CONST COPIER PRED
+Returns at least those 4 values (a string and 3 symbols, to name the necessary
+functions), might return also things discovered by actually
+inspecting the options, namely MORESLOTSN MORESLOTS MOREINITS, as can
+be created by :include, and perhaps a list of BOACONSTRUCTORS."
(let* ((namestring (symbol-name name))
;; to build the return values
(conc-name (concat namestring "-"))
@@ -2632,7 +2251,6 @@ information. The values returned are:
these-slotsn ;When :include is found, the
these-slots ; info about the included
these-inits ; structure is added here.
- included ;NIL or (list INCLUDED)
)
;; Values above are the defaults. Now we read the options themselves
(dolist (option options)
@@ -2643,7 +2261,7 @@ information. The values returned are:
(:named
) ;ignore silently
(t
- (error "can't recognize option `%s'"
+ (error "Can't recognize option `%s'"
(prin1-to-string option)))))
((and (listp option)
(keywordp (setq option-head (car option))))
@@ -2667,7 +2285,7 @@ information. The values returned are:
(null option-rest))
option-second)
(t
- (error "can't recognize option `%s'"
+ (error "Can't recognize option `%s'"
(prin1-to-string option))))))
(:constructor ;no BOA-constructors allowed
@@ -2677,7 +2295,7 @@ information. The values returned are:
(null option-rest))
option-second)
(t
- (error "can't recognize option `%s'"
+ (error "Can't recognize option `%s'"
(prin1-to-string option))))))
(:predicate
(setq pred
@@ -2686,11 +2304,11 @@ information. The values returned are:
(null option-rest))
option-second)
(t
- (error "can't recognize option `%s'"
+ (error "Can't recognize option `%s'"
(prin1-to-string option))))))
(:include
(unless (symbolp option-second)
- (error "arg to `:include' should be a symbol, not `%s'"
+ (error "Arg to `:include' should be a symbol, not `%s'"
(prin1-to-string option-second)))
(setq these-slotsn (get option-second :structure-slotsn)
these-slots (get option-second :structure-slots)
@@ -2699,10 +2317,6 @@ information. The values returned are:
(> these-slotsn 0))
(error "`%s' is not a valid structure"
(prin1-to-string option-second)))
- (if included
- (error "`%s' already includes `%s', can't include `%s' too"
- name (car included) option-second)
- (push option-second included))
(multiple-value-bind
(xtra-slotsn xtra-slots xtra-inits)
(process$slots option-rest)
@@ -2719,18 +2333,17 @@ information. The values returned are:
((:print-function :type :initial-offset)
) ;ignore silently
(t
- (error "can't recognize option `%s'"
+ (error "Can't recognize option `%s'"
(prin1-to-string option)))))
(t
- (error "can't recognize option `%s'"
+ (error "Can't recognize option `%s'"
(prin1-to-string option)))))
;; Return values found
(values conc-name const copier pred
- moreslotsn moreslots moreinits
- included)))
+ moreslotsn moreslots moreinits)))
(defun simplify$inits (slots initlist)
- "(simplify$inits SLOTS INITLIST) => new INITLIST
+ "SIMPLIFY$INITS SLOTS INITLIST => new INITLIST
Removes from INITLIST - an ALIST - any shadowed bindings."
(let ((result '()) ;built here
key ;from the slot
@@ -2741,7 +2354,7 @@ Removes from INITLIST - an ALIST - any shadowed bindings."
(nreverse result)))
(defun extract$indices (initlist)
- "(extract$indices INITLIST) => indices list
+ "EXTRACT$INDICES INITLIST => indices list
Kludge. From a list of pairs (keyword . form) build a list of pairs
of the form (keyword . position in list from 0). Useful to precompute
some of the work of MAKE$STRUCTURE$INSTANCE."
@@ -2752,7 +2365,7 @@ some of the work of MAKE$STRUCTURE$INSTANCE."
index (+ index 1)))))
(defun build$accessors$for (name conc-name predicate slots slotsn)
- "(build$accessors$for NAME PREDICATE SLOTS SLOTSN) => FSETS DEFSETFS KWDS
+ "BUILD$ACCESSORS$FOR NAME PREDICATE SLOTS SLOTSN => FSETS DEFSETFS KWDS
Generate the code for accesors and defsetfs of a structure called
NAME, whose slots are SLOTS. Also, establishes the keywords for the
slots names."
@@ -2775,7 +2388,7 @@ slots names."
(list 'aref 'object (1+ i)))
(list 't
(list 'error
- "`%s' is not a struct %s"
+ "`%s' not a %s."
(list 'prin1-to-string
'object)
(list 'prin1-to-string
@@ -2803,7 +2416,7 @@ slots names."
keywords))))
(defun make$structure$instance (name args)
- "(make$structure$instance NAME ARGS) => new struct NAME
+ "MAKE$STRUCTURE$INSTANCE NAME ARGS => new struct NAME
A struct of type NAME is created, some slots might be initialized
according to ARGS (the &rest argument of MAKE-name)."
(unless (symbolp name)
@@ -2821,7 +2434,7 @@ according to ARGS (the &rest argument of MAKE-name)."
(error "`%s' is not a defined structure"
(prin1-to-string name)))
(unless (evenp (length args))
- (error "slot initializers `%s' not of even length"
+ (error "Slot initializers `%s' not of even length"
(prin1-to-string args)))
;; analyze the initializers provided by the call
(multiple-value-bind
@@ -2829,7 +2442,7 @@ according to ARGS (the &rest argument of MAKE-name)."
(unzip-list args) ; by the user
;; check that all the arguments are introduced by keywords
(unless (every (function keywordp) speckwds)
- (error "all of the names in `%s' should be keywords"
+ (error "All of the names in `%s' should be keywords"
(prin1-to-string speckwds)))
;; check that all the keywords are known
(dolist (kwd speckwds)
@@ -2862,276 +2475,5 @@ according to ARGS (the &rest argument of MAKE-name)."
(cons name initializers)))))
;;;; end of cl-structs.el
-
-;;; For lisp-interaction mode, so that multiple values can be seen when passed
-;;; back. Lies every now and then...
-
-(defvar - nil "form currently under evaluation")
-(defvar + nil "previous -")
-(defvar ++ nil "previous +")
-(defvar +++ nil "previous ++")
-(defvar / nil "list of values returned by +")
-(defvar // nil "list of values returned by ++")
-(defvar /// nil "list of values returned by +++")
-(defvar * nil "(first) value of +")
-(defvar ** nil "(first) value of ++")
-(defvar *** nil "(first) value of +++")
-
-(defun cl-eval-print-last-sexp ()
- "Evaluate sexp before point; print value\(s\) into current buffer.
-If the evaled form returns multiple values, they are shown one to a line.
-The variables -, +, ++, +++, *, **, ***, /, //, /// have their usual meaning.
-
-It clears the multiple-value passing mechanism, and does not pass back
-multiple values. Use this only if you are debugging cl.el and understand well
-how the multiple-value stuff works, because it can be fooled into believing
-that multiple values have been returned when they actually haven't, for
-instance
- \(identity \(values nil 1\)\)
-However, even when this fails, you can trust the first printed value to be
-\(one of\) the returned value\(s\)."
- (interactive)
- ;; top level call, can reset mvalues
- (setq *mvalues-count* nil
- *mvalues-values* nil)
- (setq - (car (read-from-string
- (buffer-substring
- (let ((stab (syntax-table)))
- (unwind-protect
- (save-excursion
- (set-syntax-table emacs-lisp-mode-syntax-table)
- (forward-sexp -1)
- (point))
- (set-syntax-table stab)))
- (point)))))
- (setq *** **
- ** *
- * (eval -))
- (setq /// //
- // /
- / *mvalues-values*)
- (setq +++ ++
- ++ +
- + -)
- (cond ((or (null *mvalues-count*) ;mvalues mechanism not used
- (not (eq * (car *mvalues-values*))))
- (print * (current-buffer)))
- ((null /) ;no values returned
- (terpri (current-buffer)))
- (t ;more than zero mvalues
- (terpri (current-buffer))
- (mapcar (function (lambda (value)
- (prin1 value (current-buffer))
- (terpri (current-buffer))))
- /)))
- (setq *mvalues-count* nil ;make sure
- *mvalues-values* nil))
-
-;;;; More LISTS functions
-;;;;
-
-;;; Some mapping functions on lists, commonly useful.
-;;; They take no extra sequences, to go along with Emacs Lisp's MAPCAR.
-
-(defun mapc (function list)
- "(MAPC FUNCTION LIST) => LIST
-Apply FUNCTION to each element of LIST, return LIST.
-Like mapcar, but called only for effect."
- (let ((args list))
- (while args
- (funcall function (car args))
- (setq args (cdr args))))
- list)
-
-(defun maplist (function list)
- "(MAPLIST FUNCTION LIST) => list'ed results of FUNCTION on cdrs of LIST
-Apply FUNCTION to successive sublists of LIST, return the list of the results"
- (let ((args list)
- results '())
- (while args
- (setq results (cons (funcall function args) results)
- args (cdr args)))
- (nreverse results)))
-
-(defun mapl (function list)
- "(MAPL FUNCTION LIST) => LIST
-Apply FUNCTION to successive cdrs of LIST, return LIST.
-Like maplist, but called only for effect."
- (let ((args list))
- (while args
- (funcall function args)
- (setq args (cdr args)))
- list))
-
-(defun mapcan (function list)
- "(MAPCAN FUNCTION LIST) => nconc'd results of FUNCTION on LIST
-Apply FUNCTION to each element of LIST, nconc the results.
-Beware: nconc destroys its first argument! See copy-list."
- (let ((args list)
- (results '()))
- (while args
- (setq results (nconc (funcall function (car args)) results)
- args (cdr args)))
- (nreverse results)))
-
-(defun mapcon (function list)
- "(MAPCON FUNCTION LIST) => nconc'd results of FUNCTION on cdrs of LIST
-Apply FUNCTION to successive sublists of LIST, nconc the results.
-Beware: nconc destroys its first argument! See copy-list."
- (let ((args list)
- (results '()))
- (while args
- (setq results (nconc (funcall function args) results)
- args (cdr args)))
- (nreverse results)))
-
-;;; Copiers
-
-(defun copy-list (list)
- "Build a copy of LIST"
- (append list '()))
-
-(defun copy-tree (tree)
- "Build a copy of the tree of conses TREE
-The argument is a tree of conses, it is recursively copied down to
-non conses. Circularity and sharing of substructure are not
-necessarily preserved."
- (if (consp tree)
- (cons (copy-tree (car tree))
- (copy-tree (cdr tree)))
- tree))
-
-;;; reversals, and destructive manipulations of a list's spine
-
-(defun revappend (x y)
- "does what (append (reverse X) Y) would, only faster"
- (if (endp x)
- y
- (revappend (cdr x) (cons (car x) y))))
-
-(defun nreconc (x y)
- "does (nconc (nreverse X) Y) would, only faster
-Destructive on X, be careful."
- (if (endp x)
- y
- ;; reuse the first cons of x, making it point to y
- (nreconc (cdr x) (prog1 x (rplacd x y)))))
-
-(defun nbutlast (list &optional n)
- "Side-effected LIST truncated N+1 conses from the end.
-This is the destructive version of BUTLAST. Returns () and does not
-modify the LIST argument if the length of the list is not at least N."
- (when (null n) (setf n 1))
- (let ((length (list-length list)))
- (cond ((null length)
- list)
- ((< length n)
- '())
- (t
- (setnthcdr (- length n) list nil)
- list))))
-
-;;; Substitutions
-
-(defun subst (new old tree)
- "NEW replaces OLD in a copy of TREE
-Uses eql for the test."
- (subst-if new (function (lambda (x) (eql x old))) tree))
-
-(defun subst-if-not (new test tree)
- "NEW replaces any subtree or leaf that fails TEST in a copy of TREE"
- ;; (subst-if new (function (lambda (x) (not (funcall test x)))) tree)
- (cond ((not (funcall test tree))
- new)
- ((atom tree)
- tree)
- (t ;no match so far
- (let ((head (subst-if-not new test (car tree)))
- (tail (subst-if-not new test (cdr tree))))
- ;; If nothing changed, return originals. Else use the new
- ;; components to assemble a new tree.
- (if (and (eql head (car tree))
- (eql tail (cdr tree)))
- tree
- (cons head tail))))))
-
-(defun subst-if (new test tree)
- "NEW replaces any subtree or leaf that satisfies TEST in a copy of TREE"
- (cond ((funcall test tree)
- new)
- ((atom tree)
- tree)
- (t ;no match so far
- (let ((head (subst-if new test (car tree)))
- (tail (subst-if new test (cdr tree))))
- ;; If nothing changed, return originals. Else use the new
- ;; components to assemble a new tree.
- (if (and (eql head (car tree))
- (eql tail (cdr tree)))
- tree
- (cons head tail))))))
-
-(defun sublis (alist tree)
- "Use association list ALIST to modify a copy of TREE
-If a subtree or leaf of TREE is a key in ALIST, it is replaced by the
-associated value. Not exactly Common Lisp, but close in spirit and
-compatible with the native Emacs Lisp ASSOC, which uses EQUAL."
- (let ((toplevel (assoc tree alist)))
- (cond (toplevel ;Bingo at top
- (cdr toplevel))
- ((atom tree) ;Give up on this
- tree)
- (t
- (let ((head (sublis alist (car tree)))
- (tail (sublis alist (cdr tree))))
- (if (and (eql head (car tree))
- (eql tail (cdr tree)))
- tree
- (cons head tail)))))))
-
-(defun member-if (predicate list)
- "PREDICATE is applied to the members of LIST. As soon as one of them
-returns true, that tail of the list if returned. Else NIL."
- (catch 'found-member-if
- (while (not (endp list))
- (if (funcall predicate (car list))
- (throw 'found-member-if list)
- (setq list (cdr list))))
- nil))
-
-(defun member-if-not (predicate list)
- "PREDICATE is applied to the members of LIST. As soon as one of them
-returns false, that tail of the list if returned. Else NIL."
- (catch 'found-member-if-not
- (while (not (endp list))
- (if (funcall predicate (car list))
- (setq list (cdr list))
- (throw 'found-member-if-not list)))
- nil))
-
-(defun tailp (sublist list)
- "(tailp SUBLIST LIST) => True if SUBLIST is a sublist of LIST."
- (catch 'tailp-found
- (while (not (endp list))
- (if (eq sublist list)
- (throw 'tailp-found t)
- (setq list (cdr list))))
- nil))
-
-;;; Suggestion of phr%widow.Berkeley.EDU@lilac.berkeley.edu
-
-(defmacro declare (&rest decls)
- "Ignore a Common-Lisp declaration."
- "declarations are ignored in this implementation")
-
-(defun proclaim (&rest decls)
- "Ignore a Common-Lisp proclamation."
- "declarations are ignored in this implementation")
-
-(defmacro the (type form)
- "(the TYPE FORM) macroexpands to FORM
-No checking is even attempted. This is just for compatibility with
-Common-Lisp codes."
- form)
;;;; end of cl.el
diff --git a/lisp/cl.elc b/lisp/cl.elc
new file mode 100644
index 00000000000..8586823a775
--- /dev/null
+++ b/lisp/cl.elc
Binary files differ
diff --git a/lisp/cmacexp.el b/lisp/cmacexp.el
new file mode 100644
index 00000000000..7b33282bb88
--- /dev/null
+++ b/lisp/cmacexp.el
@@ -0,0 +1,45 @@
+
+(defun c-macro-expand (beg end)
+ "Display the result of expanding all C macros occurring in the region.
+The expansion is entirely correct because it uses the C preprocessor."
+ (interactive "r")
+ (let ((outbuf (get-buffer-create "*Macroexpansion*"))
+ (tempfile "%%macroexpand%%")
+ process
+ last-needed)
+ (save-excursion
+ (set-buffer outbuf)
+ (erase-buffer))
+ (setq process (start-process "macros" outbuf "/lib/cpp"))
+ (set-process-sentinel process '(lambda (&rest x)))
+ (save-restriction
+ (widen)
+ (save-excursion
+ (goto-char beg)
+ (beginning-of-line)
+ (setq last-needed (point))
+ (if (re-search-backward "^[ \t]*#" nil t)
+ (progn
+ ;; Skip continued lines.
+ (while (progn (end-of-line) (= (preceding-char) ?\\))
+ (forward-line 1))
+ ;; Skip the last line of the macro definition we found.
+ (forward-line 1)
+ (setq last-needed (point)))))
+ (write-region (point-min) last-needed tempfile nil 'nomsg)
+ (process-send-string process (concat "#include \"" tempfile "\"\n"))
+ (process-send-string process "\n")
+ (process-send-region process beg end)
+ (process-send-string process "\n")
+ (process-send-eof process))
+ (while (eq (process-status process) 'run)
+ (accept-process-output))
+ (delete-file tempfile)
+ (save-excursion
+ (set-buffer outbuf)
+ (goto-char (point-max))
+ (re-search-backward "\n# [12] \"\"")
+ (forward-line 2)
+ (while (eolp) (delete-char 1))
+ (delete-region (point-min) (point)))
+ (display-buffer outbuf)))
diff --git a/lisp/comint.el b/lisp/comint.el
deleted file mode 100644
index 31e8b40e1e7..00000000000
--- a/lisp/comint.el
+++ /dev/null
@@ -1,866 +0,0 @@
-;;; -*-Emacs-Lisp-*- General command interpreter in a window stuff
-;;; Copyright (C) 1989 Free Software Foundation, Inc.
-;;; Original author: Olin Shivers <olin.shivers@cs.cmu.edu> Aug 1988
-
-;;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;;; This file defines a general command-interpreter-in-a-buffer package
-;;; (comint mode). The idea is that you can build specific process-in-a-buffer
-;;; modes on top of comint mode -- e.g., lisp, shell, scheme, T, soar, ....
-;;; This way, all these specific packages share a common base functionality,
-;;; and a common set of bindings, which makes them easier to use (and
-;;; saves code, implementation time, etc., etc.).
-
-;;; For documentation on the functionality provided by comint mode, and
-;;; the hooks available for customising it, see the comments below.
-;;; For further information on the standard derived modes (shell,
-;;; inferior-lisp, inferior-scheme, ...), see the relevant source files.
-
-;;; For hints on converting existing process modes to use comint-mode
-;;; instead of shell-mode, see the notes at the end of this file.
-
-(require 'history)
-(provide 'comint)
-(defconst comint-version "2.01")
-
-
-;;; Not bound by default in comint-mode
-;;; send-invisible Read a line w/o echo, and send to proc
-;;; (These are bound in shell-mode)
-;;; comint-dynamic-complete Complete filename at point.
-;;; comint-dynamic-list-completions List completions in help buffer.
-;;; comint-replace-by-expanded-filename Expand and complete filename at point;
-;;; replace with expanded/completed name.
-(defvar comint-mode-map nil)
-
-(if comint-mode-map
- nil
- (setq comint-mode-map (make-sparse-keymap))
- (define-key comint-mode-map "\C-a" 'comint-bol)
- (define-key comint-mode-map "\C-d" 'comint-delchar-or-maybe-eof)
- (define-key comint-mode-map "\C-m" 'comint-send-input)
- (define-key comint-mode-map "\M-p" 'comint-previous-input)
- (define-key comint-mode-map "\M-n" 'comint-next-input)
- (define-key comint-mode-map "\M-s" 'comint-previous-similar-input)
- (define-key comint-mode-map "\C-c\C-c" 'comint-interrupt-subjob) ; tty ^C
- (define-key comint-mode-map "\C-c\C-f" 'comint-continue-subjob) ; shell "fg"
- (define-key comint-mode-map "\C-c\C-l" 'comint-show-output)
- (define-key comint-mode-map "\C-c\C-o" 'comint-flush-output) ; tty ^O
- (define-key comint-mode-map "\C-c\C-r" 'comint-history-search-backward)
- (define-key comint-mode-map "\C-c\C-s" 'comint-history-search-forward)
- (define-key comint-mode-map "\C-c\C-u" 'comint-kill-input) ; tty ^U
- (define-key comint-mode-map "\C-c\C-w" 'backward-kill-word) ; tty ^W
- (define-key comint-mode-map "\C-c\C-z" 'comint-stop-subjob) ; tty ^Z
- (define-key comint-mode-map "\C-c\C-\\" 'comint-quit-subjob)) ; tty ^\
-
-;;; Buffer Local Variables:
-;;;============================================================================
-;;; Comint mode buffer local variables:
-;;; comint-prompt-regexp - string comint-bol uses to match prompt.
-;;; comint-last-input-end - marker For comint-flush-output command
-;;; input-ring-size - integer For the input history
-;;; input-ring - ring mechanism
-;;; input-ring-index - marker ...
-;;; comint-last-input-match - string ...
-;;; comint-get-old-input - function Hooks for specific
-;;; comint-input-sentinel - function process-in-a-buffer
-;;; comint-input-filter - function modes.
-;;; comint-input-send - function
-;;; comint-eol-on-send - boolean
-
-(make-variable-buffer-local
- (defvar comint-prompt-regexp "^"
- "*Regexp to recognise prompts in the inferior process. Defaults to \"^\".
-
-Good choices:
- Canonical Lisp: \"^[^> \n]*>+:? *\" (Lucid, Franz, KCL, T, cscheme, oaklisp)
- Lucid Common Lisp: \"^\\(>\\|\\(->\\)+\\) *\"
- Franz: \"^\\(->\\|<[0-9]*>:\\) *\"
- KCL and T: \"^>+ *\"
- shell: \"^[^#$%>\n]*[#$%>] *\"
-
-This is a good thing to set in mode hooks."))
-
-(make-variable-buffer-local
- (defvar input-ring-size 30 "Size of input history ring."))
-
-;;; Here are the per-interpreter hooks.
-(make-variable-buffer-local
- (defvar comint-get-old-input (function comint-get-old-input-default)
- "Function that submits old text in comint mode.
-This function is called when return is typed while the point is in old text.
-It returns the text to be submitted as process input. The default is
-comint-get-old-input-default, which grabs the current line, and strips off
-leading text matching comint-prompt-regexp."))
-
-(make-variable-buffer-local
- (defvar comint-input-sentinel (function ignore)
- "Called on each input submitted to comint mode process by comint-send-input.
-Thus it can, for instance, track cd/pushd/popd commands issued to the csh."))
-
-(make-variable-buffer-local
- (defvar comint-input-filter
- (function (lambda (str) (not (string-match "\\`\\s *\\'" str))))
- "Predicate for filtering additions to input history.
-Only inputs answering true to this function are saved on the input
-history list. Default is to save anything that isn't all whitespace"))
-
-(defvar comint-mode-hook '()
- "Called upon entry into comint-mode")
-
-(defun comint-mode ()
- "Major mode for interacting with an inferior interpreter.
-Interpreter name is same as buffer name, sans the asterisks.
-Return at end of buffer sends line as input.
-Return not at end copies rest of line to end and sends it.
-
-This mode is typically customised to create inferior-lisp-mode,
-shell-mode, et cetera. This can be done by setting the hooks
-comint-input-sentinel, comint-input-filter, and comint-get-old-input
-to appropriate functions, and the variable comint-prompt-regexp
-to the appropriate regular expression.
-
-An input history is maintained of size input-ring-size, and
-can be accessed with the commands comint-next-input [\\[comint-next-input]] and
-comint-previous-input [\\[comint-previous-input]]. Commands not keybound by
-default are send-invisible, comint-dynamic-complete, and
-comint-list-dynamic-completions.
-
-If you accidentally suspend your process, use \\[comint-continue-subjob]
-to continue it.
-
-\\{comint-mode-map}
-
-Entry to this mode runs the hooks on comint-mode-hook."
- (interactive)
- (kill-all-local-variables)
- (setq major-mode 'comint-mode
- mode-name "Comint"
- mode-line-process '(": %s"))
- (use-local-map comint-mode-map)
- (set (make-local-variable 'input-ring) (make-ring input-ring-size))
- (put 'input-ring 'preserved t)
- (set (make-local-variable 'comint-last-input-match) "")
- (set (make-local-variable 'comint-last-similar--string) "")
- (set (make-local-variable 'input-ring-index) 0)
- (set (make-local-variable 'comint-last-input-end) (make-marker))
- (set-marker comint-last-input-end (point-max))
- (run-hooks 'comint-mode-hook))
-
-(defun comint-check-proc (buffer-name)
- "True if there is a running or stopped process associated with BUFFER."
- (let ((proc (get-buffer-process buffer-name)))
- (and proc (memq (process-status proc) '(run stop)))))
-
-(defun comint-mark ()
- ;; Returns the process-mark of the current-buffer
- (process-mark (get-buffer-process (current-buffer))))
-
-;;; Note that this guy, unlike shell.el's make-shell, barfs if you pass it ()
-;;; for the second argument (program).
-(defun make-comint (name program &optional startfile &rest switches)
- (let* ((buffer (get-buffer-create (concat "*" name "*")))
- (proc (get-buffer-process buffer)))
- ;; If no process, or nuked process, crank up a new one and put buffer in
- ;; comint mode. Otherwise, leave buffer and existing process alone.
- (cond ((not (comint-check-proc buffer))
- (save-excursion
- (set-buffer buffer)
- (comint-mode)) ; Install local vars, mode, keymap, ...
- (comint-exec buffer name program startfile switches)))
- buffer))
-
-(defun comint-exec (buffer name command startfile switches)
- "Fires up a process in buffer for comint modes.
-Blasts any old process running in the buffer. Doesn't set the buffer mode.
-You can use this to cheaply run a series of processes in the same buffer."
- (or command (error "No program for comint process"))
- (save-excursion
- (set-buffer buffer)
- (let ((proc (get-buffer-process buffer))) ; Blast any old process.
- (if proc (delete-process proc)))
- ;; Crank up a new process
- (let ((proc (comint-exec-1 name buffer command switches)))
- ;; Jump to the end, and set the process mark.
- (set-marker (comint-mark) (goto-char (point-max)))
- ;; Feed it the startfile.
- (cond (startfile
- ;;This is guaranteed to wait long enough
- ;;but has bad results if the comint does not prompt at all
- ;; (while (= size (buffer-size))
- ;; (sleep-for 1))
- ;;I hope 1 second is enough!
- (sleep-for 1)
- (goto-char (point-max))
- (insert-file-contents startfile)
- (setq startfile (buffer-substring (point) (point-max)))
- (delete-region (point) (point-max))
- (comint-send-string proc startfile))))
- buffer))
-
-;;; This auxiliary function cranks up the process for comint-exec in
-;;; the appropriate environment. It is twice as long as it should be
-;;; because emacs has two distinct mechanisms for manipulating the
-;;; process environment, selected at compile time with the
-;;; MAINTAIN-ENVIRONMENT #define. In one case, process-environment
-;;; is bound; in the other it isn't.
-
-(defun comint-exec-1 (name buffer command switches)
- (if (boundp 'process-environment) ; Not a completely reliable test.
- (let ((process-environment
- (comint-update-env process-environment
- (list (format "TERMCAP=emacs:co#%d:tc=unknown"
- (screen-width))
- "TERM=emacs"
- "EMACS=t"))))
- (apply 'start-process name buffer command switches))
- (let ((tcapv (getenv "TERMCAP"))
- (termv (getenv "TERM"))
- (emv (getenv "EMACS")))
- (unwind-protect
- (progn (setenv "TERMCAP" (format "emacs:co#%d:tc=unknown"
- (screen-width)))
- (setenv "TERM" "emacs")
- (setenv "EMACS" "t")
- (apply 'start-process name buffer command switches))
- (setenv "TERMCAP" tcapv)
- (setenv "TERM" termv)
- (setenv "EMACS" emv)))))
-
-;; This is just (append new old-env) that compresses out shadowed entries.
-;; It's also pretty ugly, mostly due to elisp's horrible iteration structures.
-(defun comint-update-env (old-env new)
- (let ((ans (reverse new))
- (vars (mapcar (function (lambda (vv)
- (and (string-match "^[^=]*=" vv)
- (substring vv 0 (match-end 0)))))
- new)))
- (while old-env
- (let* ((vv (car old-env)) ; vv is var=value
- (var (and (string-match "^[^=]*=" vv)
- (substring vv 0 (match-end 0)))))
- (setq old-env (cdr old-env))
- (cond ((not (and var (member var vars)))
- (if var (setq var (cons var vars)))
- (setq ans (cons vv ans))))))
- (nreverse ans)))
-
-;;; Input history retrieval commands
-;;; M-p -- previous input M-n -- next input
-;;; C-c r -- previous input matching
-;;; ===========================================================================
-
-(defun comint-previous-input (arg)
- "Cycle backwards through input history."
- (interactive "*p")
- (let ((len (ring-length input-ring)))
- (if (<= len 0) (error "Empty input ring"))
- (if (< (point) (comint-mark))
- (delete-region (comint-mark) (goto-char (point-max))))
- (cond ((eq last-command 'comint-previous-input)
- (delete-region (mark) (point)))
- ((eq last-command 'comint-previous-similar-input)
- (delete-region (comint-mark) (point)))
- (t
- (setq input-ring-index
- (if (> arg 0) -1
- (if (< arg 0) 1 0)))
- (push-mark (point))))
- (setq input-ring-index (comint-mod (+ input-ring-index arg) len))
- (message "%d" (1+ input-ring-index))
- (insert (ring-ref input-ring input-ring-index))
- (setq this-command 'comint-previous-input)))
-
-(defun comint-next-input (arg)
- "Cycle forwards through input history."
- (interactive "*p")
- (comint-previous-input (- arg)))
-
-(defun comint-previous-input-matching (str)
- "Searches backwards through input history for substring match."
- (interactive (let* ((last-command last-command) ; preserve around r-f-m
- (s (read-from-minibuffer
- (format "Command substring (default %s): "
- comint-last-input-match))))
- (list (if (string= s "") comint-last-input-match s))))
-; (interactive "sCommand substring: ")
- (setq comint-last-input-match str) ; update default
- (if (not (eq last-command 'comint-previous-input))
- (setq input-ring-index -1))
- (let ((str (regexp-quote str))
- (len (ring-length input-ring))
- (n (+ input-ring-index 1)))
- (while (and (< n len) (not (string-match str (ring-ref input-ring n))))
- (setq n (+ n 1)))
- (cond ((< n len)
- (comint-previous-input (- n input-ring-index)))
- (t (if (eq last-command 'comint-previous-input)
- (setq this-command 'comint-previous-input))
- (error "Not found")))))
-
-;;;
-;;; Similar input -- contributed by ccm and highly winning.
-;;;
-;;; Reenter input, removing back to the last insert point if it exists.
-;;;
-(defun comint-previous-similar-input (arg)
- "Reenters the last input that matches the string typed so far. If repeated
-successively older inputs are reentered. If arg is 1, it will go back
-in the history, if -1 it will go forward."
- (interactive "p")
- (if (< (point) (comint-mark))
- (error "Not after process mark"))
- (if (not (eq last-command 'comint-previous-similar-input))
- (setq input-ring-index -1
- comint-last-similar-string
- (buffer-substring (comint-mark) (point))))
- (let* ((size (length comint-last-similar-string))
- (len (ring-length input-ring))
- (n (+ input-ring-index arg))
- entry)
- (while (and (< n len)
- (or (< (length (setq entry (ring-ref input-ring n))) size)
- (not (equal comint-last-similar-string
- (substring entry 0 size)))))
- (setq n (+ n arg)))
- (cond ((< n len)
- (setq input-ring-index n)
- (if (eq last-command 'comint-previous-similar-input)
- (delete-region (comint-mark) (point)))
- (insert (substring entry size)))
- (t (error "Not found")))))
-
-(defun comint-send-input (&optional terminator delete)
- "Send input to process, followed by a linefeed or optional TERMINATOR.
-After the process output mark, sends all text from the process mark to
-end of buffer as input to the process. Before the process output mark, calls
-value of variable comint-get-old-input to retrieve old input, replaces it in
-the input region (from the end of process output to the end of the buffer) and
-then sends it. In either case, the value of variable comint-input-sentinel is
-called on the input before sending it. The input is entered into the input
-history ring, if value of variable comint-input-filter returns non-nil when
-called on the input.
-
-If optional second argument DELETE is non-nil, then the input is deleted from
-the end of the buffer. This is useful if the process unconditionally echoes
-input. Processes which use TERMINATOR or DELETE should have a command wrapper
-which provides them bound to RET; see telnet.el for an example.
-
-comint-get-old-input, comint-input-sentinel, and comint-input-filter are chosen
-according to the command interpreter running in the buffer. For example,
-
-If the interpreter is the csh,
- comint-get-old-input defaults: takes the current line, discard any
- initial string matching regexp comint-prompt-regexp.
- comint-input-sentinel: monitors input for \"cd\", \"pushd\", and \"popd\"
- commands. When it sees one, it changes the default directory of the buffer.
- comint-input-filter defaults: returns t if the input isn't all whitespace.
-
-If the comint is Lucid Common Lisp,
- comint-get-old-input: snarfs the sexp ending at point.
- comint-input-sentinel: does nothing.
- comint-input-filter: returns nil if the input matches input-filter-regexp,
- which matches (1) all whitespace (2) :a, :c, etc.
-
-Similar functions are used for other process modes."
- (interactive)
- ;; Note that the input string does not include its terminal newline.
- (if (not (get-buffer-process (current-buffer)))
- (error "Current buffer has no process")
- (let* ((pmark (comint-mark))
- (input (if (>= (point) pmark)
- (buffer-substring pmark (goto-char (point-max)))
- (let ((copy (funcall comint-get-old-input)))
- (delete-region pmark (goto-char (point-max)))
- (insert copy)
- copy))))
- (set-marker comint-last-input-end (point))
- (setq input-ring-index 0)
- (if (funcall comint-input-filter input) (ring-insert input-ring input))
- (funcall comint-input-sentinel input)
- (comint-send-string nil (concat input (or terminator "\n")))
- (if delete (delete-region mark (point))
- (insert "\n"))
- (set-marker (comint-mark) (point)))))
-
-(defun comint-get-old-input-default ()
- "Default for comint-get-old-input: use the current line sans prompt."
- (save-excursion
- (comint-bol)
- (buffer-substring (point) (progn (end-of-line) (point)))))
-
-(defun comint-bol (arg)
- "Goes to the beginning of line, then skips past the prompt, if any.
-With a prefix argument, (\\[universal-argument]), then doesn't skip prompt.
-
-The prompt skip is done by passing over text matching the regular expression
-comint-prompt-regexp, a buffer local variable."
- (interactive "P")
- (beginning-of-line)
- (or arg (if (looking-at comint-prompt-regexp) (goto-char (match-end 0)))))
-
-;;; These two functions are for entering text you don't want echoed or
-;;; saved -- typically passwords to ftp, telnet, or somesuch.
-;;; Just enter M-x send-invisible and type in your line.
-(defun comint-read-noecho (prompt)
- "Prompting with PROMPT, read a single line of text without echoing.
-The text can still be recovered (temporarily) with \\[view-lossage]. This
-may be a security bug for some applications."
- (let ((echo-keystrokes 0)
- (answ "")
- tem)
- (if (and (stringp prompt) (not (string= (message prompt) "")))
- (message prompt))
- (while (not (or (= (setq tem (read-char)) ?\^m)
- (= tem ?\n)))
- (setq answ (concat answ (char-to-string tem))))
- (message "")
- answ))
-
-(defun send-invisible (str)
- "Read a string without echoing, and send it to the current buffer's process.
-A newline is also sent. String is not saved on comint input history list.
-Security bug: your string can still be temporarily recovered with \\[view-lossage]."
-; (interactive (list (comint-read-noecho "Enter non-echoed text")))
- (interactive "P") ; Defeat snooping via C-x esc
- (let ((proc (get-buffer-process (current-buffer))))
- (if (not proc) (error "Current buffer has no process")
- (comint-send-string proc
- (if (stringp str) str
- (comint-read-noecho "Enter non-echoed text")))
- (comint-send-string proc "\n"))))
-
-
-;;; Low-level process communication
-
-(defvar comint-input-chunk-size 512
- "*Long inputs send to comint processes are broken up into chunks of this size.
-If your process is choking on big inputs, try lowering the value.")
-
-(defun comint-send-string (proc str)
- "Send PROCESS the contents of STRING as input.
-This is equivalent to process-send-string, except that long input strings
-are broken up into chunks of size comint-input-chunk-size. Processes
-are given a chance to output between chunks. This can help prevent processes
-from hanging when you send them long inputs on some OS's."
- (let* ((len (length str))
- (i (min len comint-input-chunk-size)))
- (process-send-string proc (substring str 0 i))
- (while (< i len)
- (let ((next-i (+ i comint-input-chunk-size)))
- (accept-process-output)
- (process-send-string proc (substring str i (min len next-i)))
- (setq i next-i)))))
-
-(defun comint-send-region (proc start end)
- "Sends to PROC the region delimited by START and END.
-This is a replacement for process-send-region that tries to keep
-your process from hanging on long inputs. See comint-send-string."
- (comint-send-string proc (buffer-substring start end)))
-
-
-;;; Random input hackage
-
-(defun comint-flush-output ()
- "Kill all output from interpreter since last input."
- (interactive)
- (save-excursion
- (goto-char (comint-mark))
- (beginning-of-line)
- (delete-region (1+ comint-last-input-end) (point))
- (insert "*** output flushed ***\n")))
-
-(defun comint-show-output ()
- "Start display of the current window at line preceding start of last output.
-\"Last output\" is considered to start at the line following the last command
-entered to the process."
- (interactive)
- (goto-char comint-last-input-end)
- (beginning-of-line)
- (set-window-start (selected-window) (point))
- (comint-bol))
-
-(defun comint-interrupt-subjob ()
- "Sent an interrupt signal to the current subprocess.
-If the process-connection-type is via ptys, the signal is sent to the current
-process group of the pseudoterminal which Emacs is using to communicate with
-the subprocess. If the process is a job-control shell, this means the
-shell's current subjob. If the process connection is via pipes, the signal is
-sent to the immediate subprocess."
- (interactive)
- (interrupt-process nil t))
-
-(defun comint-kill-subjob ()
- "Send a kill signal to the current subprocess.
-See comint-interrupt-subjob for a description of \"current subprocess\"."
- (interactive)
- (kill-process nil t))
-
-(defun comint-quit-subjob ()
- "Send a quit signal to the current subprocess.
-See comint-interrupt-subjob for a description of \"current subprocess\"."
- (interactive)
- (quit-process nil t))
-
-(defun comint-stop-subjob ()
- "Stop the current subprocess.
-See comint-interrupt-subjob for a description of \"current subprocess\".
-
-WARNING: if there is no current subjob, you can end up suspending
-the top-level process running in the buffer. If you accidentally do
-this, use \\[comint-continue-subjob] to resume the process. (This is not a
-problem with most shells, since they ignore this signal.)"
- (interactive)
- (stop-process nil t))
-
-(defun comint-continue-subjob ()
- "Send a continue signal to current subprocess.
-See comint-interrupt-subjob for a description of \"current subprocess\".
-Useful if you accidentally suspend the top-level process."
- (interactive)
- (continue-process nil t))
-
-(defun comint-kill-input ()
- "Kill from current command through point."
- (interactive)
- (let ((pmark (comint-mark)))
- (if (> (point) pmark)
- (kill-region pmark (point))
- (error "Nothing to kill"))))
-
-(defun comint-delchar-or-maybe-eof (arg)
- "Delete ARG characters forward, or send an EOF to process if at end of buffer."
- (interactive "p")
- (if (eobp)
- (process-send-eof)
- (delete-char arg)))
-
-;;; Support for source-file processing commands.
-;;;============================================================================
-;;; Many command-interpreters (e.g., Lisp, Scheme, Soar) have
-;;; commands that process files of source text (e.g. loading or compiling
-;;; files). So the corresponding process-in-a-buffer modes have commands
-;;; for doing this (e.g., lisp-load-file). The functions below are useful
-;;; for defining these commands.
-;;;
-;;; Alas, these guys don't do exactly the right thing for Lisp, Scheme
-;;; and Soar, in that they don't know anything about file extensions.
-;;; So the compile/load interface gets the wrong default occasionally.
-;;; The load-file/compile-file default mechanism could be smarter -- it
-;;; doesn't know about the relationship between filename extensions and
-;;; whether the file is source or executable. If you compile foo.lisp
-;;; with compile-file, then the next load-file should use foo.bin for
-;;; the default, not foo.lisp. This is tricky to do right, particularly
-;;; because the extension for executable files varies so much (.o, .bin,
-;;; .lbin, .mo, .vo, .ao, ...).
-
-
-;;; COMINT-SOURCE-DEFAULT -- determines defaults for source-file processing
-;;; commands.
-;;;
-;;; COMINT-CHECK-SOURCE -- if FNAME is in a modified buffer, asks you if you
-;;; want to save the buffer before issuing any process requests to the command
-;;; interpreter.
-;;;
-;;; COMINT-GET-SOURCE -- used by the source-file processing commands to prompt
-;;; for the file to process.
-
-;;; (COMINT-SOURCE-DEFAULT previous-dir/file source-modes)
-;;;============================================================================
-;;; This function computes the defaults for the load-file and compile-file
-;;; commands for tea, soar, lisp, and scheme modes.
-;;;
-;;; - PREVIOUS-DIR/FILE is a pair (directory . filename) from the last
-;;; source-file processing command. NIL if there hasn't been one yet.
-;;; - SOURCE-MODES is a list used to determine what buffers contain source
-;;; files: if the major mode of the buffer is in SOURCE-MODES, it's source.
-;;; Typically, (lisp-mode) or (scheme-mode).
-;;;
-;;; If the command is given while the cursor is inside a string, *and*
-;;; the string is an existing filename, *and* the filename is not a directory,
-;;; then the string is taken as default. This allows you to just position
-;;; your cursor over a string that's a filename and have it taken as default.
-;;;
-;;; If the command is given in a file buffer whose major mode is in
-;;; SOURCE-MODES, then the the filename is the default file, and the
-;;; file's directory is the default directory.
-;;;
-;;; If the buffer isn't a source file buffer (e.g., it's the process buffer),
-;;; then the default directory & file are what was used in the last source-file
-;;; processing command (i.e., PREVIOUS-DIR/FILE). If this is the first time
-;;; the command has been run (PREVIOUS-DIR/FILE is nil), the default directory
-;;; is the cwd, with no default file. (\"no default file\" = nil)
-;;;
-;;; SOURCE-REGEXP is typically going to be something like (tea-mode)
-;;; for T programs, (lisp-mode) for Lisp programs, (soar-mode lisp-mode)
-;;; for Soar programs, etc.
-;;;
-;;; The function returns a pair: (default-directory . default-file).
-
-(defun comint-source-default (previous-dir/file source-modes)
- (cond ((and buffer-file-name (memq major-mode source-modes))
- (cons (file-name-directory buffer-file-name)
- (file-name-nondirectory buffer-file-name)))
- (previous-dir/file)
- (t
- (cons default-directory nil))))
-
-;;; (COMINT-CHECK-SOURCE fname)
-;;;============================================================================
-;;; Prior to loading or compiling (or otherwise processing) a file (in the
-;;; process-in-a-buffer modes), this function can be called on the filename.
-;;; If the file is loaded into a buffer, and the buffer is modified, the user
-;;; is queried to see if he wants to save the buffer before proceeding with
-;;; the load or compile.
-
-(defun comint-check-source (fname)
- (let ((buff (get-file-buffer fname)))
- (if (and buff
- (buffer-modified-p buff)
- (y-or-n-p (format "Save buffer %s first? "
- (buffer-name buff))))
- ;; save BUFF.
- (let ((old-buffer (current-buffer)))
- (set-buffer buff)
- (save-buffer)
- (set-buffer old-buffer)))))
-
-;;; (COMINT-GET-SOURCE prompt prev-dir/file source-modes mustmatch-p)
-;;;============================================================================
-;;; COMINT-GET-SOURCE is used to prompt for filenames in command-interpreter
-;;; commands that process source files (like loading or compiling a file).
-;;; It prompts for the filename, provides a default, if there is one,
-;;; and returns the result filename.
-;;;
-;;; See COMINT-SOURCE-DEFAULT for more on determining defaults.
-;;;
-;;; PROMPT is the prompt string. PREV-DIR/FILE is the (directory . file) pair
-;;; from the last source processing command. SOURCE-MODES is a list of major
-;;; modes used to determine what file buffers contain source files. (These
-;;; two arguments are used for determining defaults). If MUSTMATCH-P is true,
-;;; then the filename reader will only accept a file that exists.
-;;;
-;;; A typical use:
-;;; (interactive (comint-get-source "Compile file: " prev-lisp-dir/file
-;;; '(lisp-mode) t))
-
-;;; This is pretty stupid about strings. It decides we're in a string
-;;; if there's a quote on both sides of point on the current line.
-(defun comint-extract-string ()
- "Returns string around point that starts the current line or nil."
- (save-excursion
- (let* ((point (point))
- (bol (progn (beginning-of-line) (point)))
- (eol (progn (end-of-line) (point)))
- (start (progn (goto-char point)
- (and (search-backward "\"" bol t)
- (1+ (point)))))
- (end (progn (goto-char point)
- (and (search-forward "\"" eol t)
- (1- (point))))))
- (and start end
- (buffer-substring start end)))))
-
-(defun comint-get-source (prompt prev-dir/file source-modes mustmatch-p)
- (let* ((def (comint-source-default prev-dir/file source-modes))
- (stringfile (comint-extract-string))
- (sfile-p (and stringfile
- (file-exists-p stringfile)
- (not (file-directory-p stringfile))))
- (defdir (if sfile-p (file-name-directory stringfile)
- (car def)))
- (deffile (if sfile-p (file-name-nondirectory stringfile)
- (cdr def)))
- (ans (read-file-name (if deffile (format "%s(default %s) "
- prompt deffile)
- prompt)
- defdir
- (concat defdir deffile)
- mustmatch-p)))
- (list (expand-file-name (substitute-in-file-name ans)))))
-
-
-;;; Simple process query facility.
-;;; ===========================================================================
-;;; This function is for commands that want to send a query to the process
-;;; and show the response to the user. For example, a command to get the
-;;; arglist for a Common Lisp function might send a "(arglist 'foo)" query
-;;; to an inferior Common Lisp process.
-;;;
-;;; This simple facility just sends strings to the inferior process and pops
-;;; up a window for the process buffer so you can see what the process
-;;; responds with. We don't do anything fancy like try to intercept what the
-;;; process responds with and put it in a pop-up window or on the message
-;;; line. We just display the buffer. Low tech. Simple. Works good.
-
-;;; Send to the inferior process PROC the string STR. Pop-up but do not select
-;;; a window for the inferior process so that its response can be seen.
-(defun comint-proc-query (proc str)
- (let* ((proc-buf (process-buffer proc))
- (proc-mark (process-mark proc)))
- (display-buffer proc-buf)
- (set-buffer proc-buf) ; but it's not the selected *window*
- (let ((proc-win (get-buffer-window proc-buf))
- (proc-pt (marker-position proc-mark)))
- (comint-send-string proc str) ; send the query
- (accept-process-output proc) ; wait for some output
- ;; Try to position the proc window so you can see the answer.
- ;; This is bogus code. If you delete the (sit-for 0), it breaks.
- ;; I don't know why. Wizards invited to improve it.
- (if (not (pos-visible-in-window-p proc-pt proc-win))
- (let ((opoint (window-point proc-win)))
- (set-window-point proc-win proc-mark) (sit-for 0)
- (if (not (pos-visible-in-window-p opoint proc-win))
- (push-mark opoint)
- (set-window-point proc-win opoint)))))))
-
-
-;;; Filename completion in a buffer
-;;; ===========================================================================
-;;; Useful completion functions, courtesy of the Ergo group.
-;;; M-<Tab> will complete the filename at the cursor as much as possible
-;;; M-? will display a list of completions in the help buffer.
-
-;;; Three commands:
-;;; comint-dynamic-complete Complete filename at point.
-;;; comint-dynamic-list-completions List completions in help buffer.
-;;; comint-replace-by-expanded-filename Expand and complete filename at point;
-;;; replace with expanded/completed name.
-
-;;; These are not installed in the comint-mode keymap. But they are
-;;; available for people who want them. Shell-mode-map uses them, though.
-
-(defun comint-match-partial-pathname ()
- "Returns the string of an existing filename or causes an error."
- (if (save-excursion (backward-char 1) (looking-at "\\s ")) ""
- (save-excursion
- (re-search-backward "[^~/A-Za-z0-9---_.$#,]+")
- (re-search-forward "[~/A-Za-z0-9---_.$#,]+")
- (substitute-in-file-name
- (buffer-substring (match-beginning 0) (match-end 0))))))
-
-(defun comint-replace-by-expanded-filename ()
- "Replace the filename at point with its expanded, canonicalised completion.
-\"Expanded\" means environment variables (e.g., $HOME) and ~'s are
-replaced with the corresponding directories. \"Canonicalised\" means ..
-and . are removed, and the filename is made absolute instead of relative.
-See functions expand-file-name and substitute-in-file-name. See also
-comint-dynamic-complete."
- (interactive)
- (let* ((pathname (comint-match-partial-pathname))
- (pathdir (file-name-directory pathname))
- (pathnondir (file-name-nondirectory pathname))
- (completion (file-name-completion pathnondir
- (or pathdir default-directory))))
- (cond ((null completion)
- (error "No completions"))
- ((eql completion t)
- (message "Sole completion"))
- (t ; this means a string was returned.
- (delete-region (match-beginning 0) (match-end 0))
- (insert (expand-file-name (concat pathdir completion)))))))
-
-(defun comint-dynamic-complete ()
- "Complete the filename at point.
-This function is similar to comint-replace-by-expanded-filename, except
-that it won't change parts of the filename already entered in the buffer;
-it just adds completion characters to the end of the filename."
- (interactive)
- (let* ((pathname (comint-match-partial-pathname))
- (pathdir (file-name-directory pathname))
- (pathnondir (file-name-nondirectory pathname))
- (completion (file-name-completion pathnondir
- (or pathdir default-directory))))
- (cond ((null completion)
- (error "No completions"))
- ((eql completion t)
- (error "Sole completion"))
- (t ; this means a string was returned.
- (goto-char (match-end 0))
- (insert (substring completion (length pathnondir)))))))
-
-(defun comint-dynamic-list-completions ()
- "List all possible completions of the filename at point."
- (interactive)
- (let* ((pathname (comint-match-partial-pathname))
- (pathdir (file-name-directory pathname))
- (pathnondir (file-name-nondirectory pathname))
- (completions
- (file-name-all-completions pathnondir
- (or pathdir default-directory))))
- (cond ((null completions)
- (error "No completions"))
- (t
- (let ((conf (current-window-configuration)))
- (with-output-to-temp-buffer " *Completions*"
- (display-completion-list completions))
- (sit-for 0)
- (message "Hit space to flush.")
- (let ((ch (read-char)))
- (if (= ch ?\ )
- (set-window-configuration conf)
- (setq unread-command-char ch))))))))
-
-
-;;; Converting process modes to use comint mode
-;;; ===========================================================================
-;;; Renaming variables
-;;; Most of the work is renaming variables and functions.
-;;; These are the common ones.
-
-;;; Local variables --
-;;; last-input-end comint-last-input-end
-;;; last-input-start <unnecessary>
-;;; shell-prompt-pattern comint-prompt-regexp
-;;; shell-set-directory-error-hook <no equivalent>
-;;; Miscellaneous --
-;;; shell-set-directory <unnecessary>
-;;; shell-mode-map comint-mode-map
-;;; Commands --
-;;; shell-send-input comint-send-input
-;;; shell-send-eof comint-delchar-or-maybe-eof
-;;; kill-shell-input comint-kill-input
-;;; interrupt-shell-subjob comint-interrupt-subjob
-;;; stop-shell-subjob comint-stop-subjob
-;;; quit-shell-subjob comint-quit-subjob
-;;; kill-shell-subjob comint-kill-subjob
-;;; kill-output-from-shell comint-kill-output
-;;; show-output-from-shell comint-show-output
-;;; copy-last-shell-input Use comint-previous-input/comint-next-input
-;;;
-;;; LAST-INPUT-START is no longer necessary because inputs are stored on the
-;;; input history ring. SHELL-SET-DIRECTORY is gone, its functionality taken
-;;; over by SHELL-DIRECTORY-TRACKER, the shell mode's comint-input-sentinel.
-;;; Comint mode does not provide functionality equivalent to
-;;; shell-set-directory-error-hook; it is gone.
-;;;
-;;; If you are implementing some process-in-a-buffer mode, called foo-mode, do
-;;; *not* create the comint-mode local variables in your foo-mode function.
-;;; This is not modular. Instead, call comint-mode, and let *it* create the
-;;; necessary comint-specific local variables. Then create the
-;;; foo-mode-specific local variables in foo-mode. Set the buffer's keymap to
-;;; be foo-mode-map, and its mode to be foo-mode. Set the comint-mode hooks
-;;; (comint-prompt-regexp, comint-input-filter, comint-input-sentinel,
-;;; comint-get-old-input) that need to be different from the defaults. Call
-;;; foo-mode-hook, and you're done. Don't run the comint-mode hook yourself;
-;;; comint-mode will take care of it.
-;;;
-;;; Note that make-comint is different from make-shell in that it
-;;; doesn't have a default program argument. If you give make-shell
-;;; a program name of NIL, it cleverly chooses one of explicit-shell-name,
-;;; $ESHELL, $SHELL, or /bin/sh. If you give make-comint a program argument
-;;; of NIL, it barfs. Adjust your code accordingly...
diff --git a/lisp/compare-w.el b/lisp/compare-w.el
new file mode 100644
index 00000000000..cdc93f74f62
--- /dev/null
+++ b/lisp/compare-w.el
@@ -0,0 +1,59 @@
+;; Compare text between windows for Emacs.
+;; Copyright (C) 1986 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+(defun compare-windows ()
+ "Compare text in current window with text in next window.
+Compares the text starting at point in each window,
+moving over text in each one as far as they match."
+ (interactive)
+ (let (p1 p2 maxp1 maxp2 b1 b2 w2
+ success size
+ (opoint (point)))
+ (setq p1 (point) b1 (current-buffer))
+ (setq w2 (next-window (selected-window)))
+ (if (eq w2 (selected-window))
+ (error "No other window."))
+ (setq p2 (window-point w2)
+ b2 (window-buffer w2))
+ (setq maxp1 (point-max))
+ (save-excursion
+ (set-buffer b2)
+ (setq maxp2 (point-max)))
+
+ ;; Try advancing comparing 1000 chars at a time.
+ ;; When that fails, go 500 chars at a time, and so on.
+ (setq size 1000)
+ (while (> size 0)
+ (setq success t)
+ (while success
+ (setq size (min size (- maxp1 p1) (- maxp2 p2)))
+ (save-excursion
+ (set-buffer b2)
+ (setq s2 (buffer-substring p2 (+ size p2))))
+ (setq s1 (buffer-substring p1 (+ size p1)))
+ (setq success (and (> size 0) (equal s1 s2)))
+ (if success
+ (setq p1 (+ p1 size) p2 (+ p2 size))))
+ (setq size (/ size 2)))
+
+ (goto-char p1)
+ (set-window-point w2 p2)
+ (if (= (point) opoint)
+ (ding))))
diff --git a/lisp/compare-w.elc b/lisp/compare-w.elc
new file mode 100644
index 00000000000..fea719725b3
--- /dev/null
+++ b/lisp/compare-w.elc
Binary files differ
diff --git a/lisp/compile.el b/lisp/compile.el
new file mode 100644
index 00000000000..1796d40fcf2
--- /dev/null
+++ b/lisp/compile.el
@@ -0,0 +1,318 @@
+;; Run compiler as inferior of Emacs, and parse its error messages.
+;; Copyright (C) 1985, 1986 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+(provide 'compile)
+
+(defvar compilation-process nil
+ "Process created by compile command, or nil if none exists now.
+Note that the process may have been \"deleted\" and still
+be the value of this variable.")
+
+(defvar compilation-error-list nil
+ "List of error message descriptors for visiting erring functions.
+Each error descriptor is a list of length two.
+Its car is a marker pointing to an error message.
+Its cadr is a marker pointing to the text of the line the message is about,
+ or nil if that is not interesting.
+The value may be t instead of a list;
+this means that the buffer of error messages should be reparsed
+the next time the list of errors is wanted.")
+
+(defvar compilation-parsing-end nil
+ "Position of end of buffer when last error messages parsed.")
+
+(defvar compilation-error-message nil
+ "Message to print when no more matches for compilation-error-regexp are found")
+
+;; The filename excludes colons to avoid confusion when error message
+;; starts with digits.
+(defvar compilation-error-regexp
+ "\\([^ :\n]+\\(: *\\|, line \\|(\\)[0-9]+\\)\\|\\([0-9]+ *of *[^ \n]+\\)"
+ "Regular expression for filename/linenumber in error in compilation log.")
+
+(defun compile (command)
+ "Compile the program including the current buffer. Default: run `make'.
+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 source code that caused it."
+ (interactive (list (read-string "Compile command: " compile-command)))
+ (setq compile-command command)
+ (compile1 compile-command "No more errors"))
+
+(defun grep (command)
+ "Run grep, with user-specified args, and collect output in a buffer.
+While grep runs asynchronously, you can use the \\[next-error] command
+to find the text that grep hits refer to."
+ (interactive "sRun grep (with args): ")
+ (compile1 (concat "grep -n " command " /dev/null")
+ "No more grep hits" "grep"))
+
+(defun compile1 (command error-message &optional name-of-mode)
+ (save-some-buffers)
+ (if compilation-process
+ (if (or (not (eq (process-status compilation-process) 'run))
+ (yes-or-no-p "A compilation process is running; kill it? "))
+ (condition-case ()
+ (if compilation-process
+ (let ((comp-proc compilation-process))
+ (interrupt-process comp-proc)
+ (sit-for 1)
+ (delete-process comp-proc)))
+ (error nil))
+ (error "Cannot have two compilation processes")))
+ (setq compilation-process nil)
+ (compilation-forget-errors)
+ (setq compilation-error-list t)
+ (setq compilation-error-message error-message)
+ (setq compilation-process
+ (start-process "compilation" "*compilation*"
+ shell-file-name
+ "-c" (concat "exec " command)))
+ (with-output-to-temp-buffer "*compilation*"
+ (princ "cd ")
+ (princ default-directory)
+ (terpri)
+ (princ command)
+ (terpri))
+ (set-process-sentinel compilation-process 'compilation-sentinel)
+ (let* ((thisdir default-directory)
+ (outbuf (process-buffer compilation-process))
+ (outwin (get-buffer-window outbuf))
+ (regexp compilation-error-regexp))
+ (if (eq outbuf (current-buffer))
+ (goto-char (point-max)))
+ (save-excursion
+ (set-buffer outbuf)
+ (buffer-flush-undo outbuf)
+ (let ((start (save-excursion (set-buffer outbuf) (point-min))))
+ (set-window-start outwin start)
+ (or (eq outwin (selected-window))
+ (set-window-point outwin start)))
+ (setq default-directory thisdir)
+ (fundamental-mode)
+ (make-local-variable 'compilation-error-regexp)
+ (setq compilation-error-regexp regexp)
+ (setq mode-name (or name-of-mode "Compilation"))
+ ;; Make log buffer's mode line show process state
+ (setq mode-line-process '(": %s")))))
+
+;; Called when compilation process changes state.
+
+(defun compilation-sentinel (proc msg)
+ (cond ((null (buffer-name (process-buffer proc)))
+ ;; buffer killed
+ (set-process-buffer proc nil))
+ ((memq (process-status proc) '(signal exit))
+ (let* ((obuf (current-buffer))
+ omax opoint)
+ ;; save-excursion isn't the right thing if
+ ;; process-buffer is current-buffer
+ (unwind-protect
+ (progn
+ ;; Write something in *compilation* and hack its mode line,
+ (set-buffer (process-buffer proc))
+ (setq omax (point-max) opoint (point))
+ (goto-char (point-max))
+ (insert ?\n mode-name " " msg)
+ (forward-char -1)
+ (insert " at "
+ (substring (current-time-string) 0 -5))
+ (forward-char 1)
+ (setq mode-line-process
+ (concat ": "
+ (symbol-name (process-status proc))))
+ ;; If buffer and mode line will show that the process
+ ;; is dead, we can delete it now. Otherwise it
+ ;; will stay around until M-x list-processes.
+ (delete-process proc))
+ (setq compilation-process nil)
+ ;; Force mode line redisplay soon
+ (set-buffer-modified-p (buffer-modified-p)))
+ (if (and opoint (< opoint omax))
+ (goto-char opoint))
+ (set-buffer obuf)))))
+
+(defun kill-compilation ()
+ "Kill the process made by the \\[compile] command."
+ (interactive)
+ (if compilation-process
+ (interrupt-process compilation-process)))
+
+(defun kill-grep ()
+ "Kill the process made by the \\[grep] command."
+ (interactive)
+ (if compilation-process
+ (interrupt-process compilation-process)))
+
+(defun next-error (&optional argp)
+ "Visit next compilation error message and corresponding source code.
+This operates on the output from the \\[compile] command.
+If all preparsed error messages have been processed,
+the error message buffer is checked for new ones.
+A non-nil argument (prefix arg, if interactive)
+means reparse the error message buffer and start at the first error."
+ (interactive "P")
+ (if (or (eq compilation-error-list t)
+ argp)
+ (progn (compilation-forget-errors)
+ (setq compilation-parsing-end 1)))
+ (if compilation-error-list
+ nil
+ (save-excursion
+ (set-buffer "*compilation*")
+ (set-buffer-modified-p nil)
+ (compilation-parse-errors)))
+ (let ((next-error (car compilation-error-list)))
+ (if (null next-error)
+ (error (concat compilation-error-message
+ (if (and compilation-process
+ (eq (process-status compilation-process)
+ 'run))
+ " yet" ""))))
+ (setq compilation-error-list (cdr compilation-error-list))
+ (if (null (car (cdr next-error)))
+ nil
+ (switch-to-buffer (marker-buffer (car (cdr next-error))))
+ (goto-char (car (cdr next-error)))
+ (set-marker (car (cdr next-error)) nil))
+ (let* ((pop-up-windows t)
+ (w (display-buffer (marker-buffer (car next-error)))))
+ (set-window-point w (car next-error))
+ (set-window-start w (car next-error)))
+ (set-marker (car next-error) nil)))
+
+;; Set compilation-error-list to nil, and
+;; unchain the markers that point to the error messages and their text,
+;; so that they no longer slow down gap motion.
+;; This would happen anyway at the next garbage collection,
+;; but it is better to do it right away.
+(defun compilation-forget-errors ()
+ (if (eq compilation-error-list t)
+ (setq compilation-error-list nil))
+ (while compilation-error-list
+ (let ((next-error (car compilation-error-list)))
+ (set-marker (car next-error) nil)
+ (if (car (cdr next-error))
+ (set-marker (car (cdr next-error)) nil)))
+ (setq compilation-error-list (cdr compilation-error-list))))
+
+(defun compilation-parse-errors ()
+ "Parse the current buffer as error messages.
+This makes a list of error descriptors, compilation-error-list.
+For each source-file, line-number pair in the buffer,
+the source file is read in, and the text location is saved in compilation-error-list.
+The function next-error, assigned to \\[next-error], takes the next error off the list
+and visits its location."
+ (setq compilation-error-list nil)
+ (message "Parsing error messages...")
+ (let (text-buffer
+ last-filename last-linenum)
+ ;; Don't reparse messages already seen at last parse.
+ (goto-char compilation-parsing-end)
+ ;; Don't parse the first two lines as error messages.
+ ;; This matters for grep.
+ (if (bobp)
+ (forward-line 2))
+ (while (re-search-forward compilation-error-regexp nil t)
+ (let (linenum filename
+ error-marker text-marker)
+ ;; Extract file name and line number from error message.
+ (save-restriction
+ (narrow-to-region (match-beginning 0) (match-end 0))
+ (goto-char (point-max))
+ (skip-chars-backward "[0-9]")
+ ;; If it's a lint message, use the last file(linenum) on the line.
+ ;; Normally we use the first on the line.
+ (if (= (preceding-char) ?\()
+ (progn
+ (narrow-to-region (point-min) (1+ (buffer-size)))
+ (end-of-line)
+ (re-search-backward compilation-error-regexp)
+ (skip-chars-backward "^ \t\n")
+ (narrow-to-region (point) (match-end 0))
+ (goto-char (point-max))
+ (skip-chars-backward "[0-9]")))
+ ;; Are we looking at a "filename-first" or "line-number-first" form?
+ (if (looking-at "[0-9]")
+ (progn
+ (setq linenum (read (current-buffer)))
+ (goto-char (point-min)))
+ ;; Line number at start, file name at end.
+ (progn
+ (goto-char (point-min))
+ (setq linenum (read (current-buffer)))
+ (goto-char (point-max))
+ (skip-chars-backward "^ \t\n")))
+ (setq filename (compilation-grab-filename)))
+ ;; Locate the erring file and line.
+ (if (and (equal filename last-filename)
+ (= linenum last-linenum))
+ nil
+ (beginning-of-line 1)
+ (setq error-marker (point-marker))
+ ;; text-buffer gets the buffer containing this error's file.
+ (if (not (equal filename last-filename))
+ (setq text-buffer
+ (and (file-exists-p (setq last-filename filename))
+ (find-file-noselect filename))
+ last-linenum 0))
+ (if text-buffer
+ ;; Go to that buffer and find the erring line.
+ (save-excursion
+ (set-buffer text-buffer)
+ (if (zerop last-linenum)
+ (progn
+ (goto-char 1)
+ (setq last-linenum 1)))
+ ;; Move the right number of lines from the old position.
+ ;; If we can't move that many, put 0 in last-linenum
+ ;; so the next error message will be handled starting from
+ ;; scratch.
+ (if (eq selective-display t)
+ (or (re-search-forward "[\n\C-m]" nil 'end
+ (- linenum last-linenum))
+ (setq last-linenum 0))
+ (or (= 0 (forward-line (- linenum last-linenum)))
+ (setq last-linenum 0)))
+ (setq last-linenum linenum)
+ (setq text-marker (point-marker))
+ (setq compilation-error-list
+ (cons (list error-marker text-marker)
+ compilation-error-list)))))
+ (forward-line 1)))
+ (setq compilation-parsing-end (point-max)))
+ (message "Parsing error messages...done")
+ (setq compilation-error-list (nreverse compilation-error-list)))
+
+(defun compilation-grab-filename ()
+ "Return a string which is a filename, starting at point.
+Ignore quotes and parentheses around it, as well as trailing colons."
+ (if (eq (following-char) ?\")
+ (save-restriction
+ (narrow-to-region (point)
+ (progn (forward-sexp 1) (point)))
+ (goto-char (point-min))
+ (read (current-buffer)))
+ (buffer-substring (point)
+ (progn
+ (skip-chars-forward "^ :,\n\t(")
+ (point)))))
+
+(define-key ctl-x-map "`" 'next-error)
diff --git a/lisp/compile.elc b/lisp/compile.elc
new file mode 100644
index 00000000000..bf2ba5bd84f
--- /dev/null
+++ b/lisp/compile.elc
Binary files differ
diff --git a/lisp/completion.el b/lisp/completion.el
deleted file mode 100644
index 9d478e78630..00000000000
--- a/lisp/completion.el
+++ /dev/null
@@ -1,3113 +0,0 @@
-;;; This is a Completion system for GNU Emacs
-;;;
-;;; E-Mail:
-;;; Internet: completion@think.com, bug-completion@think.com
-;;; UUCP: {rutgers,harvard,mit-eddie}!think!completion
-;;;
-;;; If you are a new user, we'd appreciate knowing your site name and
-;;; any comments you have.
-;;;
-;;;
-;;; NO WARRANTY
-;;;
-;;; This software is distributed free of charge and is in the public domain.
-;;; Anyone may use, duplicate or modify this program. Thinking Machines
-;;; Corporation does not restrict in any way the use of this software by
-;;; anyone.
-;;;
-;;; Thinking Machines Corporation provides absolutely no warranty of any kind.
-;;; The entire risk as to the quality and performance of this program is with
-;;; you. In no event will Thinking Machines Corporation be liable to you for
-;;; damages, including any lost profits, lost monies, or other special,
-;;; incidental or consequential damages arising out of the use of this program.
-;;;
-;;; You must not restrict the distribution of this software.
-;;;
-;;; Please keep this notice and author information in any copies you make.
-;;;
-;;; 4/90
-;;;
-;;;
-;;; Advertisement
-;;;---------------
-;;; Try using this. If you are like most you will be happy you did.
-;;;
-;;; What to put in .emacs
-;;;-----------------------
-;;; (load "completion") ;; If it's not part of the standard band.
-;;; (initialize-completions)
-;;;
-;;; For best results, be sure to byte-compile the file first.
-;;;
-
-;;; Authors
-;;;---------
-;;; Jim Salem {salem@think.com}
-;;; Brewster Kahle {brewster@think.com}
-;;; Thinking Machines Corporation
-;;; 245 First St., Cambridge MA 02142 (617) 876-1111
-;;;
-;;; Mailing Lists
-;;;---------------
-;;;
-;;; Bugs to bug-completion@think.com
-;;; Comments to completion@think.com
-;;; Requests to be added completion-request@think.com
-;;;
-;;; Availability
-;;;--------------
-;;; Anonymous FTP from think.com
-;;;
-
-;;;---------------------------------------------------------------------------
-;;; Documentation [Slightly out of date]
-;;;---------------------------------------------------------------------------
-;;; (also check the documentation string of the functions)
-;;;
-;;; Introduction
-;;;---------------
-;;;
-;;; After you type a few characters, pressing the "complete" key inserts
-;;; the rest of the word you are likely to type.
-;;;
-;;; This watches all the words that you type and remembers them. When
-;;; typing a new word, pressing "complete" (meta-return) "completes" the
-;;; word by inserting the most recently used word that begins with the
-;;; same characters. If you press meta-return repeatedly, it cycles
-;;; through all the words it knows about.
-;;;
-;;; If you like the completion then just continue typing, it is as if you
-;;; entered the text by hand. If you want the inserted extra characters
-;;; to go away, type control-w or delete. More options are described below.
-;;;
-;;; The guesses are made in the order of the most recently "used". Typing
-;;; in a word and then typing a separator character (such as a space) "uses"
-;;; the word. So does moving a cursor over the word. If no words are found,
-;;; it uses an extended version of the dabbrev style completion.
-;;;
-;;; You automatically save the completions you use to a file between
-;;; sessions.
-;;;
-;;; Completion enables programmers to enter longer, more descriptive
-;;; variable names while typing fewer keystrokes than they normally would.
-;;;
-;;;
-;;; Full documentation
-;;;---------------------
-;;;
-;;; A "word" is any string containing characters with either word or symbol
-;;; syntax. [E.G. Any alphanumeric string with hypens, underscores, etc.]
-;;; Unless you change the constants, you must type at least three characters
-;;; for the word to be recognized. Only words longer than 6 characters are
-;;; saved.
-;;;
-;;; When you load this file, completion will be on. I suggest you use the
-;;; compiled version (because it is noticibly faster).
-;;;
-;;; M-X completion-mode toggles whether or not new words are added to the
-;;; database by changing the value of *completep*.
-;;;
-;;; SAVING/LOADING COMPLETIONS
-;;; Completions are automatically saved from one session to another
-;;; (unless *save-completions-p* or *completep* is nil).
-;;; Loading this file (or calling initialize-completions) causes EMACS
-;;; to load a completions database for a saved completions file
-;;; (default: ~/.completions). When you exit, EMACS saves a copy of the
-;;; completions that you
-;;; often use. When you next start, EMACS loads in the saved completion file.
-;;;
-;;; The number of completions saved depends loosely on
-;;; *saved-completions-decay-factor*. Completions that have never been
-;;; inserted via "complete" are not saved. You are encouraged to experiment
-;;; with different functions (see compute-completion-min-num-uses).
-;;;
-;;; Some completions are permanent and are always saved out. These
-;;; completions have their num-uses slot set to T. Use
-;;; add-permanent-completion to do this
-;;;
-;;; Completions are saved only if *completep* is T. The number of old
-;;; versions kept of the saved completions file is controlled by
-;;; *completion-file-versions-kept*.
-;;;
-;;; COMPLETE KEY OPTIONS
-;;; The complete function takes a numeric arguments.
-;;; control-u :: leave the point at the beginning of the completion rather
-;;; than the middle.
-;;; a number :: rotate through the possible completions by that amount
-;;; `-' :: same as -1 (insert previous completion)
-;;;
-;;; HOW THE DATABASE IS MAINTAINED
-;;; <write>
-;;;
-;;; UPDATING THE DATABASE MANUALLY
-;;; m-x kill-completion
-;;; kills the completion at point.
-;;; m-x add-completion
-;;; m-x add-permanent-completion
-;;;
-;;; UPDATING THE DATABASE FROM A SOURCE CODE FILE
-;;; m-x add-completions-from-buffer
-;;; Parses all the definition names from a C or LISP mode buffer and
-;;; adds them to the completion database.
-;;;
-;;; m-x add-completions-from-lisp-file
-;;; Parses all the definition names from a C or Lisp mode file and
-;;; adds them to the completion database.
-;;;
-;;; UPDATING THE DATABASE FROM A TAGS TABLE
-;;; m-x add-completions-from-tags-table
-;;; Adds completions from the current tags-table-buffer.
-;;;
-;;; HOW A COMPLETION IS FOUND
-;;; <write>
-;;;
-;;; STRING CASING
-;;; Completion is string case independent if case-fold-search has its
-;;; normal default of T. Also when the completion is inserted the case of the
-;;; entry is coerced appropriately.
-;;; [E.G. APP --> APPROPRIATELY app --> appropriately
-;;; App --> Appropriately]
-;;;
-;;; INITIALIZATION
-;;; The form `(initialize-completions)' initializes the completion system by
-;;; trying to load in the user's completions. After the first cal, further
-;;; calls have no effect so one should be careful not to put the form in a
-;;; site's standard site-init file.
-;;;
-;;;---------------------------------------------------------------------------
-;;;
-;;;
-
-;;;-----------------------------------------------
-;;; Porting Notes
-;;;-----------------------------------------------
-;;;
-;;; Should run on 18.49, 18.52, and 19.0
-;;; Tested on vanilla version.
-;;; This requires the standard cl.el file. It could easily rewritten to not
-;;; require it. It defines remove which is not in cl.el.
-;;;
-;;; FUNCTIONS BASHED
-;;; The following functions are bashed but it is done carefully and should not
-;;; cause problems ::
-;;; kill-region, next-line, previous-line, newline, newline-and-indent,
-;;; kill-emacs
-;;;
-;;;
-;;;---------------------------------------------------------------------------
-;;; Functions you might like to call
-;;;---------------------------------------------------------------------------
-;;;
-;;; add-completion string &optional num-uses
-;;; Adds a new string to the database
-;;;
-;;; add-permanent-completion string
-;;; Adds a new string to the database with num-uses = T
-;;;
-
-;;; kill-completion string
-;;; Kills the completion from the database.
-;;;
-;;; clear-all-completions
-;;; Clears the database
-;;;
-;;; list-all-completions
-;;; Returns a list of all completions.
-;;;
-;;;
-;;; next-completion string &optional index
-;;; Returns a completion entry that starts with string.
-;;;
-;;; find-exact-completion string
-;;; Returns a completion entry that exactly matches string.
-;;;
-;;; complete
-;;; Inserts a completion at point
-;;;
-;;; initialize-completions
-;;; Loads the completions file and sets up so that exiting emacs will
-;;; save them.
-;;;
-;;; save-completions-to-file &optional filename
-;;; load-completions-from-file &optional filename
-;;;
-;;;-----------------------------------------------
-;;; Other functions
-;;;-----------------------------------------------
-;;;
-;;; get-completion-list string
-;;;
-;;; These things are for manipulating the structure
-;;; make-completion string num-uses
-;;; completion-num-uses completion
-;;; completion-string completion
-;;; set-completion-num-uses completion num-uses
-;;; set-completion-string completion string
-;;;
-;;;
-
-;;;-----------------------------------------------
-;;; To Do :: (anybody ?)
-;;;-----------------------------------------------
-;;;
-;;; Implement Lookup and keyboard interface in C
-;;; Add package prefix smarts (for Common Lisp)
-;;; Add autoprompting of possible completions after every keystroke (fast
-;;; terminals only !)
-;;; Add doc. to texinfo
-;;;
-;;;
-;;;-----------------------------------------------
-;;; History ::
-;;;-----------------------------------------------
-;;; Sometime in '84 Brewster implemented a somewhat buggy version for
-;;; Symbolics LISPMs.
-;;; Jan. '85 Jim became enamored of the idea and implemented a faster,
-;;; more robust version.
-;;; With input from many users at TMC, (rose, craig, and gls come to mind),
-;;; the current style of interface was developed.
-;;; 9/87, Jim and Brewster took terminals home. Yuck. After
-;;; complaining for a while Brewester implemented a subset of the current
-;;; LISPM version for GNU Emacs.
-;;; 8/88 After complaining for a while (and with sufficient
-;;; promised rewards), Jim reimplemented a version of GNU completion
-;;; superior to that of the LISPM version.
-;;;
-;;;-----------------------------------------------
-;;; Acknowlegements
-;;;-----------------------------------------------
-;;; Cliff Lasser (cal@think.com), Kevin Herbert (kph@cisco.com),
-;;; eero@media-lab, kgk@cs.brown.edu, jla@ai.mit.edu,
-;;;
-;;;-----------------------------------------------
-;;; Change Log
-;;;-----------------------------------------------
-;;; From version 9 to 10
-;;; - Allowance for non-integral *completion-version* nos.
-;;; - Fix cmpl-apply-as-top-level for keyboard macros
-;;; - Fix broken completion merging (in save-completions-to-file)
-;;; - More misc. fixes for version 19.0 of emacs
-;;;
-;;; From Version 8 to 9
-;;; - Ported to version 19.0 of emacs (backcompatible with version 18)
-;;; - Added add-completions-from-tags-table (with thanks to eero@media-lab)
-;;;
-;;; From Version 7 to 8
-;;; - Misc. changes to comments
-;;; - new completion key bindings: c-x o, M->, M-<, c-a, c-e
-;;; - cdabbrev now checks all the visible window buffers and the "other buffer"
-;;; - `%' is now a symbol character rather than a separator (except in C mode)
-;;;
-;;; From Version 6 to 7
-;;; - Fixed bug with saving out .completion file the first time
-;;;
-;;; From Version 5 to 6
-;;; - removed statistics recording
-;;; - reworked advise to handle autoloads
-;;; - Fixed fortran mode support
-;;; - Added new cursor motion triggers
-;;;
-;;; From Version 4 to 5
-;;; - doesn't bother saving if nothing has changed
-;;; - auto-save if haven't used for a 1/2 hour
-;;; - save period extended to two weeks
-;;; - minor fix to capitalization code
-;;; - added *completion-auto-save-period* to variables recorded.
-;;; - added reenter protection to cmpl-record-statistics-filter
-;;; - added backup protection to save-completions-to-file (prevents
-;;; problems with disk full errors)
-
-;;;-----------------------------------------------
-;;; Requires
-;;; Version
-;;;-----------------------------------------------
-
-;;(require 'cl) ;; DOTIMES, etc. {actually done after variable defs.}
-
-(defconst *completion-version* 10
- "Tested for EMACS versions 18.49, 18.52, 18.55 and beyond and 19.0.")
-
-;;;---------------------------------------------------------------------------
-;;; User changeable parameters
-;;;---------------------------------------------------------------------------
-
-(defvar *completep* t
- "*Set to nil to turn off the completion hooks.
-(No new words added to the database or saved to the init file).")
-
-(defvar *save-completions-p* t
- "*If non-nil, the most useful completions are saved to disk when
-exiting EMACS. See *saved-completions-decay-factor*.")
-
-(defvar *saved-completions-filename* "~/.completions"
- "*The filename to save completions to.")
-
-(defvar *saved-completion-retention-time* 336
- "*The maximum amount of time to save a completion for if it has not been used.
-In hours. (1 day = 24, 1 week = 168). If this is 0, non-permanent completions
-will not be saved unless these are used. Default is two weeks.")
-
-(defvar *separator-character-uses-completion-p* nil
- "*If non-nil, typing a separator character after a completion symbol that
-is not part of the database marks it as used (so it will be saved).")
-
-(defvar *completion-file-versions-kept* kept-new-versions
- "*Set this to the number of versions you want save-completions-to-file
-to keep.")
-
-(defvar *print-next-completion-speed-threshold* 4800
- "*The baud rate at or above which to print the next potential completion
-after inserting the current one."
- )
-
-(defvar *print-next-completion-does-cdabbrev-search-p* nil
- "*If non-nil, the next completion prompt will also do a cdabbrev search.
-This can be time consuming.")
-
-(defvar *cdabbrev-radius* 15000
- "*How far to search for cdabbrevs. In number of characters. If nil, the
-whole buffer is searched.")
-
-(defvar *modes-for-completion-find-file-hook* '(lisp c)
- "*A list of modes {either C or Lisp}. Definitions from visited files
-of those types are automatically added to the completion database.")
-
-(defvar *record-cmpl-statistics-p* nil
- "*If non-nil, statistics are automatically recorded.")
-
-(defvar *completion-auto-save-period* 1800
- "*The period in seconds to wait for emacs to be idle before autosaving
-the completions. Default is a 1/2 hour.")
-
-(defconst *completion-min-length* nil ;; defined below in eval-when
- "*The minimum length of a stored completion.
-DON'T CHANGE WITHOUT RECOMPILING ! This is used by macros.")
-
-(defconst *completion-max-length* nil ;; defined below in eval-when
- "*The maximum length of a stored completion.
-DON'T CHANGE WITHOUT RECOMPILING ! This is used by macros.")
-
-(defconst *completion-prefix-min-length* nil ;; defined below in eval-when
- "The minimum length of a completion search string.
-DON'T CHANGE WITHOUT RECOMPILING ! This is used by macros.")
-
-(defmacro eval-when-compile-load-eval (&rest body)
- ;; eval everything before expanding
- (mapcar 'eval body)
- (cons 'progn body))
-
-(defun completion-eval-when ()
- (eval-when-compile-load-eval
- ;; These vars. are defined at both compile and load time.
- (setq *completion-min-length* 6)
- (setq *completion-max-length* 200)
- (setq *completion-prefix-min-length* 3)
- ;; Need this file around too
- (require 'cl)))
-
-(completion-eval-when)
-
-;;;---------------------------------------------------------------------------
-;;; Internal Variables
-;;;---------------------------------------------------------------------------
-
-(defvar cmpl-initialized-p nil
- "Set to t when the completion system is initialized. Indicates that the
-old completion file has been read in.")
-
-(defvar cmpl-completions-accepted-p nil
- "Set to T as soon as the first completion has been accepted. Used to
-decide whether to save completions.")
-
-
-;;;---------------------------------------------------------------------------
-;;; Low level tools
-;;;---------------------------------------------------------------------------
-
-;;;-----------------------------------------------
-;;; Misc.
-;;;-----------------------------------------------
-
-(defun remove (item list)
- (setq list (copy-sequence list))
- (delq item list))
-
-(defun minibuffer-window-selected-p ()
- "True iff the current window is the minibuffer."
- (eq (minibuffer-window) (selected-window)))
-
-(eval-when-compile-load-eval
-(defun function-needs-autoloading-p (symbol)
- ;; True iff symbol is represents an autoloaded function and has not yet been
- ;; autoloaded.
- (and (listp (symbol-function symbol))
- (eq 'autoload (car (symbol-function symbol)))
- )))
-
-(defun function-defined-and-loaded (symbol)
- ;; True iff symbol is bound to a loaded function.
- (and (fboundp symbol) (not (function-needs-autoloading-p symbol))))
-
-(defmacro read-time-eval (form)
- ;; Like the #. reader macro
- (eval form))
-
-;;;-----------------------------------------------
-;;; Emacs Version 19 compatibility
-;;;-----------------------------------------------
-
-(defconst emacs-is-version-19 (string= (substring emacs-version 0 2) "19"))
-
-(defun cmpl19-baud-rate ()
- (if emacs-is-version-19
- baud-rate
- (baud-rate)))
-
-(defun cmpl19-sit-for (amount)
- (if (and emacs-is-version-19 (= amount 0))
- (sit-for 1 t)
- (sit-for amount)))
-
-;;;-----------------------------------------------
-;;; Advise
-;;;-----------------------------------------------
-
-(defmacro completion-advise (function-name where &rest body)
- "Adds the body code before calling function. This advise is not compiled.
-WHERE is either :BEFORE or :AFTER."
- (completion-advise-1 function-name where body)
- )
-
-(defmacro cmpl-apply-as-top-level (function arglist)
- "Calls function-name interactively if inside a call-interactively."
- (list 'cmpl-apply-as-top-level-1 function arglist
- '(let ((executing-macro nil)) (interactive-p)))
- )
-
-(defun cmpl-apply-as-top-level-1 (function arglist interactive-p)
- (if (and interactive-p (commandp function))
- (call-interactively function)
- (apply function arglist)
- ))
-
-(eval-when-compile-load-eval
-
-(defun cmpl-defun-preamble (function-name)
- (let ((doc-string
- (condition-case e
- ;; This condition-case is here to stave
- ;; off bizarre load time errors 18.52 gets
- ;; on the function c-mode
- (documentation function-name)
- (error nil)))
- (interactivep (commandp function-name))
- )
- (append
- (if doc-string (list doc-string))
- (if interactivep '((interactive)))
- )))
-
-(defun completion-advise-1 (function-name where body &optional new-name)
- (unless new-name (setq new-name function-name))
- (let ((quoted-name (list 'quote function-name))
- (quoted-new-name (list 'quote new-name))
- )
-
- (cond ((function-needs-autoloading-p function-name)
- (list* 'defun function-name '(&rest arglist)
- (append
- (cmpl-defun-preamble function-name)
- (list (list 'load (second (symbol-function function-name)))
- (list 'eval
- (list 'completion-advise-1 quoted-name
- (list 'quote where) (list 'quote body)
- quoted-new-name))
- (list 'cmpl-apply-as-top-level quoted-new-name 'arglist)
- )))
- )
- (t
- (let ((old-def-name
- (intern (concat "$$$cmpl-" (symbol-name function-name))))
- )
-
- (list 'progn
- (list 'defvar old-def-name
- (list 'symbol-function quoted-name))
- (list* 'defun new-name '(&rest arglist)
- (append
- (cmpl-defun-preamble function-name)
- (ecase where
- (:before
- (list (cons 'progn body)
- (list 'cmpl-apply-as-top-level
- old-def-name 'arglist)))
- (:after
- (list* (list 'cmpl-apply-as-top-level
- old-def-name 'arglist)
- body)
- )))
- )))
- ))))
-) ;; eval-when
-
-
-;;;-----------------------------------------------
-;;; String case coercion
-;;;-----------------------------------------------
-
-(defun cmpl-string-case-type (string)
- "Returns :capitalized, :up, :down, :mixed, or :neither."
- (let ((case-fold-search nil))
- (cond ((string-match "[a-z]" string)
- (cond ((string-match "[A-Z]" string)
- (cond ((and (> (length string) 1)
- (null (string-match "[A-Z]" string 1)))
- ':capitalized)
- (t
- ':mixed)))
- (t ':down)))
- (t
- (cond ((string-match "[A-Z]" string)
- ':up)
- (t ':neither))))
- ))
-
-;;; Tests -
-;;; (cmpl-string-case-type "123ABCDEF456") --> :up
-;;; (cmpl-string-case-type "123abcdef456") --> :down
-;;; (cmpl-string-case-type "123aBcDeF456") --> :mixed
-;;; (cmpl-string-case-type "123456") --> :neither
-;;; (cmpl-string-case-type "Abcde123") --> :capitalized
-
-(defun cmpl-coerce-string-case (string case-type)
- (cond ((eq case-type ':down) (downcase string))
- ((eq case-type ':up) (upcase string))
- ((eq case-type ':capitalized)
- (setq string (downcase string))
- (aset string 0 (logand ?\337 (aref string 0)))
- string)
- (t string)
- ))
-
-(defun cmpl-merge-string-cases (string-to-coerce given-string)
- (let ((string-case-type (cmpl-string-case-type string-to-coerce))
- )
- (cond ((memq string-case-type '(:down :up :capitalized))
- ;; Found string is in a standard case. Coerce to a type based on
- ;; the given string
- (cmpl-coerce-string-case string-to-coerce
- (cmpl-string-case-type given-string))
- )
- (t
- ;; If the found string is in some unusual case, just insert it
- ;; as is
- string-to-coerce)
- )))
-
-;;; Tests -
-;;; (cmpl-merge-string-cases "AbCdEf456" "abc") --> AbCdEf456
-;;; (cmpl-merge-string-cases "abcdef456" "ABC") --> ABCDEF456
-;;; (cmpl-merge-string-cases "ABCDEF456" "Abc") --> Abcdef456
-;;; (cmpl-merge-string-cases "ABCDEF456" "abc") --> abcdef456
-
-
-;;;-----------------------------------------------
-;;; Emacs Idle Time hooks
-;;;-----------------------------------------------
-
-(defvar cmpl-emacs-idle-process nil)
-
-(defvar cmpl-emacs-idle-interval 150
- "Seconds between running the Emacs idle process.")
-
-(defun init-cmpl-emacs-idle-process ()
- "Initialize the emacs idle process."
- (let ((live (and cmpl-emacs-idle-process
- (eq (process-status cmpl-emacs-idle-process) 'run)))
- ;; do not allocate a pty
- (process-connection-type nil))
- (if live
- (kill-process cmpl-emacs-idle-process))
- (if cmpl-emacs-idle-process
- (delete-process cmpl-emacs-idle-process))
- (setq cmpl-emacs-idle-process
- (start-process "cmpl-emacs-idle" nil
- "loadst"
- "-n" (int-to-string cmpl-emacs-idle-interval)))
- (process-kill-without-query cmpl-emacs-idle-process)
- (set-process-filter cmpl-emacs-idle-process 'cmpl-emacs-idle-filter)
- ))
-
-(defvar cmpl-emacs-buffer nil)
-(defvar cmpl-emacs-point 0)
-(defvar cmpl-emacs-last-command nil)
-(defvar cmpl-emacs-last-command-char nil)
-(defun cmpl-emacs-idle-p ()
- ;; returns T if emacs has been idle
- (if (and (eq cmpl-emacs-buffer (current-buffer))
- (= cmpl-emacs-point (point))
- (eq cmpl-emacs-last-command last-command)
- (eq last-command-char last-command-char)
- )
- t ;; idle
- ;; otherwise, update count
- (setq cmpl-emacs-buffer (current-buffer))
- (setq cmpl-emacs-point (point))
- (setq cmpl-emacs-last-command last-command)
- (setq last-command-char last-command-char)
- nil
- ))
-
-(defvar cmpl-emacs-idle-time 0
- "The idle time of Emacs in seconds.")
-
-(defvar inside-cmpl-emacs-idle-filter nil)
-(defvar cmpl-emacs-idle-time-hooks nil)
-
-(defun cmpl-emacs-idle-filter (proc string)
- ;; This gets called every cmpl-emacs-idle-interval seconds
- ;; Update idle time clock
- (if (cmpl-emacs-idle-p)
- (incf cmpl-emacs-idle-time cmpl-emacs-idle-interval)
- (setq cmpl-emacs-idle-time 0))
-
- (unless inside-cmpl-emacs-idle-filter
- ;; Don't reenter if we are hung
-
- (setq inside-cmpl-emacs-idle-filter t)
-
- (dolist (function cmpl-emacs-idle-time-hooks)
- (condition-case e
- (funcall function)
- (error nil)
- ))
- (setq inside-cmpl-emacs-idle-filter nil)
- ))
-
-
-;;;-----------------------------------------------
-;;; Time
-;;;-----------------------------------------------
-;;; What a backwards way to get the time! Unfortunately, GNU Emacs
-;;; doesn't have an accessible time function.
-
-(defconst cmpl-hours-per-day 24)
-(defconst cmpl-hours-per-year (* 365 cmpl-hours-per-day))
-(defconst cmpl-hours-per-4-years (+ (* 4 cmpl-hours-per-year)
- cmpl-hours-per-day))
-(defconst cmpl-days-since-start-of-year
- '(0 31 59 90 120 151 181 212 243 273 304 334))
-(defconst cmpl-days-since-start-of-leap-year
- '(0 31 60 91 121 152 182 213 244 274 305 335))
-(defconst cmpl-months
- '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
-
-(defun cmpl-hours-since-1900-internal (month day year hours)
- "Month is an integer from 1 to 12. Year is a two digit integer (19XX)"
- (+ ;; Year
- (* (/ (1- year) 4) cmpl-hours-per-4-years)
- (* (1+ (mod (1- year) 4)) cmpl-hours-per-year)
- ;; minus two to account for 1968 rather than 1900
- ;; month
- (* cmpl-hours-per-day
- (nth (1- month) (if (zerop (mod year 4))
- cmpl-days-since-start-of-leap-year
- cmpl-days-since-start-of-year)))
- (* (1- day) cmpl-hours-per-day)
- hours))
-
-(defun cmpl-month-from-string (month-string)
- "Month string is a three char. month string"
- (let ((count 1))
- (do ((list cmpl-months (cdr list))
- )
- ((or (null list) (string-equal month-string (car list))))
- (setq count (1+ count)))
- (if (> count 12)
- (error "Unknown month - %s" month-string))
- count))
-
-(defun cmpl-hours-since-1900 (&optional time-string)
- "String is a string in the format of current-time-string (the default)."
- (let* ((string (or time-string (current-time-string)))
- (month (cmpl-month-from-string (substring string 4 7)))
- (day (string-to-int (substring string 8 10)))
- (year (string-to-int (substring string 22 24)))
- (hour (string-to-int (substring string 11 13)))
- )
- (cmpl-hours-since-1900-internal month day year hour)))
-
-;;; Tests -
-;;;(cmpl-hours-since-1900 "Wed Jan 1 00:00:28 1900") --> 35040
-;;;(cmpl-hours-since-1900 "Wed Nov 2 23:00:28 1988") --> 778751
-;;;(cmpl-hours-since-1900 "Wed Jan 23 14:34:28 1988") --> 771926
-;;;(cmpl-hours-since-1900 "Wed Feb 23 14:34:28 1988") --> 772670
-;;;(cmpl-hours-since-1900 "Wed Mar 23 14:34:28 1988") --> 773366
-;;;(cmpl-hours-since-1900 "Wed Apr 23 14:34:28 1988") --> 774110
-;;;(cmpl-hours-since-1900 "Wed May 23 14:34:28 1988") --> 774830
-;;;(cmpl-hours-since-1900 "Wed Jun 23 14:34:28 1988") --> 775574
-;;;(cmpl-hours-since-1900 "Wed Jul 23 14:34:28 1988") --> 776294
-;;;(cmpl-hours-since-1900 "Wed Aug 23 14:34:28 1988") --> 777038
-;;;(cmpl-hours-since-1900 "Wed Sep 23 14:34:28 1988") --> 777782
-;;;(cmpl-hours-since-1900 "Wed Oct 23 14:34:28 1988") --> 778502
-;;;(cmpl-hours-since-1900 "Wed Nov 23 14:34:28 1988") --> 779246
-;;;(cmpl-hours-since-1900 "Wed Dec 23 14:34:28 1988") --> 779966
-;;;(cmpl-hours-since-1900 "Wed Jan 23 14:34:28 1957") --> 500198
-;;;(cmpl-hours-since-1900 "Wed Feb 23 14:34:28 1957") --> 500942
-;;;(cmpl-hours-since-1900 "Wed Mar 23 14:34:28 1957") --> 501614
-;;;(cmpl-hours-since-1900 "Wed Apr 23 14:34:28 1957") --> 502358
-;;;(cmpl-hours-since-1900 "Wed May 23 14:34:28 1957") --> 503078
-;;;(cmpl-hours-since-1900 "Wed Jun 23 14:34:28 1957") --> 503822
-;;;(cmpl-hours-since-1900 "Wed Jul 23 14:34:28 1957") --> 504542
-;;;(cmpl-hours-since-1900 "Wed Aug 23 14:34:28 1957") --> 505286
-;;;(cmpl-hours-since-1900 "Wed Sep 23 14:34:28 1957") --> 506030
-;;;(cmpl-hours-since-1900 "Wed Oct 23 14:34:28 1957") --> 506750
-;;;(cmpl-hours-since-1900 "Wed Nov 23 14:34:28 1957") --> 507494
-;;;(cmpl-hours-since-1900 "Wed Dec 23 14:34:28 1957") --> 508214
-
-
-;;;---------------------------------------------------------------------------
-;;; "Symbol" parsing functions
-;;;---------------------------------------------------------------------------
-;;; The functions symbol-before-point, symbol-under-point, etc. quickly return
-;;; an appropriate symbol string. The strategy is to temporarily change
-;;; the syntax table to enable fast symbol searching. There are three classes
-;;; of syntax in these "symbol" syntax tables ::
-;;;
-;;; syntax (?_) - "symbol" chars (e.g. alphanumerics)
-;;; syntax (?w) - symbol chars to ignore at end of words (e.g. period).
-;;; syntax (? ) - everything else
-;;;
-;;; Thus by judicious use of scan-sexps and forward-word, we can get
-;;; the word we want relatively fast and without consing.
-;;;
-;;; Why do we need a separate category for "symbol chars to ignore at ends" ?
-;;; For example, in LISP we want starting :'s trimmed
-;;; so keyword argument specifiers also define the keyword completion. And,
-;;; for example, in C we want `.' appearing in a structure ref. to
-;;; be kept intact in order to store the whole structure ref.; however, if
-;;; it appears at the end of a symbol it should be discarded because it is
-;;; probably used as a period.
-
-;;; Here is the default completion syntax ::
-;;; Symbol chars :: A-Z a-z 0-9 @ / \ * + ~ $ < > %
-;;; Symbol chars to ignore at ends :: _ : . -
-;;; Separator chars. :: <tab> <space> ! ^ & ( ) = ` | { } [ ] ; " ' #
-;;; , ? <Everything else>
-
-;;; Mode specific differences and notes ::
-;;; LISP diffs ->
-;;; Symbol chars :: ! & ? = ^
-;;;
-;;; C diffs ->
-;;; Separator chars :: + * / : %
-;;; A note on the hypen (`-'). Perhaps, the hypen should also be a separator
-;;; char., however, we wanted to have completion symbols include pointer
-;;; references. For example, "foo->bar" is a symbol as far as completion is
-;;; concerned.
-;;;
-;;; FORTRAN diffs ->
-;;; Separator chars :: + - * / :
-;;;
-;;; Pathname diffs ->
-;;; Symbol chars :: .
-;;; Of course there is no pathname "mode" and in fact we have not implemented
-;;; this table. However, if there was such a mode, this is what it would look
-;;; like.
-
-;;;-----------------------------------------------
-;;; Table definitions
-;;;-----------------------------------------------
-
-(defun make-standard-completion-syntax-table ()
- (let ((table (make-vector 256 0)) ;; default syntax is whitespace
- )
- ;; alpha chars
- (dotimes (i 26)
- (modify-syntax-entry (+ ?a i) "_" table)
- (modify-syntax-entry (+ ?A i) "_" table))
- ;; digit chars.
- (dotimes (i 10)
- (modify-syntax-entry (+ ?0 i) "_" table))
- ;; Other ones
- (let ((symbol-chars '(?@ ?/ ?\\ ?* ?+ ?~ ?$ ?< ?> ?%))
- (symbol-chars-ignore '(?_ ?- ?: ?.))
- )
- (dolist (char symbol-chars)
- (modify-syntax-entry char "_" table))
- (dolist (char symbol-chars-ignore)
- (modify-syntax-entry char "w" table)
- )
- )
- table))
-
-(defconst cmpl-standard-syntax-table (make-standard-completion-syntax-table))
-
-(defun make-lisp-completion-syntax-table ()
- (let ((table (copy-syntax-table cmpl-standard-syntax-table))
- (symbol-chars '(?! ?& ?? ?= ?^))
- )
- (dolist (char symbol-chars)
- (modify-syntax-entry char "_" table))
- table))
-
-(defun make-c-completion-syntax-table ()
- (let ((table (copy-syntax-table cmpl-standard-syntax-table))
- (separator-chars '(?+ ?* ?/ ?: ?%))
- )
- (dolist (char separator-chars)
- (modify-syntax-entry char " " table))
- table))
-
-(defun make-fortran-completion-syntax-table ()
- (let ((table (copy-syntax-table cmpl-standard-syntax-table))
- (separator-chars '(?+ ?- ?* ?/ ?:))
- )
- (dolist (char separator-chars)
- (modify-syntax-entry char " " table))
- table))
-
-(defconst cmpl-lisp-syntax-table (make-lisp-completion-syntax-table))
-(defconst cmpl-c-syntax-table (make-c-completion-syntax-table))
-(defconst cmpl-fortran-syntax-table (make-fortran-completion-syntax-table))
-
-(defvar cmpl-syntax-table cmpl-standard-syntax-table
- "This variable holds the current completion syntax table.")
-(make-variable-buffer-local 'cmpl-syntax-table)
-
-;;;-----------------------------------------------
-;;; Installing the appropriate mode tables
-;;;-----------------------------------------------
-
-(completion-advise lisp-mode-variables :after
- (setq cmpl-syntax-table cmpl-lisp-syntax-table)
- )
-
-(completion-advise c-mode :after
- (setq cmpl-syntax-table cmpl-c-syntax-table)
- )
-
-(completion-advise fortran-mode :after
- (setq cmpl-syntax-table cmpl-fortran-syntax-table)
- (completion-setup-fortran-mode)
- )
-
-;;;-----------------------------------------------
-;;; Symbol functions
-;;;-----------------------------------------------
-(defvar cmpl-symbol-start nil
- "Set to the first character of the symbol after one of the completion
-symbol functions is called.")
-(defvar cmpl-symbol-end nil
- "Set to the last character of the symbol after one of the completion
-symbol functions is called.")
-;;; These are temp. vars. we use to avoid using let.
-;;; Why ? Small speed improvement.
-(defvar cmpl-saved-syntax nil)
-(defvar cmpl-saved-point nil)
-
-(defun symbol-under-point ()
- "Returns the symbol that the point is currently on if it is longer
-than *completion-min-length*."
- (setq cmpl-saved-syntax (syntax-table))
- (set-syntax-table cmpl-syntax-table)
- (cond
- ;; Cursor is on following-char and after preceding-char
- ((memq (char-syntax (following-char)) '(?w ?_))
- (setq cmpl-saved-point (point)
- cmpl-symbol-start (scan-sexps (1+ cmpl-saved-point) -1)
- cmpl-symbol-end (scan-sexps cmpl-saved-point 1))
- ;; remove chars to ignore at the start
- (cond ((= (char-syntax (char-after cmpl-symbol-start)) ?w)
- (goto-char cmpl-symbol-start)
- (forward-word 1)
- (setq cmpl-symbol-start (point))
- (goto-char cmpl-saved-point)
- ))
- ;; remove chars to ignore at the end
- (cond ((= (char-syntax (char-after (1- cmpl-symbol-end))) ?w)
- (goto-char cmpl-symbol-end)
- (forward-word -1)
- (setq cmpl-symbol-end (point))
- (goto-char cmpl-saved-point)
- ))
- ;; restore state
- (set-syntax-table cmpl-saved-syntax)
- ;; Return completion if the length is reasonable
- (if (and (<= (read-time-eval *completion-min-length*)
- (- cmpl-symbol-end cmpl-symbol-start))
- (<= (- cmpl-symbol-end cmpl-symbol-start)
- (read-time-eval *completion-max-length*)))
- (buffer-substring cmpl-symbol-start cmpl-symbol-end))
- )
- (t
- ;; restore table if no symbol
- (set-syntax-table cmpl-saved-syntax)
- nil)
- ))
-
-;;; tests for symbol-under-point
-;;; `^' indicates cursor pos. where value is returned
-;;; simple-word-test
-;;; ^^^^^^^^^^^^^^^^ --> simple-word-test
-;;; _harder_word_test_
-;;; ^^^^^^^^^^^^^^^^^^ --> harder_word_test
-;;; .___.______.
-;;; --> nil
-;;; /foo/bar/quux.hello
-;;; ^^^^^^^^^^^^^^^^^^^ --> /foo/bar/quux.hello
-;;;
-
-(defun symbol-before-point ()
- "Returns a string of the symbol immediately before point
-or nil if there isn't one longer than *completion-min-length*."
- ;; This is called when a word separator is typed so it must be FAST !
- (setq cmpl-saved-syntax (syntax-table))
- (set-syntax-table cmpl-syntax-table)
- ;; Cursor is on following-char and after preceding-char
- (cond ((= (setq cmpl-preceding-syntax (char-syntax (preceding-char))) ?_)
- ;; No chars. to ignore at end
- (setq cmpl-symbol-end (point)
- cmpl-symbol-start (scan-sexps (1+ cmpl-symbol-end) -1)
- )
- ;; remove chars to ignore at the start
- (cond ((= (char-syntax (char-after cmpl-symbol-start)) ?w)
- (goto-char cmpl-symbol-start)
- (forward-word 1)
- (setq cmpl-symbol-start (point))
- (goto-char cmpl-symbol-end)
- ))
- ;; restore state
- (set-syntax-table cmpl-saved-syntax)
- ;; return value if long enough
- (if (>= cmpl-symbol-end
- (+ cmpl-symbol-start
- (read-time-eval *completion-min-length*)))
- (buffer-substring cmpl-symbol-start cmpl-symbol-end))
- )
- ((= cmpl-preceding-syntax ?w)
- ;; chars to ignore at end
- (setq cmpl-saved-point (point)
- cmpl-symbol-start (scan-sexps (1+ cmpl-saved-point) -1))
- ;; take off chars. from end
- (forward-word -1)
- (setq cmpl-symbol-end (point))
- ;; remove chars to ignore at the start
- (cond ((= (char-syntax (char-after cmpl-symbol-start)) ?w)
- (goto-char cmpl-symbol-start)
- (forward-word 1)
- (setq cmpl-symbol-start (point))
- ))
- ;; restore state
- (goto-char cmpl-saved-point)
- (set-syntax-table cmpl-saved-syntax)
- ;; Return completion if the length is reasonable
- (if (and (<= (read-time-eval *completion-min-length*)
- (- cmpl-symbol-end cmpl-symbol-start))
- (<= (- cmpl-symbol-end cmpl-symbol-start)
- (read-time-eval *completion-max-length*)))
- (buffer-substring cmpl-symbol-start cmpl-symbol-end))
- )
- (t
- ;; restore table if no symbol
- (set-syntax-table cmpl-saved-syntax)
- nil)
- ))
-
-;;; tests for symbol-before-point
-;;; `^' indicates cursor pos. where value is returned
-;;; simple-word-test
-;;; ^ --> nil
-;;; ^ --> nil
-;;; ^ --> simple-w
-;;; ^ --> simple-word-test
-;;; _harder_word_test_
-;;; ^ --> harder_word_test
-;;; ^ --> harder_word_test
-;;; ^ --> harder
-;;; .___....
-;;; --> nil
-
-(defun symbol-under-or-before-point ()
- ;;; This could be made slightly faster but it is better to avoid
- ;;; copying all the code.
- ;;; However, it is only used by the completion string prompter.
- ;;; If it comes into common use, it could be rewritten.
- (setq cmpl-saved-syntax (syntax-table))
- (set-syntax-table cmpl-syntax-table)
- (cond ((memq (char-syntax (following-char)) '(?w ?_))
- (set-syntax-table cmpl-saved-syntax)
- (symbol-under-point))
- (t
- (set-syntax-table cmpl-saved-syntax)
- (symbol-before-point))
- ))
-
-
-(defun symbol-before-point-for-complete ()
- ;; "Returns a string of the symbol immediately before point
- ;; or nil if there isn't one. Like symbol-before-point but doesn't trim the
- ;; end chars."
- ;; Cursor is on following-char and after preceding-char
- (setq cmpl-saved-syntax (syntax-table))
- (set-syntax-table cmpl-syntax-table)
- (cond ((memq (setq cmpl-preceding-syntax (char-syntax (preceding-char)))
- '(?_ ?w))
- (setq cmpl-symbol-end (point)
- cmpl-symbol-start (scan-sexps (1+ cmpl-symbol-end) -1)
- )
- ;; remove chars to ignore at the start
- (cond ((= (char-syntax (char-after cmpl-symbol-start)) ?w)
- (goto-char cmpl-symbol-start)
- (forward-word 1)
- (setq cmpl-symbol-start (point))
- (goto-char cmpl-symbol-end)
- ))
- ;; restore state
- (set-syntax-table cmpl-saved-syntax)
- ;; Return completion if the length is reasonable
- (if (and (<= (read-time-eval
- *completion-prefix-min-length*)
- (- cmpl-symbol-end cmpl-symbol-start))
- (<= (- cmpl-symbol-end cmpl-symbol-start)
- (read-time-eval *completion-max-length*)))
- (buffer-substring cmpl-symbol-start cmpl-symbol-end))
- )
- (t
- ;; restore table if no symbol
- (set-syntax-table cmpl-saved-syntax)
- nil)
- ))
-
-;;; tests for symbol-before-point-for-complete
-;;; `^' indicates cursor pos. where value is returned
-;;; simple-word-test
-;;; ^ --> nil
-;;; ^ --> nil
-;;; ^ --> simple-w
-;;; ^ --> simple-word-test
-;;; _harder_word_test_
-;;; ^ --> harder_word_test
-;;; ^ --> harder_word_test_
-;;; ^ --> harder_
-;;; .___....
-;;; --> nil
-
-
-
-;;;---------------------------------------------------------------------------
-;;; Statistics Recording
-;;;---------------------------------------------------------------------------
-
-;;; Note that the guts of this has been turned off. The guts
-;;; are in completion-stats.el.
-
-;;;-----------------------------------------------
-;;; Conditionalizing code on *record-cmpl-statistics-p*
-;;;-----------------------------------------------
-;;; All statistics code outside this block should use this
-(defmacro cmpl-statistics-block (&rest body)
- "Only executes body if we are recording statistics."
- (list 'cond
- (list* '*record-cmpl-statistics-p* body)
- ))
-
-;;;-----------------------------------------------
-;;; Completion Sources
-;;;-----------------------------------------------
-
-;; ID numbers
-(defconst cmpl-source-unknown 0)
-(defconst cmpl-source-init-file 1)
-(defconst cmpl-source-file-parsing 2)
-(defconst cmpl-source-separator 3)
-(defconst cmpl-source-cursor-moves 4)
-(defconst cmpl-source-interactive 5)
-(defconst cmpl-source-cdabbrev 6)
-(defconst num-cmpl-sources 7)
-(defvar current-completion-source cmpl-source-unknown)
-
-
-
-;;;---------------------------------------------------------------------------
-;;; Completion Method #2: dabbrev-expand style
-;;;---------------------------------------------------------------------------
-;;;
-;;; This method is used if there are no useful stored completions. It is
-;;; based on dabbrev-expand with these differences :
-;;; 1) Faster (we don't use regexps)
-;;; 2) case coercion handled correctly
-;;; This is called cdabbrev to differentiate it.
-;;; We simply search backwards through the file looking for words which
-;;; start with the same letters we are trying to complete.
-;;;
-
-(defvar cdabbrev-completions-tried nil)
-;;; "A list of all the cdabbrev completions since the last reset.")
-
-(defvar cdabbrev-current-point 0)
-;;; "The current point position the cdabbrev search is at.")
-
-(defvar cdabbrev-current-window nil)
-;;; "The current window we are looking for cdabbrevs in. T if looking in
-;;; (other-buffer), NIL if no more cdabbrevs.")
-
-(defvar cdabbrev-wrapped-p nil)
-;;; "T if the cdabbrev search has wrapped around the file.")
-
-(defvar cdabbrev-abbrev-string "")
-(defvar cdabbrev-start-point 0)
-
-;;; Test strings for cdabbrev
-;;; cdat-upcase ;;same namestring
-;;; CDAT-UPCASE ;;ok
-;;; cdat2 ;;too short
-;;; cdat-1-2-3-4 ;;ok
-;;; a-cdat-1 ;;doesn't start correctly
-;;; cdat-simple ;;ok
-
-
-(defun reset-cdabbrev (abbrev-string &optional initial-completions-tried)
- "Resets the cdabbrev search to search for abbrev-string.
-initial-completions-tried is a list of downcased strings to ignore
-during the search."
- (setq cdabbrev-abbrev-string abbrev-string
- cdabbrev-completions-tried
- (cons (downcase abbrev-string) initial-completions-tried)
- )
- (reset-cdabbrev-window t)
- )
-
-(defun set-cdabbrev-buffer ()
- ;; cdabbrev-current-window must not be NIL
- (set-buffer (if (eq cdabbrev-current-window t)
- (other-buffer)
- (window-buffer cdabbrev-current-window)))
- )
-
-
-(defun reset-cdabbrev-window (&optional initializep)
- "Resets the cdabbrev search to search for abbrev-string.
-initial-completions-tried is a list of downcased strings to ignore
-during the search."
- ;; Set the window
- (cond (initializep
- (setq cdabbrev-current-window (selected-window))
- )
- ((eq cdabbrev-current-window t)
- ;; Everything has failed
- (setq cdabbrev-current-window nil))
- (cdabbrev-current-window
- (setq cdabbrev-current-window (next-window cdabbrev-current-window))
- (if (eq cdabbrev-current-window (selected-window))
- ;; No more windows, try other buffer.
- (setq cdabbrev-current-window t)))
- )
- (when cdabbrev-current-window
- (save-excursion
- (set-cdabbrev-buffer)
- (setq cdabbrev-current-point (point)
- cdabbrev-start-point cdabbrev-current-point
- cdabbrev-stop-point
- (if *cdabbrev-radius*
- (max (point-min)
- (- cdabbrev-start-point *cdabbrev-radius*))
- (point-min))
- cdabbrev-wrapped-p nil)
- )))
-
-(defun next-cdabbrev ()
- "Return the next possible cdabbrev expansion or nil if there isn't one.
-reset-cdabbrev must've been called. This is sensitive to case-fold-search."
- ;; note that case-fold-search affects the behavior of this function
- ;; Bug: won't pick up an expansion that starts at the top of buffer
- (when cdabbrev-current-window
- (let (saved-point
- saved-syntax
- (expansion nil)
- downcase-expansion tried-list syntax saved-point-2)
- (save-excursion
- (unwind-protect
- (progn
- ;; Switch to current completion buffer
- (set-cdabbrev-buffer)
- ;; Save current buffer state
- (setq saved-point (point)
- saved-syntax (syntax-table))
- ;; Restore completion state
- (set-syntax-table cmpl-syntax-table)
- (goto-char cdabbrev-current-point)
- ;; Loop looking for completions
- (while
- ;; This code returns t if it should loop again
- (cond
- (;; search for the string
- (search-backward cdabbrev-abbrev-string cdabbrev-stop-point t)
- ;; return nil if the completion is valid
- (not
- (and
- ;; does it start with a separator char ?
- (or (= (setq syntax (char-syntax (preceding-char))) ? )
- (and (= syntax ?w)
- ;; symbol char to ignore at end. Are we at end ?
- (progn
- (setq saved-point-2 (point))
- (forward-word -1)
- (prog1
- (= (char-syntax (preceding-char)) ? )
- (goto-char saved-point-2)
- ))))
- ;; is the symbol long enough ?
- (setq expansion (symbol-under-point))
- ;; have we not tried this one before
- (progn
- ;; See if we've already used it
- (setq tried-list cdabbrev-completions-tried
- downcase-expansion (downcase expansion))
- (while (and tried-list
- (not (string-equal downcase-expansion
- (car tried-list))))
- ;; Already tried, don't choose this one
- (setq tried-list (cdr tried-list))
- )
- ;; at this point tried-list will be nil if this
- ;; expansion has not yet been tried
- (if tried-list
- (setq expansion nil)
- t)
- ))))
- ;; search failed
- (cdabbrev-wrapped-p
- ;; If already wrapped, then we've failed completely
- nil)
- (t
- ;; need to wrap
- (goto-char (setq cdabbrev-current-point
- (if *cdabbrev-radius*
- (min (point-max) (+ cdabbrev-start-point *cdabbrev-radius*))
- (point-max))))
-
- (setq cdabbrev-wrapped-p t))
- ))
- ;; end of while loop
- (cond (expansion
- ;; successful
- (setq cdabbrev-completions-tried
- (cons downcase-expansion cdabbrev-completions-tried)
- cdabbrev-current-point (point))))
- )
- (set-syntax-table saved-syntax)
- (goto-char saved-point)
- ))
- ;; If no expansion, go to next window
- (cond (expansion)
- (t (reset-cdabbrev-window)
- (next-cdabbrev)))
- )))
-
-;;; The following must be eval'd in the minibuffer ::
-;;; (reset-cdabbrev "cdat")
-;;; (next-cdabbrev) --> "cdat-simple"
-;;; (next-cdabbrev) --> "cdat-1-2-3-4"
-;;; (next-cdabbrev) --> "CDAT-UPCASE"
-;;; (next-cdabbrev) --> "cdat-wrapping"
-;;; (next-cdabbrev) --> "cdat_start_sym"
-;;; (next-cdabbrev) --> nil
-;;; (next-cdabbrev) --> nil
-;;; (next-cdabbrev) --> nil
-
-;;; _cdat_start_sym
-;;; cdat-wrapping
-
-
-;;;---------------------------------------------------------------------------
-;;; Completion Database
-;;;---------------------------------------------------------------------------
-
-;;; We use two storage modes for the two search types ::
-;;; 1) Prefix {cmpl-prefix-obarray} for looking up possible completions
-;;; Used by search-completion-next
-;;; the value of the symbol is nil or a cons of head and tail pointers
-;;; 2) Interning {cmpl-obarray} to see if it's in the database
-;;; Used by find-exact-completion, completion-in-database-p
-;;; The value of the symbol is the completion entry
-
-;;; bad things may happen if this length is changed due to the way
-;;; GNU implements obarrays
-(defconst cmpl-obarray-length 511)
-
-(defvar cmpl-prefix-obarray (make-vector cmpl-obarray-length 0)
- "An obarray used to store the downcased completion prefices.
-Each symbol is bound to a list of completion entries.")
-
-(defvar cmpl-obarray (make-vector cmpl-obarray-length 0)
- "An obarray used to store the downcased completions.
-Each symbol is bound to a single completion entry.")
-
-;;;-----------------------------------------------
-;;; Completion Entry Structure Definition
-;;;-----------------------------------------------
-
-;;; A completion entry is a LIST of string, prefix-symbol num-uses, and
-;;; last-use-time (the time the completion was last used)
-;;; last-use-time is T if the string should be kept permanently
-;;; num-uses is incremented everytime the completion is used.
-
-;;; We chose lists because (car foo) is faster than (aref foo 0) and the
-;;; creation time is about the same.
-
-;;; READER MACROS
-
-(defmacro completion-string (completion-entry)
- (list 'car completion-entry))
-
-(defmacro completion-num-uses (completion-entry)
- ;; "The number of times it has used. Used to decide whether to save
- ;; it."
- (list 'car (list 'cdr completion-entry)))
-
-(defmacro completion-last-use-time (completion-entry)
- ;; "The time it was last used. In hours since 1900. Used to decide
- ;; whether to save it. T if one should always save it."
- (list 'nth 2 completion-entry))
-
-(defmacro completion-source (completion-entry)
- (list 'nth 3 completion-entry))
-
-;;; WRITER MACROS
-(defmacro set-completion-string (completion-entry string)
- (list 'setcar completion-entry string))
-
-(defmacro set-completion-num-uses (completion-entry num-uses)
- (list 'setcar (list 'cdr completion-entry) num-uses))
-
-(defmacro set-completion-last-use-time (completion-entry last-use-time)
- (list 'setcar (list 'cdr (list 'cdr completion-entry)) last-use-time))
-
-;;; CONSTRUCTOR
-(defun make-completion (string)
- "Returns a list of a completion entry."
- (list (list string 0 nil current-completion-source)))
-
-;; Obsolete
-;;(defmacro cmpl-prefix-entry-symbol (completion-entry)
-;; (list 'car (list 'cdr completion-entry)))
-
-
-
-;;;-----------------------------------------------
-;;; Prefix symbol entry definition
-;;;-----------------------------------------------
-;;; A cons of (head . tail)
-
-;;; READER Macros
-
-(defmacro cmpl-prefix-entry-head (prefix-entry)
- (list 'car prefix-entry))
-
-(defmacro cmpl-prefix-entry-tail (prefix-entry)
- (list 'cdr prefix-entry))
-
-;;; WRITER Macros
-
-(defmacro set-cmpl-prefix-entry-head (prefix-entry new-head)
- (list 'setcar prefix-entry new-head))
-
-(defmacro set-cmpl-prefix-entry-tail (prefix-entry new-tail)
- (list 'setcdr prefix-entry new-tail))
-
-;;; Contructor
-
-(defun make-cmpl-prefix-entry (completion-entry-list)
- "Makes a new prefix entry containing only completion-entry."
- (cons completion-entry-list completion-entry-list))
-
-;;;-----------------------------------------------
-;;; Completion Database - Utilities
-;;;-----------------------------------------------
-
-(defun clear-all-completions ()
- "Initializes the completion storage. All existing completions are lost."
- (interactive)
- (setq cmpl-prefix-obarray (make-vector cmpl-obarray-length 0))
- (setq cmpl-obarray (make-vector cmpl-obarray-length 0))
- (cmpl-statistics-block
- (record-clear-all-completions))
- )
-
-(defun list-all-completions ()
- "Returns a list of all the known completion entries."
- (let ((return-completions nil))
- (mapatoms 'list-all-completions-1 cmpl-prefix-obarray)
- return-completions))
-
-(defun list-all-completions-1 (prefix-symbol)
- (if (boundp prefix-symbol)
- (setq return-completions
- (append (cmpl-prefix-entry-head (symbol-value prefix-symbol))
- return-completions))))
-
-(defun list-all-completions-by-hash-bucket ()
- "Returns a list of lists of all the known completion entries organized by
-hash bucket."
- (let ((return-completions nil))
- (mapatoms 'list-all-completions-by-hash-bucket-1 cmpl-prefix-obarray)
- return-completions))
-
-(defun list-all-completions-by-hash-bucket-1 (prefix-symbol)
- (if (boundp prefix-symbol)
- (setq return-completions
- (cons (cmpl-prefix-entry-head (symbol-value prefix-symbol))
- return-completions))))
-
-
-;;;-----------------------------------------------
-;;; Updating the database
-;;;-----------------------------------------------
-;;;
-;;; These are the internal functions used to update the datebase
-;;;
-;;;
-(defvar completion-to-accept nil)
- ;;"Set to a string that is pending its acceptance."
- ;; this checked by the top level reading functions
-
-(defvar cmpl-db-downcase-string nil)
- ;; "Setup by find-exact-completion, etc. The given string, downcased."
-(defvar cmpl-db-symbol nil)
- ;; "The interned symbol corresponding to cmpl-db-downcase-string.
- ;; Set up by cmpl-db-symbol."
-(defvar cmpl-db-prefix-symbol nil)
- ;; "The interned prefix symbol corresponding to cmpl-db-downcase-string."
-(defvar cmpl-db-entry nil)
-(defvar cmpl-db-debug-p nil
- "Set to T if you want to debug the database.")
-
-;;; READS
-(defun find-exact-completion (string)
- "Returns the completion entry for string or nil.
-Sets up cmpl-db-downcase-string and cmpl-db-symbol."
- (and (boundp (setq cmpl-db-symbol
- (intern (setq cmpl-db-downcase-string (downcase string))
- cmpl-obarray)))
- (symbol-value cmpl-db-symbol)
- ))
-
-(defun find-cmpl-prefix-entry (prefix-string)
- "Returns the prefix entry for string. Sets cmpl-db-prefix-symbol.
-Prefix-string must be exactly *completion-prefix-min-length* long
-and downcased. Sets up cmpl-db-prefix-symbol."
- (and (boundp (setq cmpl-db-prefix-symbol
- (intern prefix-string cmpl-prefix-obarray)))
- (symbol-value cmpl-db-prefix-symbol)))
-
-(defvar inside-locate-completion-entry nil)
-;; used to trap lossage in silent error correction
-
-(defun locate-completion-entry (completion-entry prefix-entry)
- "Locates the completion entry. Returns a pointer to the element
-before the completion entry or nil if the completion entry is at the head.
-Must be called after find-exact-completion."
- (let ((prefix-list (cmpl-prefix-entry-head prefix-entry))
- next-prefix-list
- )
- (cond
- ((not (eq (car prefix-list) completion-entry))
- ;; not already at head
- (while (and prefix-list
- (not (eq completion-entry
- (car (setq next-prefix-list (cdr prefix-list)))
- )))
- (setq prefix-list next-prefix-list))
- (cond (;; found
- prefix-list)
- ;; Didn't find it. Database is messed up.
- (cmpl-db-debug-p
- ;; not found, error if debug mode
- (error "Completion entry exists but not on prefix list - %s"
- string))
- (inside-locate-completion-entry
- ;; recursive error: really scrod
- (locate-completion-db-error))
- (t
- ;; Patch out
- (set cmpl-db-symbol nil)
- ;; Retry
- (locate-completion-entry-retry completion-entry)
- ))))))
-
-(defun locate-completion-entry-retry (old-entry)
- (let ((inside-locate-completion-entry t))
- (add-completion (completion-string old-entry)
- (completion-num-uses old-entry)
- (completion-last-use-time old-entry))
- (let ((cmpl-entry (find-exact-completion (completion-string old-entry)))
- (pref-entry
- (if cmpl-entry
- (find-cmpl-prefix-entry
- (substring cmpl-db-downcase-string
- 0 *completion-prefix-min-length*))))
- )
- (if (and cmpl-entry pref-entry)
- ;; try again
- (locate-completion-entry cmpl-entry pref-entry)
- ;; still losing
- (locate-completion-db-error))
- )))
-
-(defun locate-completion-db-error ()
- ;; recursive error: really scrod
- (error "Completion database corrupted. Try M-x clear-all-completions. Send bug report.")
- )
-
-;;; WRITES
-(defun add-completion-to-tail-if-new (string)
- "If the string is not in the database it is added to the end of the
-approppriate prefix list with num-uses = 0. The database is unchanged if it
-is there. string must be longer than *completion-prefix-min-length*.
-This must be very fast.
-Returns the completion entry."
- (or (find-exact-completion string)
- ;; not there
- (let (;; create an entry
- (entry (make-completion string))
- ;; setup the prefix
- (prefix-entry (find-cmpl-prefix-entry
- (substring cmpl-db-downcase-string 0
- (read-time-eval
- *completion-prefix-min-length*))))
- )
- ;; The next two forms should happen as a unit (atomically) but
- ;; no fatal errors should result if that is not the case.
- (cond (prefix-entry
- ;; These two should be atomic, but nothing fatal will happen
- ;; if they're not.
- (setcdr (cmpl-prefix-entry-tail prefix-entry) entry)
- (set-cmpl-prefix-entry-tail prefix-entry entry))
- (t
- (set cmpl-db-prefix-symbol (make-cmpl-prefix-entry entry))
- ))
- ;; statistics
- (cmpl-statistics-block
- (note-added-completion))
- ;; set symbol
- (set cmpl-db-symbol (car entry))
- )))
-
-(defun add-completion-to-head (string)
- "If the string is not in the database it is added to the head of the
-approppriate prefix list. Otherwise it is moved to the head of the list.
-string must be longer than *completion-prefix-min-length*.
-Updates the saved string with the supplied string.
-This must be very fast.
-Returns the completion entry."
- ;; Handle pending acceptance
- (if completion-to-accept (accept-completion))
- ;; test if already in database
- (if (setq cmpl-db-entry (find-exact-completion string))
- ;; found
- (let* ((prefix-entry (find-cmpl-prefix-entry
- (substring cmpl-db-downcase-string 0
- (read-time-eval
- *completion-prefix-min-length*))))
- (splice-ptr (locate-completion-entry cmpl-db-entry prefix-entry))
- (cmpl-ptr (cdr splice-ptr))
- )
- ;; update entry
- (set-completion-string cmpl-db-entry string)
- ;; move to head (if necessary)
- (cond (splice-ptr
- ;; These should all execute atomically but it is not fatal if
- ;; they don't.
- ;; splice it out
- (or (setcdr splice-ptr (cdr cmpl-ptr))
- ;; fix up tail if necessary
- (set-cmpl-prefix-entry-tail prefix-entry splice-ptr))
- ;; splice in at head
- (setcdr cmpl-ptr (cmpl-prefix-entry-head prefix-entry))
- (set-cmpl-prefix-entry-head prefix-entry cmpl-ptr)
- ))
- cmpl-db-entry)
- ;; not there
- (let (;; create an entry
- (entry (make-completion string))
- ;; setup the prefix
- (prefix-entry (find-cmpl-prefix-entry
- (substring cmpl-db-downcase-string 0
- (read-time-eval
- *completion-prefix-min-length*))))
- )
- (cond (prefix-entry
- ;; Splice in at head
- (setcdr entry (cmpl-prefix-entry-head prefix-entry))
- (set-cmpl-prefix-entry-head prefix-entry entry))
- (t
- ;; Start new prefix entry
- (set cmpl-db-prefix-symbol (make-cmpl-prefix-entry entry))
- ))
- ;; statistics
- (cmpl-statistics-block
- (note-added-completion))
- ;; Add it to the symbol
- (set cmpl-db-symbol (car entry))
- )))
-
-(defun delete-completion (string)
- "Deletes the completion from the database. string must be longer than
-*completion-prefix-min-length*."
- ;; Handle pending acceptance
- (if completion-to-accept (accept-completion))
- (if (setq cmpl-db-entry (find-exact-completion string))
- ;; found
- (let* ((prefix-entry (find-cmpl-prefix-entry
- (substring cmpl-db-downcase-string 0
- (read-time-eval
- *completion-prefix-min-length*))))
- (splice-ptr (locate-completion-entry cmpl-db-entry prefix-entry))
- )
- ;; delete symbol reference
- (set cmpl-db-symbol nil)
- ;; remove from prefix list
- (cond (splice-ptr
- ;; not at head
- (or (setcdr splice-ptr (cdr (cdr splice-ptr)))
- ;; fix up tail if necessary
- (set-cmpl-prefix-entry-tail prefix-entry splice-ptr))
- )
- (t
- ;; at head
- (or (set-cmpl-prefix-entry-head
- prefix-entry (cdr (cmpl-prefix-entry-head prefix-entry)))
- ;; List is now empty
- (set cmpl-db-prefix-symbol nil))
- ))
- (cmpl-statistics-block
- (note-completion-deleted))
- )
- (error "Unknown completion: %s. Couldn't delete it." string)
- ))
-
-;;; Tests --
-;;; - Add and Find -
-;;; (add-completion-to-head "banana") --> ("banana" 0 nil 0)
-;;; (find-exact-completion "banana") --> ("banana" 0 nil 0)
-;;; (find-exact-completion "bana") --> nil
-;;; (car (find-cmpl-prefix-entry "ban")) --> (("banana" ...))
-;;; (cdr (find-cmpl-prefix-entry "ban")) --> (("banana" ...))
-;;; (add-completion-to-head "banish") --> ("banish" 0 nil 0)
-;;; (find-exact-completion "banish") --> ("banish" 0 nil 0)
-;;; (car (find-cmpl-prefix-entry "ban")) --> (("banish" ...) ("banana" ...))
-;;; (cdr (find-cmpl-prefix-entry "ban")) --> (("banana" ...))
-;;; (add-completion-to-head "banana") --> ("banana" 0 nil 0)
-;;; (car (find-cmpl-prefix-entry "ban")) --> (("banana" ...) ("banish" ...))
-;;; (cdr (find-cmpl-prefix-entry "ban")) --> (("banish" ...))
-;;;
-;;; - Deleting -
-;;; (add-completion-to-head "banner") --> ("banner" 0 nil 0)
-;;; (delete-completion "banner")
-;;; (find-exact-completion "banner") --> nil
-;;; (car (find-cmpl-prefix-entry "ban")) --> (("banana" ...) ("banish" ...))
-;;; (cdr (find-cmpl-prefix-entry "ban")) --> (("banish" ...))
-;;; (add-completion-to-head "banner") --> ("banner" 0 nil 0)
-;;; (delete-completion "banana")
-;;; (car (find-cmpl-prefix-entry "ban")) --> (("banner" ...) ("banish" ...))
-;;; (cdr (find-cmpl-prefix-entry "ban")) --> (("banish" ...))
-;;; (delete-completion "banner")
-;;; (delete-completion "banish")
-;;; (find-cmpl-prefix-entry "ban") --> nil
-;;; (delete-completion "banner") --> error
-;;;
-;;; - Tail -
-;;; (add-completion-to-tail-if-new "banana") --> ("banana" 0 nil 0)
-;;; (car (find-cmpl-prefix-entry "ban")) --> (("banana" ...))
-;;; (cdr (find-cmpl-prefix-entry "ban")) --> (("banana" ...))
-;;; (add-completion-to-tail-if-new "banish") --> ("banish" 0 nil 0)
-;;; (car (find-cmpl-prefix-entry "ban")) -->(("banana" ...) ("banish" ...))
-;;; (cdr (find-cmpl-prefix-entry "ban")) -->(("banish" ...))
-;;;
-
-
-;;;---------------------------------------------------------------------------
-;;; Database Update :: Interface level routines
-;;;---------------------------------------------------------------------------
-;;;
-;;; These lie on top of the database ref. functions but below the standard
-;;; user interface level
-
-
-(defun interactive-completion-string-reader (prompt)
- (let* ((default (symbol-under-or-before-point))
- (new-prompt
- (if default
- (format "%s: (default: %s) " prompt default)
- (format "%s: " prompt))
- )
- (read (completing-read new-prompt cmpl-obarray))
- )
- (if (zerop (length read)) (setq read (or default "")))
- (list read)
- ))
-
-(defun check-completion-length (string)
- (if (< (length string) *completion-min-length*)
- (error "The string \"%s\" is too short to be saved as a completion."
- string)
- (list string)))
-
-(defun add-completion (string &optional num-uses last-use-time)
- "If the string is not there, it is added to the head of the completion list.
-Otherwise, it is moved to the head of the list.
-The completion is altered appropriately if num-uses and/or last-use-time is
-specified."
- (interactive (interactive-completion-string-reader "Completion to add"))
- (check-completion-length string)
- (let* ((current-completion-source (if (interactive-p)
- cmpl-source-interactive
- current-completion-source))
- (entry (add-completion-to-head string)))
-
- (if num-uses (set-completion-num-uses entry num-uses))
- (if last-use-time
- (set-completion-last-use-time entry last-use-time))
- ))
-
-(defun add-permanent-completion (string)
- "Adds string if it isn't already there and and makes it a permanent string."
- (interactive
- (interactive-completion-string-reader "Completion to add permanently"))
- (let ((current-completion-source (if (interactive-p)
- cmpl-source-interactive
- current-completion-source))
- )
- (add-completion string nil t)
- ))
-
-(defun kill-completion (string)
- (interactive (interactive-completion-string-reader "Completion to kill"))
- (check-completion-length string)
- (delete-completion string)
- )
-
-(defun accept-completion ()
- "Accepts the pending completion in completion-to-accept.
-This bumps num-uses. Called by add-completion-to-head and
-completion-search-reset."
- (let ((string completion-to-accept)
- ;; if this is added afresh here, then it must be a cdabbrev
- (current-completion-source cmpl-source-cdabbrev)
- entry
- )
- (setq completion-to-accept nil)
- (setq entry (add-completion-to-head string))
- (set-completion-num-uses entry (1+ (completion-num-uses entry)))
- (setq cmpl-completions-accepted-p t)
- ))
-
-(defun use-completion-under-point ()
- "Call this to add the completion symbol underneath the point into
-the completion buffer."
- (let ((string (and *completep* (symbol-under-point)))
- (current-completion-source cmpl-source-cursor-moves))
- (if string (add-completion-to-head string))))
-
-(defun use-completion-before-point ()
- "Call this to add the completion symbol before point into
-the completion buffer."
- (let ((string (and *completep* (symbol-before-point)))
- (current-completion-source cmpl-source-cursor-moves))
- (if string (add-completion-to-head string))))
-
-(defun use-completion-under-or-before-point ()
- "Call this to add the completion symbol before point into
-the completion buffer."
- (let ((string (and *completep* (symbol-under-or-before-point)))
- (current-completion-source cmpl-source-cursor-moves))
- (if string (add-completion-to-head string))))
-
-(defun use-completion-before-separator ()
- "Call this to add the completion symbol before point into
-the completion buffer. Completions added this way will automatically be
-saved if *separator-character-uses-completion-p* is non-nil."
- (let ((string (and *completep* (symbol-before-point)))
- (current-completion-source cmpl-source-separator)
- entry)
- (cmpl-statistics-block
- (note-separator-character string)
- )
- (cond (string
- (setq entry (add-completion-to-head string))
- (when (and *separator-character-uses-completion-p*
- (zerop (completion-num-uses entry)))
- (set-completion-num-uses entry 1)
- (setq cmpl-completions-accepted-p t)
- )))
- ))
-
-;;; Tests --
-;;; - Add and Find -
-;;; (add-completion "banana" 5 10)
-;;; (find-exact-completion "banana") --> ("banana" 5 10 0)
-;;; (add-completion "banana" 6)
-;;; (find-exact-completion "banana") --> ("banana" 6 10 0)
-;;; (add-completion "banish")
-;;; (car (find-cmpl-prefix-entry "ban")) --> (("banish" ...) ("banana" ...))
-;;;
-;;; - Accepting -
-;;; (setq completion-to-accept "banana")
-;;; (accept-completion)
-;;; (find-exact-completion "banana") --> ("banana" 7 10)
-;;; (car (find-cmpl-prefix-entry "ban")) --> (("banana" ...) ("banish" ...))
-;;; (setq completion-to-accept "banish")
-;;; (add-completion "banner")
-;;; (car (find-cmpl-prefix-entry "ban"))
-;;; --> (("banner" ...) ("banish" 1 ...) ("banana" 7 ...))
-;;;
-;;; - Deleting -
-;;; (kill-completion "banish")
-;;; (car (find-cmpl-prefix-entry "ban")) --> (("banner" ...) ("banana" ...))
-
-
-;;;---------------------------------------------------------------------------
-;;; Searching the database
-;;;---------------------------------------------------------------------------
-;;; Functions outside this block must call completion-search-reset followed
-;;; by calls to completion-search-next or completion-search-peek
-;;;
-
-;;; Status variables
-;; Commented out to improve loading speed
-(defvar cmpl-test-string "")
-;; "The current string used by completion-search-next."
-(defvar cmpl-test-regexp "")
-;; "The current regexp used by completion-search-next.
-;; (derived from cmpl-test-string)"
-(defvar cmpl-last-index 0)
-;; "The last index that completion-search-next was called with."
-(defvar cmpl-cdabbrev-reset-p nil)
-;; "Set to t when cdabbrevs have been reset."
-(defvar cmpl-next-possibilities nil)
-;; "A pointer to the element BEFORE the next set of possible completions.
-;; cadr of this is the cmpl-next-possibility"
-(defvar cmpl-starting-possibilities nil)
-;; "The initial list of starting possibilities."
-(defvar cmpl-next-possibility nil)
-;; "The cached next possibility."
-(defvar cmpl-tried-list nil)
-;; "A downcased list of all the completions we have tried."
-
-
-(defun completion-search-reset (string)
- "Given a string, sets up the get-completion and completion-search-next functions.
-String must be longer than *completion-prefix-min-length*."
- (if completion-to-accept (accept-completion))
- (setq cmpl-starting-possibilities
- (cmpl-prefix-entry-head
- (find-cmpl-prefix-entry (downcase (substring string 0 3))))
- cmpl-test-string string
- cmpl-test-regexp (concat (regexp-quote string) "."))
- (completion-search-reset-1)
- )
-
-(defun completion-search-reset-1 ()
- (setq cmpl-next-possibilities cmpl-starting-possibilities
- cmpl-next-possibility nil
- cmpl-cdabbrev-reset-p nil
- cmpl-last-index -1
- cmpl-tried-list nil
- ))
-
-(defun completion-search-next (index)
- "Returns the next completion entry. If index is out of sequence it resets
-and starts from the top. If there are no more entries it tries cdabbrev and
-returns only a string."
- (cond
- ((= index (setq cmpl-last-index (1+ cmpl-last-index)))
- (completion-search-peek t))
- ((minusp index)
- (completion-search-reset-1)
- (setq cmpl-last-index index)
- ;; reverse the possibilities list
- (setq cmpl-next-possibilities (reverse cmpl-starting-possibilities))
- ;; do a "normal" search
- (while (and (completion-search-peek nil)
- (minusp (setq index (1+ index))))
- (setq cmpl-next-possibility nil)
- )
- (cond ((not cmpl-next-possibilities))
- ;; If no more possibilities, leave it that way
- ((= -1 cmpl-last-index)
- ;; next completion is at index 0. reset next-possibility list
- ;; to start at beginning
- (setq cmpl-next-possibilities cmpl-starting-possibilities))
- (t
- ;; otherwise point to one before current
- (setq cmpl-next-possibilities
- (nthcdr (- (length cmpl-starting-possibilities)
- (length cmpl-next-possibilities))
- cmpl-starting-possibilities))
- )))
- (t
- ;; non-negative index, reset and search
- ;;(prin1 'reset)
- (completion-search-reset-1)
- (setq cmpl-last-index index)
- (while (and (completion-search-peek t)
- (not (minusp (setq index (1- index)))))
- (setq cmpl-next-possibility nil)
- ))
- )
- (prog1
- cmpl-next-possibility
- (setq cmpl-next-possibility nil)
- ))
-
-
-(defun completion-search-peek (use-cdabbrev)
- "Returns the next completion entry without actually moving the pointers.
-Calling this again or calling completion-search-next will result in the same
-string being returned. Depends on case-fold-search.
-If there are no more entries it tries cdabbrev and then returns only a string."
- (cond
- ;; return the cached value if we have it
- (cmpl-next-possibility)
- ((and cmpl-next-possibilities
- ;; still a few possibilities left
- (progn
- (while
- (and (not (eq 0 (string-match cmpl-test-regexp
- (completion-string (car cmpl-next-possibilities)))))
- (setq cmpl-next-possibilities (cdr cmpl-next-possibilities))
- ))
- cmpl-next-possibilities
- ))
- ;; successful match
- (setq cmpl-next-possibility (car cmpl-next-possibilities)
- cmpl-tried-list (cons (downcase (completion-string cmpl-next-possibility))
- cmpl-tried-list)
- cmpl-next-possibilities (cdr cmpl-next-possibilities)
- )
- cmpl-next-possibility)
- (use-cdabbrev
- ;; unsuccessful, use cdabbrev
- (cond ((not cmpl-cdabbrev-reset-p)
- (reset-cdabbrev cmpl-test-string cmpl-tried-list)
- (setq cmpl-cdabbrev-reset-p t)
- ))
- (setq cmpl-next-possibility (next-cdabbrev))
- )
- ;; Completely unsuccessful, return nil
- ))
-
-;;; Tests --
-;;; - Add and Find -
-;;; (add-completion "banana")
-;;; (completion-search-reset "ban")
-;;; (completion-search-next 0) --> "banana"
-;;;
-;;; - Discrimination -
-;;; (add-completion "cumberland")
-;;; (add-completion "cumberbund")
-;;; cumbering
-;;; (completion-search-reset "cumb")
-;;; (completion-search-peek t) --> "cumberbund"
-;;; (completion-search-next 0) --> "cumberbund"
-;;; (completion-search-peek t) --> "cumberland"
-;;; (completion-search-next 1) --> "cumberland"
-;;; (completion-search-peek nil) --> nil
-;;; (completion-search-next 2) --> "cumbering" {cdabbrev}
-;;; (completion-search-next 3) --> nil or "cumming"{depends on context}
-;;; (completion-search-next 1) --> "cumberland"
-;;; (completion-search-peek t) --> "cumbering" {cdabbrev}
-;;;
-;;; - Accepting -
-;;; (completion-search-next 1) --> "cumberland"
-;;; (setq completion-to-accept "cumberland")
-;;; (completion-search-reset "foo")
-;;; (completion-search-reset "cum")
-;;; (completion-search-next 0) --> "cumberland"
-;;;
-;;; - Deleting -
-;;; (kill-completion "cumberland")
-;;; cummings
-;;; (completion-search-reset "cum")
-;;; (completion-search-next 0) --> "cumberbund"
-;;; (completion-search-next 1) --> "cummings"
-;;;
-;;; - Ignoring Capitalization -
-;;; (completion-search-reset "CuMb")
-;;; (completion-search-next 0) --> "cumberbund"
-
-
-
-;;;-----------------------------------------------
-;;; COMPLETE
-;;;-----------------------------------------------
-
-(defun completion-mode ()
- "Toggles whether or not new words are added to the database."
- (interactive)
- (setq *completep* (not *completep*))
- (message "Completion mode is now %s." (if *completep* "ON" "OFF"))
- )
-
-(defvar cmpl-current-index 0)
-(defvar cmpl-original-string nil)
-(defvar cmpl-last-insert-location -1)
-(defvar cmpl-leave-point-at-start nil)
-
-(defun complete (&optional arg)
- "Inserts a completion at point.
-Point is left at end. Consective calls rotate through all possibilities.
-Prefix args ::
- control-u :: leave the point at the beginning of the completion rather
- than at the end.
- a number :: rotate through the possible completions by that amount
- `-' :: same as -1 (insert previous completion)
- {See the comments at the top of completion.el for more info.}
-"
- (interactive "*p")
- ;;; Set up variables
- (cond ((eq last-command this-command)
- ;; Undo last one
- (delete-region cmpl-last-insert-location (point))
- ;; get next completion
- (setq cmpl-current-index (+ cmpl-current-index (or arg 1)))
- )
- (t
- (if (not cmpl-initialized-p)
- (initialize-completions)) ;; make sure everything's loaded
- (cond ((consp current-prefix-arg) ;; control-u
- (setq arg 0)
- (setq cmpl-leave-point-at-start t)
- )
- (t
- (setq cmpl-leave-point-at-start nil)
- ))
- ;; get string
- (setq cmpl-original-string (symbol-before-point-for-complete))
- (cond ((not cmpl-original-string)
- (setq this-command 'failed-complete)
- (error "To complete, the point must be after a symbol at least %d character long."
- *completion-prefix-min-length*)))
- ;; get index
- (setq cmpl-current-index (if current-prefix-arg arg 0))
- ;; statistics
- (cmpl-statistics-block
- (note-complete-entered-afresh cmpl-original-string))
- ;; reset database
- (completion-search-reset cmpl-original-string)
- ;; erase what we've got
- (delete-region cmpl-symbol-start cmpl-symbol-end)
- ))
-
- ;; point is at the point to insert the new symbol
- ;; Get the next completion
- (let* ((print-status-p
- (and (>= (cmpl19-baud-rate) *print-next-completion-speed-threshold*)
- (not (minibuffer-window-selected-p))))
- (insert-point (point))
- (entry (completion-search-next cmpl-current-index))
- string
- )
- ;; entry is either a completion entry or a string (if cdabbrev)
-
- ;; If found, insert
- (cond (entry
- ;; Setup for proper case
- (setq string (if (stringp entry)
- entry (completion-string entry)))
- (setq string (cmpl-merge-string-cases
- string cmpl-original-string))
- ;; insert
- (insert string)
- ;; accept it
- (setq completion-to-accept string)
- ;; fixup and cache point
- (cond (cmpl-leave-point-at-start
- (setq cmpl-last-insert-location (point))
- (goto-char insert-point))
- (t;; point at end,
- (setq cmpl-last-insert-location insert-point))
- )
- ;; statistics
- (cmpl-statistics-block
- (note-complete-inserted entry cmpl-current-index))
- ;; Done ! cmpl-stat-complete-successful
- ;;display the next completion
- (cond
- ((and print-status-p
- ;; This updates the display and only prints if there
- ;; is no typeahead
- (cmpl19-sit-for 0)
- (setq entry
- (completion-search-peek
- *print-next-completion-does-cdabbrev-search-p*)))
- (setq string (if (stringp entry)
- entry (completion-string entry)))
- (setq string (cmpl-merge-string-cases
- string cmpl-original-string))
- (message "Next completion: %s" string)
- ))
- )
- (t;; none found, insert old
- (insert cmpl-original-string)
- ;; Don't accept completions
- (setq completion-to-accept nil)
- ;; print message
- (if (and print-status-p (cmpl19-sit-for 0))
- (message "No %scompletions."
- (if (eq this-command last-command) "more " "")))
- ;; statistics
- (cmpl-statistics-block
- (record-complete-failed cmpl-current-index))
- ;; Pretend that we were never here
- (setq this-command 'failed-complete)
- ))))
-
-;;;-----------------------------------------------
-;;; "Complete" Key Keybindings
-;;;-----------------------------------------------
-
-;;; Complete key definition
-;;; These define c-return and meta-return
-;;; In any case you really want to bind this to a single keystroke
-(if (fboundp 'key-for-others-chord)
- (condition-case e
- ;; this can fail if some of the prefix chars. are already used
- ;; as commands (this happens on wyses)
- (global-set-key (key-for-others-chord "return" '(control)) 'complete)
- (error)
- ))
-(if (fboundp 'gmacs-keycode)
- (global-set-key (gmacs-keycode "return" '(control)) 'complete)
- )
-(global-set-key "\M-\r" 'complete)
-
-;;; Tests -
-;;; (add-completion "cumberland")
-;;; (add-completion "cumberbund")
-;;; cum
-;;; Cumber
-;;; cumbering
-;;; cumb
-
-
-;;;---------------------------------------------------------------------------
-;;; Parsing definitions from files into the database
-;;;---------------------------------------------------------------------------
-
-;;;-----------------------------------------------
-;;; Top Level functions ::
-;;;-----------------------------------------------
-
-;;; User interface
-(defun add-completions-from-file (file)
- "Parses all the definition names from a Lisp mode file and adds them to the
-completion database."
- (interactive "fFile: ")
- (setq file (if (fboundp 'expand-file-name-defaulting)
- (expand-file-name-defaulting file)
- (expand-file-name file)))
- (let* ((buffer (get-file-buffer file))
- (buffer-already-there-p buffer)
- )
- (when (not buffer-already-there-p)
- (let ((*modes-for-completion-find-file-hook* nil))
- (setq buffer (find-file-noselect file))
- ))
- (unwind-protect
- (save-excursion
- (set-buffer buffer)
- (add-completions-from-buffer)
- )
- (when (not buffer-already-there-p)
- (kill-buffer buffer))
- )))
-
-(defun add-completions-from-buffer ()
- (interactive)
- (let ((current-completion-source cmpl-source-file-parsing)
- (start-num
- (cmpl-statistics-block
- (aref completion-add-count-vector cmpl-source-file-parsing)))
- mode
- )
- (cond ((memq major-mode '(emacs-lisp-mode lisp-mode))
- (add-completions-from-lisp-buffer)
- (setq mode 'lisp)
- )
- ((memq major-mode '(c-mode))
- (add-completions-from-c-buffer)
- (setq mode 'c)
- )
- (t
- (error "Do not know how to parse completions in %s buffers."
- major-mode)
- ))
- (cmpl-statistics-block
- (record-cmpl-parse-file
- mode (point-max)
- (- (aref completion-add-count-vector cmpl-source-file-parsing)
- start-num)))
- ))
-
-;;; Find file hook
-(defun cmpl-find-file-hook ()
- (cond (*completep*
- (cond ((and (memq major-mode '(emacs-lisp-mode lisp-mode))
- (memq 'lisp *modes-for-completion-find-file-hook*)
- )
- (add-completions-from-buffer))
- ((and (memq major-mode '(c-mode))
- (memq 'c *modes-for-completion-find-file-hook*)
- )
- (add-completions-from-buffer)
- )))
- ))
-
-(pushnew 'cmpl-find-file-hook find-file-hooks)
-
-;;;-----------------------------------------------
-;;; Tags Table Completions
-;;;-----------------------------------------------
-
-(defun add-completions-from-tags-table ()
- ;; Inspired by eero@media-lab.media.mit.edu
- "Add completions from the current tags-table-buffer."
- (interactive)
- (visit-tags-table-buffer) ;this will prompt if no tags-table
- (save-excursion
- (goto-char (point-min))
- (let (string)
- (condition-case e
- (while t
- (search-forward "\177")
- (backward-char 3)
- (and (setq string (symbol-under-point))
- (add-completion-to-tail-if-new string))
- (forward-char 3)
- )
- (search-failed)
- ))))
-
-
-;;;-----------------------------------------------
-;;; Lisp File completion parsing
-;;;-----------------------------------------------
-;;; This merely looks for phrases beginning with (def.... or
-;;; (package:def ... and takes the next word.
-;;;
-;;; We tried using forward-lines and explicit searches but the regexp technique
-;;; was faster. (About 100K characters per second)
-;;;
-(defconst *lisp-def-regexp*
- "\n(\\(\\w*:\\)?def\\(\\w\\|\\s_\\)*\\s +(*"
- "A regexp that searches for lisp definition form."
- )
-
-;;; Tests -
-;;; (and (string-match *lisp-def-regexp* "\n(defun foo") (match-end 0)) -> 8
-;;; (and (string-match *lisp-def-regexp* "\n(si:def foo") (match-end 0)) -> 9
-;;; (and (string-match *lisp-def-regexp* "\n(def-bar foo")(match-end 0)) -> 10
-;;; (and (string-match *lisp-def-regexp* "\n(defun (foo") (match-end 0)) -> 9
-
-(defun add-completions-from-lisp-buffer ()
- "Parses all the definition names from a Lisp mode buffer and adds them to
-the completion database."
- ;;; Benchmarks
- ;;; Sun-3/280 - 1500 to 3000 lines of lisp code per second
- (let (string)
- (save-excursion
- (goto-char (point-min))
- (condition-case e
- (while t
- (re-search-forward *lisp-def-regexp*)
- (and (setq string (symbol-under-point))
- (add-completion-to-tail-if-new string))
- )
- (search-failed)
- ))))
-
-
-;;;-----------------------------------------------
-;;; C file completion parsing
-;;;-----------------------------------------------
-;;; C :
-;;; Looks for #define or [<storage class>] [<type>] <name>{,<name>}
-;;; or structure, array or pointer defs.
-;;; It gets most of the definition names.
-;;;
-;;; As you might suspect by now, we use some symbol table hackery
-;;;
-;;; Symbol separator chars (have whitespace syntax) --> , ; * = (
-;;; Opening char --> [ {
-;;; Closing char --> ] }
-;;; openning and closing must be skipped over
-;;; Whitespace chars (have symbol syntax)
-;;; Everything else has word syntax
-
-(defun make-c-def-completion-syntax-table ()
- (let ((table (make-vector 256 0))
- (whitespace-chars '(? ?\n ?\t ?\f ?\v ?\r))
- ;; unforunately the ?( causes the parens to appear unbalanced
- (separator-chars '(?, ?* ?= ?\( ?\;
- ))
- )
- ;; default syntax is whitespace
- (dotimes (i 256)
- (modify-syntax-entry i "w" table))
- (dolist (char whitespace-chars)
- (modify-syntax-entry char "_" table))
- (dolist (char separator-chars)
- (modify-syntax-entry char " " table))
- (modify-syntax-entry ?\[ "(]" table)
- (modify-syntax-entry ?\{ "(}" table)
- (modify-syntax-entry ?\] ")[" table)
- (modify-syntax-entry ?\} "){" table)
- table))
-
-(defconst cmpl-c-def-syntax-table (make-c-def-completion-syntax-table))
-
-;;; Regexps
-(defconst *c-def-regexp*
- ;; This stops on lines with possible definitions
- "\n[_a-zA-Z#]"
- ;; This stops after the symbol to add.
- ;;"\n\\(#define\\s +.\\|\\(\\(\\w\\|\\s_\\)+\\b\\s *\\)+[(;,[*{=]\\)"
- ;; This stops before the symbol to add. {Test cases in parens. below}
- ;;"\n\\(\\(\\w\\|\\s_\\)+\\s *(\\|\\(\\(#define\\|auto\\|extern\\|register\\|static\\|int\\|long\\|short\\|unsigned\\|char\\|void\\|float\\|double\\|enum\\|struct\\|union\\|typedef\\)\\s +\\)+\\)"
- ;; this simple version picks up too much extraneous stuff
- ;; "\n\\(\\w\\|\\s_\\|#\\)\\B"
- "A regexp that searches for a definition form."
- )
-;
-;(defconst *c-cont-regexp*
-; "\\(\\w\\|\\s_\\)+\\b\\s *\\({\\|\\(\\[[0-9\t ]*\\]\\s *\\)*,\\(*\\|\\s \\)*\\b\\)"
-; "This regexp should be used in a looking-at to parse for lists of variables.")
-;
-;(defconst *c-struct-regexp*
-; "\\(*\\|\\s \\)*\\b"
-; "This regexp should be used to test whether a symbol follows a structure definition.")
-
-;(defun test-c-def-regexp (regexp string)
-; (and (eq 0 (string-match regexp string)) (match-end 0))
-; )
-
-;;; Tests -
-;;; (test-c-def-regexp *c-def-regexp* "\n#define foo") -> 10 (9)
-;;; (test-c-def-regexp *c-def-regexp* "\nfoo (x, y) {") -> 6 (6)
-;;; (test-c-def-regexp *c-def-regexp* "\nint foo (x, y)") -> 10 (5)
-;;; (test-c-def-regexp *c-def-regexp* "\n int foo (x, y)") -> nil
-;;; (test-c-def-regexp *c-cont-regexp* "oo, bar") -> 4
-;;; (test-c-def-regexp *c-cont-regexp* "oo, *bar") -> 5
-;;; (test-c-def-regexp *c-cont-regexp* "a [5][6], bar") -> 10
-;;; (test-c-def-regexp *c-cont-regexp* "oo(x,y)") -> nil
-;;; (test-c-def-regexp *c-cont-regexp* "a [6] ,\t bar") -> 9
-;;; (test-c-def-regexp *c-cont-regexp* "oo {trout =1} my_carp;") -> 14
-;;; (test-c-def-regexp *c-cont-regexp* "truct_p complex foon") -> nil
-
-(defun add-completions-from-c-buffer ()
- "Parses all the definition names from a C mode buffer and adds them to the
-completion database."
- ;; Benchmark --
- ;; Sun 3/280-- 1250 lines/sec.
-
- (let (string next-point char
- (saved-syntax (syntax-table))
- )
- (save-excursion
- (goto-char (point-min))
- (catch 'finish-add-completions
- (unwind-protect
- (while t
- ;; we loop here only when scan-sexps fails
- ;; (i.e. unbalance exps.)
- (set-syntax-table cmpl-c-def-syntax-table)
- (condition-case e
- (while t
- (re-search-forward *c-def-regexp*)
- (cond
- ((= (preceding-char) ?#)
- ;; preprocessor macro, see if it's one we handle
- (setq string (buffer-substring (point) (+ (point) 6)))
- (cond ((or (string-equal string "define")
- (string-equal string "ifdef ")
- )
- ;; skip forward over definition symbol
- ;; and add it to database
- (and (forward-word 2)
- (setq string (symbol-before-point))
- ;;(push string foo)
- (add-completion-to-tail-if-new string)
- ))))
- (t
- ;; C definition
- (setq next-point (point))
- (while (and
- next-point
- ;; scan to next separator char.
- (setq next-point (scan-sexps next-point 1))
- )
- ;; position the point on the word we want to add
- (goto-char next-point)
- (while (= (setq char (following-char)) ?*)
- ;; handle pointer ref
- ;; move to next separator char.
- (goto-char
- (setq next-point (scan-sexps (point) 1)))
- )
- (forward-word -1)
- ;; add to database
- (if (setq string (symbol-under-point))
- ;; (push string foo)
- (add-completion-to-tail-if-new string)
- ;; Local TMC hack (useful for parsing paris.h)
- (if (and (looking-at "_AP") ;; "ansi prototype"
- (progn
- (forward-word -1)
- (setq string
- (symbol-under-point))
- ))
- (add-completion-to-tail-if-new string)
- )
- )
- ;; go to next
- (goto-char next-point)
- ;; (push (format "%c" (following-char)) foo)
- (if (= (char-syntax char) ?\()
- ;; if on an opening delimiter, go to end
- (while (= (char-syntax char) ?\()
- (setq next-point (scan-sexps next-point 1)
- char (char-after next-point))
- )
- (or (= char ?,)
- ;; Current char is an end char.
- (setq next-point nil)
- ))
- ))))
- (search-failed ;;done
- (throw 'finish-add-completions t)
- )
- (error
- ;; Check for failure in scan-sexps
- (if (or (string-equal (second e)
- "Containing expression ends prematurely")
- (string-equal (second e) "Unbalanced parentheses"))
- ;; unbalanced paren., keep going
- ;;(ding)
- (forward-line 1)
- (message "Error parsing C buffer for completions. Please bug report.")
- (throw 'finish-add-completions t)
- ))
- ))
- (set-syntax-table saved-syntax)
- )))))
-
-
-;;;---------------------------------------------------------------------------
-;;; Init files
-;;;---------------------------------------------------------------------------
-
-(defun kill-emacs-save-completions ()
- "The version of save-completions-to-file called at kill-emacs
-time."
- (when (and *save-completions-p* *completep* cmpl-initialized-p)
- (cond
- ((not cmpl-completions-accepted-p)
- (message "Completions database has not changed - not writing."))
- (t
- (save-completions-to-file)
- ))
- ))
-
-(defconst saved-cmpl-file-header
- ";;; Completion Initialization file.
-;;; Version = %s
-;;; Format is (<string> . <last-use-time>)
-;;; <string> is the completion
-;;; <last-use-time> is the time the completion was last used
-;;; If it is t, the completion will never be pruned from the file.
-;;; Otherwise it is in hours since 1900.
-\n")
-
-(defun completion-backup-filename (filename)
- (concat filename ".BAK"))
-
-(defun save-completions-to-file (&optional filename)
- "Saves a completion init file. If file is not specified,
- then *saved-completions-filename* is used."
- (interactive)
- (setq filename (expand-file-name (or filename *saved-completions-filename*)))
- (when (file-writable-p filename)
- (if (not cmpl-initialized-p)
- (initialize-completions));; make sure everything's loaded
- (message "Saving completions to file %s" filename)
-
- (let* ((trim-versions-without-asking t)
- (kept-old-versions 0)
- (kept-new-versions *completion-file-versions-kept*)
- last-use-time
- (current-time (cmpl-hours-since-1900))
- (total-in-db 0)
- (total-perm 0)
- (total-saved 0)
- (backup-filename (completion-backup-filename filename))
- )
-
- (save-excursion
- (get-buffer-create " *completion-save-buffer*")
- (set-buffer " *completion-save-buffer*")
- (setq buffer-file-name filename)
-
- (when (not (verify-visited-file-modtime (current-buffer)))
- ;; file has changed on disk. Bring us up-to-date
- (message "Completion file has changed. Merging. . .")
- (load-completions-from-file filename t)
- (message "Merging finished. Saving completions to file %s" filename)
- )
-
- ;; prepare the buffer to be modified
- (clear-visited-file-modtime)
- (erase-buffer)
- ;; (/ 1 0)
- (insert (format saved-cmpl-file-header *completion-version*))
- (dolist (completion (list-all-completions))
- (setq total-in-db (1+ total-in-db))
- (setq last-use-time (completion-last-use-time completion))
- ;; Update num uses and maybe write completion to a file
- (cond ((or;; Write to file if
- ;; permanent
- (and (eq last-use-time t)
- (setq total-perm (1+ total-perm)))
- ;; or if
- (if (plusp (completion-num-uses completion))
- ;; it's been used
- (setq last-use-time current-time)
- ;; or it was saved before and
- (and last-use-time
- ;; *saved-completion-retention-time* is nil
- (or (not *saved-completion-retention-time*)
- ;; or time since last use is < ...retention-time*
- (< (- current-time last-use-time)
- *saved-completion-retention-time*))
- )))
- ;; write to file
- (setq total-saved (1+ total-saved))
- (insert (prin1-to-string (cons (completion-string completion)
- last-use-time)) "\n")
- )))
-
- ;; write the buffer
- (condition-case e
- (let ((file-exists-p (file-exists-p filename)))
- (when file-exists-p
- ;; If file exists . . .
- ;; Save a backup(so GNU doesn't screw us when we're out of disk)
- ;; (GNU leaves a 0 length file if it gets a disk full error!)
-
- ;; If backup doesn't exit, Rename current to backup
- ;; {If backup exists the primary file is probably messed up}
- (unless (file-exists-p backup-filename)
- (rename-file filename backup-filename))
- ;; Copy the backup back to the current name
- ;; (so versioning works)
- (copy-file backup-filename filename t)
- )
- ;; Save it
- (save-buffer)
- (when file-exists-p
- ;; If successful, remove backup
- (delete-file backup-filename)
- ))
- (error
- (set-buffer-modified-p nil)
- (message "Couldn't save completion file %s." filename)
- ))
- ;; Reset accepted-p flag
- (setq cmpl-completions-accepted-p nil)
- )
- (cmpl-statistics-block
- (record-save-completions total-in-db total-perm total-saved))
- )))
-
-(defun autosave-completions ()
- (when (and *save-completions-p* *completep* cmpl-initialized-p
- *completion-auto-save-period*
- (> cmpl-emacs-idle-time *completion-auto-save-period*)
- cmpl-completions-accepted-p)
- (save-completions-to-file)
- ))
-
-(pushnew 'autosave-completions cmpl-emacs-idle-time-hooks)
-
-(defun load-completions-from-file (&optional filename no-message-p)
- "loads a completion init file. If file is not specified,
- then *saved-completions-filename* is used"
- (interactive)
- (setq filename (expand-file-name (or filename *saved-completions-filename*)))
- (let* ((backup-filename (completion-backup-filename filename))
- (backup-readable-p (file-readable-p backup-filename))
- )
- (when backup-readable-p (setq filename backup-filename))
- (when (file-readable-p filename)
- (if (not no-message-p)
- (message "Loading completions from %sfile %s . . ."
- (if backup-readable-p "backup " "") filename))
- (save-excursion
- (get-buffer-create " *completion-save-buffer*")
- (set-buffer " *completion-save-buffer*")
- (setq buffer-file-name filename)
- ;; prepare the buffer to be modified
- (clear-visited-file-modtime)
- (erase-buffer)
-
- (let ((insert-okay-p nil)
- (buffer (current-buffer))
- (current-time (cmpl-hours-since-1900))
- string num-uses entry last-use-time
- cmpl-entry cmpl-last-use-time
- (current-completion-source cmpl-source-init-file)
- (start-num
- (cmpl-statistics-block
- (aref completion-add-count-vector cmpl-source-file-parsing)))
- (total-in-file 0) (total-perm 0)
- )
- ;; insert the file into a buffer
- (condition-case e
- (progn (insert-file-contents filename t)
- (setq insert-okay-p t))
-
- (file-error
- (message "File error trying to load completion file %s."
- filename)))
- ;; parse it
- (when insert-okay-p
- (goto-char (point-min))
-
- (condition-case e
- (while t
- (setq entry (read buffer))
- (setq total-in-file (1+ total-in-file))
- (cond
- ((and (consp entry)
- (stringp (setq string (car entry)))
- (cond
- ((eq (setq last-use-time (cdr entry)) 'T)
- ;; handle case sensitivity
- (setq total-perm (1+ total-perm))
- (setq last-use-time t))
- ((eq last-use-time t)
- (setq total-perm (1+ total-perm)))
- ((integerp last-use-time))
- ))
- ;; Valid entry
- ;; add it in
- (setq cmpl-last-use-time
- (completion-last-use-time
- (setq cmpl-entry
- (add-completion-to-tail-if-new string))
- ))
- (if (or (eq last-use-time t)
- (and (> last-use-time 1000);;backcompatibility
- (not (eq cmpl-last-use-time t))
- (or (not cmpl-last-use-time)
- ;; more recent
- (> last-use-time cmpl-last-use-time))
- ))
- ;; update last-use-time
- (set-completion-last-use-time cmpl-entry last-use-time)
- ))
- (t
- ;; Bad format
- (message "Error: invalid saved completion - %s"
- (prin1-to-string entry))
- ;; try to get back in sync
- (search-forward "\n(")
- )))
- (search-failed
- (message "End of file while reading completions.")
- )
- (end-of-file
- (if (= (point) (point-max))
- (if (not no-message-p)
- (message "Loading completions from file %s . . . Done."
- filename))
- (message "End of file while reading completions.")
- ))
- ))
-
- (cmpl-statistics-block
- (record-load-completions
- total-in-file total-perm
- (- (aref completion-add-count-vector cmpl-source-init-file)
- start-num)))
-
- )))))
-
-(defun initialize-completions ()
- "Loads the default completions file and sets up so that exiting emacs will
-automatically save the file."
- (interactive)
- (cond ((not cmpl-initialized-p)
- (load-completions-from-file)
- ))
- (init-cmpl-emacs-idle-process)
- (setq cmpl-initialized-p t)
- )
-
-
-;;;-----------------------------------------------
-;;; Kill EMACS patch
-;;;-----------------------------------------------
-
-(completion-advise kill-emacs :before
- ;; | All completion code should go in here
- ;;\ /
- (kill-emacs-save-completions)
- ;;/ \
- ;; | All completion code should go in here
- (cmpl-statistics-block
- (record-cmpl-kill-emacs))
- )
-
-
-;;;-----------------------------------------------
-;;; Kill region patch
-;;;-----------------------------------------------
-
-;;; Patched to remove the most recent completion
-(defvar $$$cmpl-old-kill-region (symbol-function 'kill-region))
-
-(defun kill-region (&optional beg end)
- "Kill between point and mark.
-The text is deleted but saved in the kill ring.
-The command \\[yank] can retrieve it from there.
-/(If you want to kill and then yank immediately, use \\[copy-region-as-kill].)
-
-This is the primitive for programs to kill text (as opposed to deleting it).
-Supply two arguments, character numbers indicating the stretch of text
- to be killed.
-Any command that calls this function is a \"kill command\".
-If the previous command was also a kill command,
-the text killed this time appends to the text killed last time
-to make one entry in the kill ring.
-Patched to remove the most recent completion."
- (interactive "*")
- (cond ((and (eq last-command 'complete) (eq last-command-char ?\C-w))
- (delete-region (point) cmpl-last-insert-location)
- (insert cmpl-original-string)
- (setq completion-to-accept nil)
- (cmpl-statistics-block
- (record-complete-failed))
- )
- (t
- (if (not beg)
- (setq beg (min (point) (mark))
- end (max (point) (mark)))
- )
- (funcall $$$cmpl-old-kill-region beg end)
- )))
-
-;;;-----------------------------------------------
-;;; Patches to self-insert-command.
-;;;-----------------------------------------------
-
-;;; Need 2 versions: generic seperator chars. and space (to get auto fill
-;;; to work)
-
-;;; All common separators (eg. space "(" ")" """) characters go through a
-;;; function to add new words to the list of words to complete from:
-;;; COMPLETION-SEPARATOR-SELF-INSERT-COMMAND (arg).
-;;; If the character before this was an alpha-numeric then this adds the
-;;; symbol befoe point to the completion list (using ADD-COMPLETION).
-
-(defun completion-separator-self-insert-command (arg)
- (interactive "p")
- (use-completion-before-separator)
- (self-insert-command arg)
- )
-
-(defun completion-separator-self-insert-autofilling (arg)
- (interactive "p")
- (use-completion-before-separator)
- (self-insert-command arg)
- (and (> (current-column) fill-column)
- auto-fill-hook
- (funcall auto-fill-hook))
- )
-
-;;;-----------------------------------------------
-;;; Wrapping Macro
-;;;-----------------------------------------------
-
-;;; Note that because of the way byte compiling works, none of
-;;; the functions defined with this macro get byte compiled.
-
-(defmacro def-completion-wrapper (function-name type &optional new-name)
- "Add a call to update the completion database before the function is
-executed. TYPE is the type of the wrapper to be added. Can be :before or
-:under."
- (completion-advise-1
- function-name ':before
- (ecase type
- (:before '((use-completion-before-point)))
- (:separator '((use-completion-before-separator)))
- (:under '((use-completion-under-point)))
- (:under-or-before
- '((use-completion-under-or-before-point)))
- (:minibuffer-separator
- '((let ((cmpl-syntax-table cmpl-standard-syntax-table))
- (use-completion-before-separator))))
- )
- new-name
- ))
-
-;;;(defun foo (x y z) (+ x y z))
-;;;foo
-;;;(macroexpand '(def-completion-wrapper foo :under))
-;;;(progn (defvar $$$cmpl-foo (symbol-function (quote foo))) (defun foo (&rest arglist) (progn (use-completion-under-point)) (cmpl-apply-as-top-level $$$cmpl-foo arglist)))
-;;;(defun bar (x y z) "Documentation" (+ x y z))
-;;;bar
-;;;(macroexpand '(def-completion-wrapper bar :under))
-;;;(progn (defvar $$$cmpl-bar (symbol-function (quote bar))) (defun bar (&rest arglist) "Documentation" (progn (use-completion-under-point)) (cmpl-apply-as-top-level $$$cmpl-bar arglist)))
-;;;(defun quuz (x &optional y z) "Documentation" (interactive "P") (+ x y z))
-;;;quuz
-;;;(macroexpand '(def-completion-wrapper quuz :before))
-;;;(progn (defvar $$$cmpl-quuz (symbol-function (quote quuz))) (defun quuz (&rest arglist) "Documentation" (interactive) (progn (use-completion-before-point)) (cmpl-apply-as-top-level $$$cmpl-quuz arglist)))
-
-
-;;;---------------------------------------------------------------------------
-;;; Patches to standard keymaps insert completions
-;;;---------------------------------------------------------------------------
-
-;;;-----------------------------------------------
-;;; Separators
-;;;-----------------------------------------------
-;;; We've used the completion syntax table given as a guide.
-;;;
-;;; Global separator chars.
-;;; We left out <tab> because there are too many special cases for it. Also,
-;;; in normal coding it's rarely typed after a word.
-(global-set-key " " 'completion-separator-self-insert-autofilling)
-(global-set-key "!" 'completion-separator-self-insert-command)
-(global-set-key "%" 'completion-separator-self-insert-command)
-(global-set-key "^" 'completion-separator-self-insert-command)
-(global-set-key "&" 'completion-separator-self-insert-command)
-(global-set-key "(" 'completion-separator-self-insert-command)
-(global-set-key ")" 'completion-separator-self-insert-command)
-(global-set-key "=" 'completion-separator-self-insert-command)
-(global-set-key "`" 'completion-separator-self-insert-command)
-(global-set-key "|" 'completion-separator-self-insert-command)
-(global-set-key "{" 'completion-separator-self-insert-command)
-(global-set-key "}" 'completion-separator-self-insert-command)
-(global-set-key "[" 'completion-separator-self-insert-command)
-(global-set-key "]" 'completion-separator-self-insert-command)
-(global-set-key ";" 'completion-separator-self-insert-command)
-(global-set-key "\"" 'completion-separator-self-insert-command)
-(global-set-key "'" 'completion-separator-self-insert-command)
-(global-set-key "#" 'completion-separator-self-insert-command)
-(global-set-key "," 'completion-separator-self-insert-command)
-(global-set-key "?" 'completion-separator-self-insert-command)
-
-;;; We include period and colon even though they are symbol chars because :
-;;; - in text we want to pick up the last word in a sentence.
-;;; - in C pointer refs. we want to pick up the first symbol
-;;; - it won't make a difference for lisp mode (package names are short)
-(global-set-key "." 'completion-separator-self-insert-command)
-(global-set-key ":" 'completion-separator-self-insert-command)
-
-;;; Lisp Mode diffs
-(define-key lisp-mode-map "!" 'self-insert-command)
-(define-key lisp-mode-map "&" 'self-insert-command)
-(define-key lisp-mode-map "%" 'self-insert-command)
-(define-key lisp-mode-map "?" 'self-insert-command)
-(define-key lisp-mode-map "=" 'self-insert-command)
-(define-key lisp-mode-map "^" 'self-insert-command)
-
-;;; C mode diffs.
-(def-completion-wrapper electric-c-semi :separator)
-(define-key c-mode-map "+" 'completion-separator-self-insert-command)
-(define-key c-mode-map "*" 'completion-separator-self-insert-command)
-(define-key c-mode-map "/" 'completion-separator-self-insert-command)
-
-;;; FORTRAN mode diffs. (these are defined when fortran is called)
-(defun completion-setup-fortran-mode ()
- (define-key fortran-mode-map "+" 'completion-separator-self-insert-command)
- (define-key fortran-mode-map "-" 'completion-separator-self-insert-command)
- (define-key fortran-mode-map "*" 'completion-separator-self-insert-command)
- (define-key fortran-mode-map "/" 'completion-separator-self-insert-command)
- )
-
-;;;-----------------------------------------------
-;;; End of line chars.
-;;;-----------------------------------------------
-(def-completion-wrapper newline :separator)
-(def-completion-wrapper newline-and-indent :separator)
-(if (function-defined-and-loaded 'shell-send-input)
- (def-completion-wrapper shell-send-input :separator))
-(def-completion-wrapper exit-minibuffer :minibuffer-separator)
-(def-completion-wrapper eval-print-last-sexp :separator)
-(def-completion-wrapper eval-last-sexp :separator)
-;;(def-completion-wrapper minibuffer-complete-and-exit :minibuffer)
-
-;;;-----------------------------------------------
-;;; Cursor movement
-;;;-----------------------------------------------
-
-(def-completion-wrapper next-line :under-or-before)
-(def-completion-wrapper previous-line :under-or-before)
-(def-completion-wrapper beginning-of-buffer :under-or-before)
-(def-completion-wrapper end-of-buffer :under-or-before)
-
-;; we patch these explicitly so they byte compile and so we don't have to
-;; patch the faster underlying function.
-
-(defun cmpl-beginning-of-line (&optional n)
- "Move point to beginning of current line.\n\
-With argument ARG not nil or 1, move forward ARG - 1 lines first.\n\
-If scan reaches end of buffer, stop there without error."
- (interactive "p")
- (use-completion-under-or-before-point)
- (beginning-of-line n)
- )
-
-(defun cmpl-end-of-line (&optional n)
- "Move point to end of current line.\n\
-With argument ARG not nil or 1, move forward ARG - 1 lines first.\n\
-If scan reaches end of buffer, stop there without error."
- (interactive "p")
- (use-completion-under-or-before-point)
- (end-of-line n)
- )
-
-(defun cmpl-forward-char (n)
- "Move point right ARG characters (left if ARG negative).\n\
-On reaching end of buffer, stop and signal error."
- (interactive "p")
- (use-completion-under-or-before-point)
- (forward-char n)
- )
-(defun cmpl-backward-char (n)
- "Move point left ARG characters (right if ARG negative).\n\
-On attempt to pass beginning or end of buffer, stop and signal error."
- (interactive "p")
- (use-completion-under-point)
- (if (eq last-command 'complete)
- ;; probably a failed completion if you have to back up
- (cmpl-statistics-block (record-complete-failed)))
- (backward-char n)
- )
-
-(defun cmpl-forward-word (n)
- "Move point forward ARG words (backward if ARG is negative).\n\
-Normally returns t.\n\
-If an edge of the buffer is reached, point is left there\n\
-and nil is returned."
- (interactive "p")
- (use-completion-under-or-before-point)
- (forward-word n)
- )
-(defun cmpl-backward-word (n)
- "Move backward until encountering the end of a word.
-With argument, do this that many times.
-In programs, it is faster to call forward-word with negative arg."
- (interactive "p")
- (use-completion-under-point)
- (if (eq last-command 'complete)
- ;; probably a failed completion if you have to back up
- (cmpl-statistics-block (record-complete-failed)))
- (forward-word (- n))
- )
-
-(defun cmpl-forward-sexp (n)
- "Move forward across one balanced expression.
-With argument, do this that many times."
- (interactive "p")
- (use-completion-under-or-before-point)
- (forward-sexp n)
- )
-(defun cmpl-backward-sexp (n)
- "Move backward across one balanced expression.
-With argument, do this that many times."
- (interactive "p")
- (use-completion-under-point)
- (if (eq last-command 'complete)
- ;; probably a failed completion if you have to back up
- (cmpl-statistics-block (record-complete-failed)))
- (backward-sexp n)
- )
-
-(defun cmpl-delete-backward-char (n killflag)
- "Delete the previous ARG characters (following, with negative ARG).\n\
-Optional second arg KILLFLAG non-nil means kill instead (save in kill ring).\n\
-Interactively, ARG is the prefix arg, and KILLFLAG is set if\n\
-ARG was explicitly specified."
- (interactive "p\nP")
- (if (eq last-command 'complete)
- ;; probably a failed completion if you have to back up
- (cmpl-statistics-block (record-complete-failed)))
- (delete-backward-char n killflag)
- )
-
-(defvar $$$cmpl-old-backward-delete-char-untabify
- (symbol-function 'backward-delete-char-untabify))
-
-(defun backward-delete-char-untabify (arg &optional killp)
- "Delete characters backward, changing tabs into spaces.
-Delete ARG chars, and kill (save in kill ring) if KILLP is non-nil.
-Interactively, ARG is the prefix arg (default 1)
-and KILLP is t if prefix arg is was specified."
- (interactive "*p\nP")
- (if (eq last-command 'complete)
- ;; probably a failed completion if you have to back up
- (cmpl-statistics-block (record-complete-failed)))
- (funcall $$$cmpl-old-backward-delete-char-untabify arg killp)
- )
-
-
-(global-set-key "\C-?" 'cmpl-delete-backward-char)
-(global-set-key "\M-\C-F" 'cmpl-forward-sexp)
-(global-set-key "\M-\C-B" 'cmpl-backward-sexp)
-(global-set-key "\M-F" 'cmpl-forward-word)
-(global-set-key "\M-B" 'cmpl-backward-word)
-(global-set-key "\C-F" 'cmpl-forward-char)
-(global-set-key "\C-B" 'cmpl-backward-char)
-(global-set-key "\C-A" 'cmpl-beginning-of-line)
-(global-set-key "\C-E" 'cmpl-end-of-line)
-
-;;;-----------------------------------------------
-;;; Misc.
-;;;-----------------------------------------------
-
-(def-completion-wrapper electric-buffer-list :under-or-before)
-(def-completion-wrapper list-buffers :under-or-before)
-(def-completion-wrapper scroll-up :under-or-before)
-(def-completion-wrapper scroll-down :under-or-before)
-(def-completion-wrapper execute-extended-command
- :under-or-before)
-(def-completion-wrapper other-window :under-or-before)
-
-;;;-----------------------------------------------
-;;; Local Thinking Machines stuff
-;;;-----------------------------------------------
-
-(if (fboundp 'up-ten-lines)
- (def-completion-wrapper up-ten-lines :under-or-before))
-(if (fboundp 'down-ten-lines)
- (def-completion-wrapper down-ten-lines :under-or-before))
-(if (fboundp 'tmc-scroll-up)
- (def-completion-wrapper tmc-scroll-up :under-or-before))
-(if (fboundp 'tmc-scroll-down)
- (def-completion-wrapper tmc-scroll-down :under-or-before))
-(if (fboundp 'execute-extended-command-and-check-for-bindings)
- (def-completion-wrapper execute-extended-command-and-check-for-bindings
- :under-or-before))
-
-;;; Tests --
-;;; foobarbiz
-;;; foobar
-;;; fooquux
-;;; fooper
-
-(cmpl-statistics-block
- (record-completion-file-loaded))
diff --git a/lisp/dabbrev.el b/lisp/dabbrev.el
new file mode 100644
index 00000000000..edd6fa75331
--- /dev/null
+++ b/lisp/dabbrev.el
@@ -0,0 +1,221 @@
+;; Dynamic abbreviation package for GNU Emacs.
+;; Copyright (C) 1985, 1986 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+; DABBREVS - "Dynamic abbreviations" hack, originally written by Don Morrison
+; for Twenex Emacs. Converted to mlisp by Russ Fish. Supports the table
+; feature to avoid hitting the same expansion on re-expand, and the search
+; size limit variable. Bugs fixed from the Twenex version are flagged by
+; comments starting with ;;; .
+;
+; converted to elisp by Spencer Thomas.
+; Thoroughly cleaned up by Richard Stallman.
+;
+; If anyone feels like hacking at it, Bob Keller (Keller@Utah-20) first
+; suggested the beast, and has some good ideas for its improvement, but
+; doesn?tknow TECO (the lucky devil...). One thing that should definitely
+; be done is adding the ability to search some other buffer(s) if you can?t
+; find the expansion you want in the current one.
+
+;; (defun dabbrevs-help ()
+;; "Give help about dabbrevs."
+;; (interactive)
+;; (&info "emacs" "dabbrevs") ; Select the specific info node.
+;; )
+(provide 'dabbrevs)
+
+(defvar dabbrevs-limit nil
+ "*Limits region searched by dabbrevs-expand to that many chars away (local).")
+(make-variable-buffer-local 'dabbrevs-limit)
+
+(defvar dabbrevs-backward-only nil
+ "*If non-NIL, dabbrevs-expand only looks backwards.")
+
+; State vars for dabbrevs-re-expand.
+(defvar last-dabbrevs-table nil
+ "Table of expansions seen so far. (local)")
+(make-variable-buffer-local 'last-dabbrevs-table)
+
+(defvar last-dabbrevs-abbreviation ""
+ "Last string we tried to expand. Buffer-local.")
+(make-variable-buffer-local 'last-dabbrevs-abbreviation)
+
+(defvar last-dabbrevs-direction 0
+ "Direction of last dabbrevs search. (local)")
+(make-variable-buffer-local 'last-dabbrevs-direction)
+
+(defvar last-dabbrevs-abbrev-location nil
+ "Location last abbreviation began (local).")
+(make-variable-buffer-local 'last-dabbrevs-abbrev-location)
+
+(defvar last-dabbrevs-expansion nil
+ "Last expansion of an abbreviation. (local)")
+(make-variable-buffer-local 'last-dabbrevs-expansion)
+
+(defvar last-dabbrevs-expansion-location nil
+ "Location the last expansion was found. (local)")
+(make-variable-buffer-local 'last-dabbrevs-expansion-location)
+
+(defun dabbrev-expand (arg)
+ "Expand previous word \"dynamically\".
+Expands to the most recent, preceding word for which this is a prefix.
+If no suitable preceding word is found, words following point are considered.
+
+A positive prefix argument, N, says to take the Nth backward DISTINCT
+possibility. A negative argument says search forward. The variable
+dabbrev-backward-only may be used to limit the direction of search to
+backward if set non-nil.
+
+If the cursor has not moved from the end of the previous expansion and
+no argument is given, replace the previously-made expansion
+with the next possible expansion not yet tried."
+ (interactive "*P")
+ (let (abbrev expansion old which loc n pattern
+ (do-case (and case-fold-search case-replace)))
+ ;; abbrev -- the abbrev to expand
+ ;; expansion -- the expansion found (eventually) or nil until then
+ ;; old -- the text currently in the buffer
+ ;; (the abbrev, or the previously-made expansion)
+ ;; loc -- place where expansion is found
+ ;; (to start search there for next expansion if requested later)
+ ;; do-case -- nil if should consider case significant.
+ (save-excursion
+ (if (and (null arg)
+ (eq last-command this-command)
+ last-dabbrevs-abbrev-location)
+ (progn
+ (setq abbrev last-dabbrevs-abbreviation)
+ (setq old last-dabbrevs-expansion)
+ (setq which last-dabbrevs-direction))
+ (setq which (if (null arg)
+ (if dabbrevs-backward-only 1 0)
+ (prefix-numeric-value arg)))
+ (setq loc (point))
+ (forward-word -1)
+ (setq last-dabbrevs-abbrev-location (point)) ; Original location.
+ (setq abbrev (buffer-substring (point) loc))
+ (setq old abbrev)
+ (setq last-dabbrevs-expansion-location nil)
+ (setq last-dabbrev-table nil)) ; Clear table of things seen.
+
+ (setq pattern (concat "\\b" (regexp-quote abbrev) "\\(\\sw\\|\\s_\\)+"))
+ ;; Try looking backward unless inhibited.
+ (if (>= which 0)
+ (progn
+ (setq n (max 1 which))
+ (if last-dabbrevs-expansion-location
+ (goto-char last-dabbrevs-expansion-location))
+ (while (and (> n 0)
+ (setq expansion (dabbrevs-search pattern t do-case)))
+ (setq loc (point-marker))
+ (setq last-dabbrev-table (cons expansion last-dabbrev-table))
+ (setq n (1- n)))
+ (or expansion
+ (setq last-dabbrevs-expansion-location nil))
+ (setq last-dabbrevs-direction (min 1 which))))
+
+ (if (and (<= which 0) (not expansion)) ; Then look forward.
+ (progn
+ (setq n (max 1 (- which)))
+ (if last-dabbrevs-expansion-location
+ (goto-char last-dabbrevs-expansion-location))
+ (while (and (> n 0)
+ (setq expansion (dabbrevs-search pattern nil do-case)))
+ (setq loc (point-marker))
+ (setq last-dabbrev-table (cons expansion last-dabbrev-table))
+ (setq n (1- n)))
+ (setq last-dabbrevs-direction -1))))
+
+ (if (not expansion)
+ (let ((first (string= abbrev old)))
+ (setq last-dabbrevs-abbrev-location nil)
+ (if (not first)
+ (progn (undo-boundary)
+ (delete-backward-char (length old))
+ (insert abbrev)))
+ (error (if first
+ "No dynamic expansion for \"%s\" found."
+ "No further dynamic expansions for \"%s\" found.")
+ abbrev))
+ ;; Success: stick it in and return.
+ (undo-boundary)
+ (search-backward old)
+ ;; Make case of replacement conform to case of abbreviation
+ ;; provided (1) that kind of thing is enabled in this buffer
+ ;; and (2) the replacement itself is all lower case
+ ;; except perhaps for the first character.
+ (let ((do-case (and do-case
+ (string= (substring expansion 1)
+ (downcase (substring expansion 1))))))
+ ;; First put back the original abbreviation with its original
+ ;; case pattern.
+ (save-excursion
+ (replace-match abbrev t 'literal))
+ (search-forward abbrev)
+ (replace-match (if do-case (downcase expansion) expansion)
+ (not do-case)
+ 'literal))
+ ;; Save state for re-expand.
+ (setq last-dabbrevs-abbreviation abbrev)
+ (setq last-dabbrevs-expansion expansion)
+ (setq last-dabbrevs-expansion-location loc))))
+
+;; Search function used by dabbrevs library.
+;; First arg is string to find as prefix of word. Second arg is
+;; t for reverse search, nil for forward. Variable dabbrevs-limit
+;; controls the maximum search region size.
+
+;; Table of expansions already seen is examined in buffer last-dabbrev-table,
+;; so that only distinct possibilities are found by dabbrevs-re-expand.
+;; Note that to prevent finding the abbrev itself it must have been
+;; entered in the table.
+
+;; Value is the expansion, or nil if not found. After a successful
+;; search, point is left right after the expansion found.
+
+(defun dabbrevs-search (pattern reverse do-case)
+ (let (missing result)
+ (save-restriction ; Uses restriction for limited searches.
+ (if dabbrevs-limit
+ (narrow-to-region last-dabbrevs-abbrev-location
+ (+ (point)
+ (* dabbrevs-limit (if reverse -1 1)))))
+ ;; Keep looking for a distinct expansion.
+ (setq result nil)
+ (setq missing nil)
+ (while (and (not result) (not missing))
+ ; Look for it, leave loop if search fails.
+ (setq missing
+ (not (if reverse
+ (re-search-backward pattern nil t)
+ (re-search-forward pattern nil t))))
+
+ (if (not missing)
+ (progn
+ (setq result (buffer-substring (match-beginning 0)
+ (match-end 0)))
+ (let* ((test last-dabbrev-table))
+ (while (and test
+ (not
+ (if do-case
+ (string= (downcase (car test)) (downcase result))
+ (string= (car test) result))))
+ (setq test (cdr test)))
+ (if test (setq result nil)))))) ; if already in table, ignore
+ result)))
diff --git a/lisp/dabbrev.elc b/lisp/dabbrev.elc
new file mode 100644
index 00000000000..689b5a88af0
--- /dev/null
+++ b/lisp/dabbrev.elc
Binary files differ
diff --git a/lisp/dbx.el b/lisp/dbx.el
new file mode 100644
index 00000000000..9b268fee133
--- /dev/null
+++ b/lisp/dbx.el
@@ -0,0 +1,165 @@
+;; Run dbx under Emacs
+;; Copyright (C) 1988 Free Software Foundation, Inc.
+;; Main author Masanobu UMEDA (umerin@flab.fujitsu.junet)
+
+;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+(require 'shell)
+
+(defvar dbx-trace-flag nil
+ "Dbx trace switch.")
+
+(defvar dbx-process nil
+ "The process in which dbx is running.")
+
+(defvar dbx-break-point
+ "stopped in .* at line \\([0-9]*\\) in file \"\\([^\"]*\\)\""
+ "Regexp of pattern that dbx writes at break point.")
+
+(defvar inferior-dbx-mode-map nil)
+(if inferior-dbx-mode-map
+ nil
+ (setq inferior-dbx-mode-map (copy-keymap shell-mode-map))
+ (define-key inferior-dbx-mode-map "\C-cw" 'dbx-where)
+ (define-key inferior-dbx-mode-map "\C-c\C-t" 'dbx-trace-mode)
+ (define-key ctl-x-map " " 'dbx-stop-at))
+
+(defun inferior-dbx-mode ()
+ "Major mode for interacting with an inferior Dbx process.
+
+The following commands are available:
+\\{inferior-dbx-mode-map}
+
+Entry to this mode calls the value of dbx-mode-hook with no arguments,
+if that value is non-nil. Likewise with the value of shell-mode-hook.
+dbx-mode-hook is called after shell-mode-hook.
+
+You can display the debugging program in other window and point out
+where you are looking at using the command \\[dbx-where].
+
+\\[dbx-trace-mode] toggles dbx-trace mode. In dbx-trace mode,
+debugging program is automatically traced using output from dbx.
+
+The command \\[dbx-stop-at] sets break point at current line of the
+program in the buffer. Major mode name of the buffer must be in
+dbx-language-mode-list.
+
+Commands:
+
+Return at end of buffer sends line as input.
+Return not at end copies rest of line to end and sends it.
+\\[shell-send-eof] sends end-of-file as input.
+\\[kill-shell-input] and \\[backward-kill-word] are kill commands, imitating normal Unix input editing.
+\\[interrupt-shell-subjob] interrupts the shell or its current subjob if any.
+\\[stop-shell-subjob] stops, likewise. \\[quit-shell-subjob] sends quit signal, likewise.
+\\[dbx-where] displays debugging program in other window and
+ points out where you are looking at.
+\\[dbx-trace-mode] toggles dbx-trace mode.
+\\[dbx-stop-at] sets break point at current line."
+ (interactive)
+ (kill-all-local-variables)
+ (setq major-mode 'inferior-dbx-mode)
+ (setq mode-name "Inferior Dbx")
+ (setq mode-line-process '(": %s"))
+ (use-local-map inferior-dbx-mode-map)
+ (make-local-variable 'last-input-start)
+ (setq last-input-start (make-marker))
+ (make-local-variable 'last-input-end)
+ (setq last-input-end (make-marker))
+ (make-local-variable 'dbx-trace-flag)
+ (setq dbx-trace-flag nil)
+ (make-variable-buffer-local 'shell-prompt-pattern)
+ (setq shell-prompt-pattern "^[^)]*dbx) *") ;Set dbx prompt pattern
+ (or (assq 'dbx-trace-flag minor-mode-alist)
+ (setq minor-mode-alist
+ (cons '(dbx-trace-flag " Trace") minor-mode-alist)))
+ (run-hooks 'shell-mode-hook 'dbx-mode-hook))
+
+(defun run-dbx (path)
+ "Run an inferior Dbx process, input and output via buffer *dbx*."
+ (interactive "fProgram to debug: ")
+ (setq path (expand-file-name path))
+ (let ((file (file-name-nondirectory path)))
+ (switch-to-buffer (concat "*dbx-" file "*"))
+ (setq default-directory (file-name-directory path))
+ (switch-to-buffer (make-shell (concat "dbx-" file) "dbx" nil file)))
+ (setq dbx-process (get-buffer-process (current-buffer)))
+ (set-process-filter dbx-process 'dbx-filter)
+ (inferior-dbx-mode))
+
+(defun dbx-trace-mode (arg)
+ "Toggle dbx-trace mode.
+With arg, turn dbx-trace mode on iff arg is positive.
+In dbx-trace mode, user program is automatically traced."
+ (interactive "P")
+ (if (not (eql major-mode 'inferior-dbx-mode))
+ (error "Dbx-trace mode is effective in inferior-dbx mode only."))
+ (setq dbx-trace-flag
+ (if (null arg)
+ (not dbx-trace-flag)
+ (> (prefix-numeric-value arg) 0)))
+ ;; Force mode line redisplay
+ (set-buffer-modified-p (buffer-modified-p)))
+
+(defun dbx-filter (process string)
+ "Trace debugging program automatically if dbx-trace-flag is not nil."
+ (save-excursion
+ (set-buffer (process-buffer process))
+ (goto-char (point-max))
+ (let ((beg (point)))
+ (insert string)
+ (if dbx-trace-flag ;Trace mode is on?
+ (dbx-where beg t)))
+ (if (process-mark process)
+ (set-marker (process-mark process) (point-max))))
+ (if (eq (process-buffer process)
+ (current-buffer))
+ (goto-char (point-max)))
+ )
+
+(defun dbx-where (&optional begin quiet)
+ "Display dbx'ed program in other window and point out where you are looking at.
+BEGIN bounds the search. If QUIET, just return nil (no error) if fail."
+ (interactive)
+ (let (file line)
+ (save-excursion
+ (if (re-search-backward dbx-break-point begin quiet)
+ (progn
+ (setq line (buffer-substring (match-beginning 1) (match-end 1)))
+ (setq file (buffer-substring (match-beginning 2) (match-end 2)))
+ )))
+ (if (and file line) ;Find break point?
+ (progn
+ (find-file-other-window (expand-file-name file nil))
+ (goto-line (string-to-int line)) ;Jump to the line
+ (beginning-of-line)
+ (setq overlay-arrow-string "=>")
+ (or overlay-arrow-position
+ (setq overlay-arrow-position (make-marker)))
+ (set-marker overlay-arrow-position (point) (current-buffer))
+ (other-window 1)) ;Return to dbx
+ )))
+
+(defun dbx-stop-at ()
+ "Set break point at current line."
+ (interactive)
+ (let ((file-name (file-name-nondirectory buffer-file-name))
+ (line (save-restriction
+ (widen)
+ (1+ (count-lines 1 (point))))))
+ (send-string dbx-process
+ (concat "stop at \"" file-name "\":" line "\n"))))
diff --git a/lisp/dbx.elc b/lisp/dbx.elc
new file mode 100644
index 00000000000..6f73b802ef7
--- /dev/null
+++ b/lisp/dbx.elc
Binary files differ
diff --git a/lisp/debug.el b/lisp/debug.el
new file mode 100644
index 00000000000..0c6a124d837
--- /dev/null
+++ b/lisp/debug.el
@@ -0,0 +1,261 @@
+;; Debuggers and related commands for Emacs
+;; Copyright (C) 1985, 1986 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+(setq debugger 'debug)
+
+(defun debug (&rest debugger-args)
+ "Enter debugger. Returns if user says \"continue\".
+Arguments are mainly for use when this is called
+ from the internals of the evaluator.
+You may call with no args, or you may
+ pass nil as the first arg and any other args you like.
+ In that case, the list of args after the first will
+ be printed into the backtrace buffer."
+ (message "Entering debugger...")
+ (let (debugger-value
+ (debugger-match-data (match-data))
+ (debug-on-error nil)
+ (debug-on-quit nil)
+ (debugger-buffer (let ((default-major-mode 'fundamental-mode))
+ (generate-new-buffer "*Backtrace*")))
+ (debugger-old-buffer (current-buffer))
+ (debugger-step-after-exit nil)
+ ;; Don't keep reading from an executing kbd macro!
+ (executing-macro nil)
+ (cursor-in-echo-area nil))
+ (unwind-protect
+ (save-excursion
+ (save-window-excursion
+ (pop-to-buffer debugger-buffer)
+ (erase-buffer)
+ (let ((standard-output (current-buffer))
+ (print-escape-newlines t)
+ (print-length 50))
+ (backtrace))
+ (goto-char (point-min))
+ (debugger-mode)
+ (delete-region (point)
+ (progn
+ (forward-sexp 8)
+ (forward-line 1)
+ (point)))
+ (cond ((memq (car debugger-args) '(lambda debug))
+ (insert "Entering:\n")
+ (if (eq (car debugger-args) 'debug)
+ (progn
+ (backtrace-debug 4 t)
+ (delete-char 1)
+ (insert ?*)
+ (beginning-of-line))))
+ ((eq (car debugger-args) 'exit)
+ (insert "Return value: ")
+ (setq debugger-value (nth 1 debugger-args))
+ (prin1 debugger-value (current-buffer))
+ (insert ?\n)
+ (delete-char 1)
+ (insert ? )
+ (beginning-of-line))
+ ((eq (car debugger-args) 'error)
+ (insert "Signalling: ")
+ (prin1 (nth 1 debugger-args) (current-buffer))
+ (insert ?\n))
+ ((eq (car debugger-args) t)
+ (insert "Beginning evaluation of function call form:\n"))
+ (t
+ (prin1 (if (eq (car debugger-args) 'nil)
+ (cdr debugger-args) debugger-args)
+ (current-buffer))
+ (insert ?\n)))
+ (message "")
+ (let ((inhibit-trace t)
+ (standard-output nil)
+ (buffer-read-only t))
+ (message "")
+ (recursive-edit))))
+ ;; So that users do not try to execute debugger commands
+ ;; in an invalid context
+ (kill-buffer debugger-buffer)
+ (store-match-data debugger-match-data))
+ (setq debug-on-next-call debugger-step-after-exit)
+ debugger-value))
+
+(defun debugger-step-through ()
+ "Proceed, stepping through subexpressions of this expression.
+Enter another debugger on next entry to eval, apply or funcall."
+ (interactive)
+ (setq debugger-step-after-exit t)
+ (message "Proceding, will debug on next eval or call.")
+ (exit-recursive-edit))
+
+(defun debugger-continue ()
+ "Continue, evaluating this expression without stopping."
+ (interactive)
+ (message "Continuing.")
+ (exit-recursive-edit))
+
+(defun debugger-return-value (val)
+ "Continue, specifying value to return.
+This is only useful when the value returned from the debugger
+will be used, such as in a debug on exit from a frame."
+ (interactive "XReturn value (evaluated): ")
+ (setq debugger-value val)
+ (princ "Returning " t)
+ (prin1 debugger-value)
+ (exit-recursive-edit))
+
+(defun debugger-frame-number ()
+ "Return number of frames in backtrace before the one point points at."
+ (save-excursion
+ (beginning-of-line)
+ (let ((opoint (point))
+ (count 0))
+ (goto-char (point-min))
+ (if (or (equal (buffer-substring (point) (+ (point) 6))
+ "Signal")
+ (equal (buffer-substring (point) (+ (point) 6))
+ "Return"))
+ (progn
+ (search-forward ":")
+ (forward-sexp 1)))
+ (forward-line 1)
+ (while (progn
+ (forward-char 2)
+ (if (= (following-char) ?\()
+ (forward-sexp 1)
+ (forward-sexp 2))
+ (forward-line 1)
+ (<= (point) opoint))
+ (setq count (1+ count)))
+ count)))
+
+;; Chosen empirically to account for all the frames
+;; that will exist when debugger-frame is called
+;; within the first one that appears in the backtrace buffer.
+;; Assumes debugger-frame is called from a key;
+;; will be wrong if it is called with Meta-x.
+(defconst debugger-frame-offset 8 "")
+
+(defun debugger-frame ()
+ "Request entry to debugger when this frame exits.
+Applies to the frame whose line point is on in the backtrace."
+ (interactive)
+ (beginning-of-line)
+ (let ((level (debugger-frame-number)))
+ (backtrace-debug (+ level debugger-frame-offset) t))
+ (if (= (following-char) ? )
+ (let ((buffer-read-only nil))
+ (delete-char 1)
+ (insert ?*)))
+ (beginning-of-line))
+
+(defun debugger-frame-clear ()
+ "Do not enter to debugger when this frame exits.
+Applies to the frame whose line point is on in the backtrace."
+ (interactive)
+ (beginning-of-line)
+ (let ((level (debugger-frame-number)))
+ (backtrace-debug (+ level debugger-frame-offset) nil))
+ (if (= (following-char) ?*)
+ (let ((buffer-read-only nil))
+ (delete-char 1)
+ (insert ? )))
+ (beginning-of-line))
+
+(defun debugger-eval-expression (exp)
+ (interactive "xEval: ")
+ (save-excursion
+ (if (null (buffer-name debugger-old-buffer))
+ ;; old buffer deleted
+ (setq debugger-old-buffer (current-buffer)))
+ (set-buffer debugger-old-buffer)
+ (eval-expression exp)))
+
+(defvar debugger-mode-map nil)
+(if debugger-mode-map
+ nil
+ (let ((loop ? ))
+ (setq debugger-mode-map (make-keymap))
+ (suppress-keymap debugger-mode-map)
+ (define-key debugger-mode-map "-" 'negative-argument)
+ (define-key debugger-mode-map "b" 'debugger-frame)
+ (define-key debugger-mode-map "c" 'debugger-continue)
+ (define-key debugger-mode-map "r" 'debugger-return-value)
+ (define-key debugger-mode-map "u" 'debugger-frame-clear)
+ (define-key debugger-mode-map "d" 'debugger-step-through)
+ (define-key debugger-mode-map "h" 'describe-mode)
+ (define-key debugger-mode-map "q" 'top-level)
+ (define-key debugger-mode-map "e" 'debugger-eval-expression)
+ (define-key debugger-mode-map " " 'next-line)))
+
+(put 'debugger-mode 'mode-class 'special)
+
+(defun debugger-mode ()
+ "Mode for backtrace buffers, selected in debugger.
+\\{debugger-mode-map}
+For the r command, when in debugger due to frame being exited,
+ the value specified here will be used as the value of that frame.
+
+Note lines starting with * are frames that will
+ enter debugger when exited."
+ (kill-all-local-variables)
+ (setq major-mode 'debugger-mode)
+ (setq mode-name "Debugger")
+ (setq truncate-lines t)
+ (set-syntax-table emacs-lisp-mode-syntax-table)
+ (use-local-map debugger-mode-map))
+
+(defun debug-on-entry (function)
+ "Request FUNCTION to invoke debugger each time it is called.
+If the user continues, FUNCTION's execution proceeds.
+Works by modifying the definition of FUNCTION,
+which must be written in Lisp, not predefined.
+Use `cancel-debug-on-entry' to cancel the effect of this command.
+Redefining FUNCTION also does that."
+ (interactive "aDebug on entry (to function): ")
+ (let ((defn (symbol-function function)))
+ (if (eq (car defn) 'macro)
+ (fset function (cons 'macro (debug-on-entry-1 function (cdr defn) t)))
+ (fset function (debug-on-entry-1 function defn t))))
+ function)
+
+(defun cancel-debug-on-entry (function)
+ "Undoes effect of debug-on-entry on FUNCTION."
+ (interactive "aCancel debug on entry (to function): ")
+ (let ((defn (symbol-function function)))
+ (if (eq (car defn) 'macro)
+ (fset function
+ (cons 'macro (debug-on-entry-1 function (cdr defn) nil)))
+ (fset function (debug-on-entry-1 function defn nil))))
+ function)
+
+(defun debug-on-entry-1 (function defn flag)
+ (or (eq (car defn) 'lambda)
+ (error "%s not user-defined Lisp function." function))
+ (let (tail prec)
+ (if (stringp (car (nthcdr 2 defn)))
+ (setq tail (nthcdr 3 defn)
+ prec (list (car defn) (car (cdr defn)) (car (cdr (cdr defn)))))
+ (setq tail (nthcdr 2 defn)
+ prec (list (car defn) (car (cdr defn)))))
+ (if (eq flag (equal (car tail) '(debug 'debug)))
+ nil
+ (if flag
+ (nconc prec (cons '(debug 'debug) tail))
+ (nconc prec (cdr tail))))))
diff --git a/lisp/debug.elc b/lisp/debug.elc
new file mode 100644
index 00000000000..eb613e80b02
--- /dev/null
+++ b/lisp/debug.elc
Binary files differ
diff --git a/lisp/dired.el b/lisp/dired.el
new file mode 100644
index 00000000000..e56afcc8e17
--- /dev/null
+++ b/lisp/dired.el
@@ -0,0 +1,633 @@
+;;; Missing: P command, sorting, setting file modes.
+;;; Dired buffer containing multiple directories gets totally confused
+;;; Implement insertion of subdirectories in situ --- tree dired
+
+;; DIRED commands for Emacs
+;; Copyright (C) 1985, 1986 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+;In loaddefs.el
+;(defvar dired-listing-switches "-al"
+; "Switches passed to ls for dired. MUST contain the 'l' option.
+;CANNOT contain the 'F' option.")
+
+(defun dired-readin (dirname buffer)
+ (save-excursion
+ (message "Reading directory %s..." dirname)
+ (set-buffer buffer)
+ (let ((buffer-read-only nil))
+ (widen)
+ (erase-buffer)
+ (setq dirname (expand-file-name dirname))
+ (if (file-directory-p dirname)
+ (call-process "ls" nil buffer nil
+ dired-listing-switches dirname)
+ (let ((default-directory (file-name-directory dirname)))
+ (call-process shell-file-name nil buffer nil
+ "-c" (concat "ls " dired-listing-switches " "
+ (file-name-nondirectory dirname)))))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (insert " ")
+ (forward-line 1))
+ (goto-char (point-min)))
+ (set-buffer-modified-p nil)
+ (message "Reading directory %s...done" dirname)))
+
+(defun dired-find-buffer (dirname)
+ (let ((blist (buffer-list))
+ found)
+ (while blist
+ (save-excursion
+ (set-buffer (car blist))
+ (if (and (eq major-mode 'dired-mode)
+ (equal dired-directory dirname))
+ (setq found (car blist)
+ blist nil)
+ (setq blist (cdr blist)))))
+ (or found
+ (create-file-buffer (directory-file-name dirname)))))
+
+(defun dired (dirname)
+ "\"Edit\" directory DIRNAME--delete, rename, print, etc. some files in it.
+Dired displays a list of files in DIRNAME.
+You can move around in it with the usual commands.
+You can flag files for deletion with C-d
+and then delete them by typing `x'.
+Type `h' after entering dired for more info."
+ (interactive (list (read-file-name "Dired (directory): "
+ nil default-directory nil)))
+ (switch-to-buffer (dired-noselect dirname)))
+
+(defun dired-other-window (dirname)
+ "\"Edit\" directory DIRNAME. Like M-x dired but selects in another window."
+ (interactive (list (read-file-name "Dired in other window (directory): "
+ nil default-directory nil)))
+ (switch-to-buffer-other-window (dired-noselect dirname)))
+
+(defun dired-noselect (dirname)
+ "Like M-x dired but returns the dired buffer as value, does not select it."
+ (or dirname (setq dirname default-directory))
+ (setq dirname (expand-file-name (directory-file-name dirname)))
+ (if (file-directory-p dirname)
+ (setq dirname (file-name-as-directory dirname)))
+ (let ((buffer (dired-find-buffer dirname)))
+ (save-excursion
+ (set-buffer buffer)
+ (dired-readin dirname buffer)
+ (dired-move-to-filename)
+ (dired-mode dirname))
+ buffer))
+
+(defun dired-revert (&optional arg noconfirm)
+ (let ((opoint (point))
+ (ofile (dired-get-filename t t))
+ (buffer-read-only nil))
+ (erase-buffer)
+ (dired-readin dired-directory (current-buffer))
+ (or (and ofile (re-search-forward (concat " " (regexp-quote ofile) "$")
+ nil t))
+ (goto-char opoint))
+ (beginning-of-line)))
+
+(defvar dired-mode-map nil "Local keymap for dired-mode buffers.")
+(if dired-mode-map
+ nil
+ (setq dired-mode-map (make-keymap))
+ (suppress-keymap dired-mode-map)
+ (define-key dired-mode-map "r" 'dired-rename-file)
+ (define-key dired-mode-map "\C-d" 'dired-flag-file-deleted)
+ (define-key dired-mode-map "d" 'dired-flag-file-deleted)
+ (define-key dired-mode-map "v" 'dired-view-file)
+ (define-key dired-mode-map "e" 'dired-find-file)
+ (define-key dired-mode-map "f" 'dired-find-file)
+ (define-key dired-mode-map "o" 'dired-find-file-other-window)
+ (define-key dired-mode-map "u" 'dired-unflag)
+ (define-key dired-mode-map "x" 'dired-do-deletions)
+ (define-key dired-mode-map "\177" 'dired-backup-unflag)
+ (define-key dired-mode-map "?" 'dired-summary)
+ (define-key dired-mode-map "c" 'dired-copy-file)
+ (define-key dired-mode-map "#" 'dired-flag-auto-save-files)
+ (define-key dired-mode-map "~" 'dired-flag-backup-files)
+ (define-key dired-mode-map "." 'dired-clean-directory)
+ (define-key dired-mode-map "h" 'describe-mode)
+ (define-key dired-mode-map " " 'dired-next-line)
+ (define-key dired-mode-map "\C-n" 'dired-next-line)
+ (define-key dired-mode-map "\C-p" 'dired-previous-line)
+ (define-key dired-mode-map "n" 'dired-next-line)
+ (define-key dired-mode-map "p" 'dired-previous-line)
+ (define-key dired-mode-map "g" 'revert-buffer)
+ (define-key dired-mode-map "C" 'dired-compress)
+ (define-key dired-mode-map "U" 'dired-uncompress)
+ (define-key dired-mode-map "B" 'dired-byte-recompile)
+ (define-key dired-mode-map "M" 'dired-chmod)
+ (define-key dired-mode-map "G" 'dired-chgrp)
+ (define-key dired-mode-map "O" 'dired-chown))
+
+
+;; Dired mode is suitable only for specially formatted data.
+(put 'dired-mode 'mode-class 'special)
+
+(defun dired-mode (&optional dirname)
+ "Mode for \"editing\" directory listings.
+In dired, you are \"editing\" a list of the files in a directory.
+You can move using the usual cursor motion commands.
+Letters no longer insert themselves.
+Instead, type d to flag a file for Deletion.
+Type u to Unflag a file (remove its D flag).
+ Type Rubout to back up one line and unflag.
+Type x to eXecute the deletions requested.
+Type f to Find the current line's file
+ (or Dired it, if it is a directory).
+Type o to find file or dired directory in Other window.
+Type # to flag temporary files (names beginning with #) for Deletion.
+Type ~ to flag backup files (names ending with ~) for Deletion.
+Type . to flag numerical backups for Deletion.
+ (Spares dired-kept-versions or its numeric argument.)
+Type r to rename a file.
+Type c to copy a file.
+Type v to view a file in View mode, returning to Dired when done.
+Type g to read the directory again. This discards all deletion-flags.
+Space and Rubout can be used to move down and up by lines.
+Also: C -- compress this file. U -- uncompress this file.
+ B -- byte compile this file.
+ M, G, O -- change file's mode, group or owner.
+\\{dired-mode-map}"
+ (interactive)
+ (kill-all-local-variables)
+ (make-local-variable 'revert-buffer-function)
+ (setq revert-buffer-function 'dired-revert)
+ (setq major-mode 'dired-mode)
+ (setq mode-name "Dired")
+ (make-local-variable 'dired-directory)
+ (setq dired-directory (or dirname default-directory))
+ (if dirname
+ (setq default-directory
+ (if (file-directory-p dirname)
+ dirname (file-name-directory dirname))))
+ (setq mode-line-buffer-identification '("Dired: %17b"))
+ (setq case-fold-search nil)
+ (setq buffer-read-only t)
+ (use-local-map dired-mode-map)
+ (run-hooks 'dired-mode-hook))
+
+(defun dired-repeat-over-lines (arg function)
+ (beginning-of-line)
+ (while (and (> arg 0) (not (eobp)))
+ (setq arg (1- arg))
+ (save-excursion
+ (beginning-of-line)
+ (and (bobp) (looking-at " total")
+ (error "No file on this line"))
+ (funcall function))
+ (forward-line 1)
+ (dired-move-to-filename))
+ (while (and (< arg 0) (not (bobp)))
+ (setq arg (1+ arg))
+ (forward-line -1)
+ (dired-move-to-filename)
+ (save-excursion
+ (beginning-of-line)
+ (funcall function))))
+
+(defun dired-flag-file-deleted (arg)
+ "In dired, flag the current line's file for deletion.
+With arg, repeat over several lines."
+ (interactive "p")
+ (dired-repeat-over-lines arg
+ '(lambda ()
+ (let ((buffer-read-only nil))
+ (delete-char 1)
+ (insert "D")))))
+
+(defun dired-summary ()
+ (interactive)
+ ;>> this should check the key-bindings and use substitute-command-keys if non-standard
+ (message
+ "d-elete, u-ndelete, x-ecute, f-ind, o-ther window, r-ename, c-opy, v-iew"))
+
+(defun dired-unflag (arg)
+ "In dired, remove the current line's delete flag then move to next line."
+ (interactive "p")
+ (dired-repeat-over-lines arg
+ '(lambda ()
+ (let ((buffer-read-only nil))
+ (delete-char 1)
+ (insert " ")
+ (forward-char -1)))))
+
+(defun dired-backup-unflag (arg)
+ "In dired, move up a line and remove deletion flag there."
+ (interactive "p")
+ (dired-unflag (- arg)))
+
+(defun dired-next-line (arg)
+ "Move down ARG lines then position at filename."
+ (interactive "p")
+ (next-line arg)
+ (dired-move-to-filename))
+
+(defun dired-previous-line (arg)
+ "Move up ARG lines then position at filename."
+ (interactive "p")
+ (previous-line arg)
+ (dired-move-to-filename))
+
+(defun dired-find-file ()
+ "In dired, visit the file or directory named on this line."
+ (interactive)
+ (find-file (dired-get-filename)))
+
+(defun dired-view-file ()
+ "In dired, examine a file in view mode, returning to dired when done."
+ (interactive)
+ (if (file-directory-p (dired-get-filename))
+ (dired (dired-get-filename))
+ (view-file (dired-get-filename))))
+
+(defun dired-find-file-other-window ()
+ "In dired, visit this file or directory in another window."
+ (interactive)
+ (find-file-other-window (dired-get-filename)))
+
+(defun dired-get-filename (&optional localp no-error-if-not-filep)
+ "In dired, return name of file mentioned on this line.
+Value returned normally includes the directory name.
+A non-nil 1st argument means do not include it. A non-nil 2nd argument
+says return nil if no filename on this line, otherwise an error occurs."
+ (let (eol)
+ (save-excursion
+ (end-of-line)
+ (setq eol (point))
+ (beginning-of-line)
+ (if (re-search-forward
+ "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct\\|Nov\\|Dec\\)[ ]+[0-9]+"
+ eol t)
+ (progn (skip-chars-forward " ")
+ (skip-chars-forward "^ " eol)
+ (skip-chars-forward " " eol)
+ (let ((beg (point)))
+ (skip-chars-forward "^ \n")
+ (if localp
+ (buffer-substring beg (point))
+ ;; >> uses default-directory, could lose on cd, multiple.
+ (concat default-directory (buffer-substring beg (point))))))
+ (if no-error-if-not-filep nil
+ (error "No file on this line"))))))
+
+(defun dired-move-to-filename ()
+ "In dired, move to first char of filename on this line.
+Returns position (point) or nil if no filename on this line."
+ (let ((eol (progn (end-of-line) (point))))
+ (beginning-of-line)
+ (if (re-search-forward
+ "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct\\|Nov\\|Dec\\)[ ]+[0-9]+"
+ eol t)
+ (progn
+ (skip-chars-forward " ")
+ (skip-chars-forward "^ " eol)
+ (skip-chars-forward " " eol)
+ (point)))))
+
+(defun dired-map-dired-file-lines (fn)
+ "perform fn with point at the end of each non-directory line:
+arguments are the short and long filename"
+ (save-excursion
+ (let (filename longfilename (buffer-read-only nil))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (save-excursion
+ (and (not (looking-at " d"))
+ (not (eolp))
+ (setq filename (dired-get-filename t t)
+ longfilename (dired-get-filename nil t))
+ (progn (end-of-line)
+ (funcall fn filename longfilename))))
+ (forward-line 1)))))
+
+(defun dired-flag-auto-save-files ()
+ "Flag for deletion files whose names suggest they are auto save files."
+ (interactive)
+ (save-excursion
+ (let ((buffer-read-only nil))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (and (not (looking-at " d"))
+ (not (eolp))
+ (if (fboundp 'auto-save-file-name-p)
+ (let ((fn (dired-get-filename t t)))
+ (if fn (auto-save-file-name-p fn)))
+ (if (dired-move-to-filename)
+ (looking-at "#")))
+ (progn (beginning-of-line)
+ (delete-char 1)
+ (insert "D")))
+ (forward-line 1)))))
+
+(defun dired-clean-directory (keep)
+ "Flag numerical backups for Deletion.
+Spares dired-kept-versions latest versions, and kept-old-versions oldest.
+Positive numeric arg overrides dired-kept-versions;
+negative numeric arg overrides kept-old-versions with minus the arg."
+ (interactive "P")
+ (setq keep (if keep (prefix-numeric-value keep) dired-kept-versions))
+ (let ((early-retention (if (< keep 0) (- keep) kept-old-versions))
+ (late-retention (if (<= keep 0) dired-kept-versions keep))
+ (file-version-assoc-list ()))
+ ;; Look at each file.
+ ;; If the file has numeric backup versions,
+ ;; put on file-version-assoc-list an element of the form
+ ;; (FILENAME . VERSION-NUMBER-LIST)
+ (dired-map-dired-file-lines 'dired-collect-file-versions)
+ ;; Sort each VERSION-NUMBER-LIST,
+ ;; and remove the versions not to be deleted.
+ (let ((fval file-version-assoc-list))
+ (while fval
+ (let* ((sorted-v-list (cons 'q (sort (cdr (car fval)) '<)))
+ (v-count (length sorted-v-list)))
+ (if (> v-count (+ early-retention late-retention))
+ (rplacd (nthcdr early-retention sorted-v-list)
+ (nthcdr (- v-count late-retention)
+ sorted-v-list)))
+ (rplacd (car fval)
+ (cdr sorted-v-list)))
+ (setq fval (cdr fval))))
+ ;; Look at each file. If it is a numeric backup file,
+ ;; find it in a VERSION-NUMBER-LIST and maybe flag it for deletion.
+ (dired-map-dired-file-lines 'dired-trample-file-versions)))
+
+(defun dired-collect-file-versions (ignore fn)
+ "If it looks like fn has versions, we make a list of the versions.
+We may want to flag some for deletion."
+ (let* ((base-versions
+ (concat (file-name-nondirectory fn) ".~"))
+ (bv-length (length base-versions))
+ (possibilities (file-name-all-completions
+ base-versions
+ (file-name-directory fn)))
+ (versions (mapcar 'backup-extract-version possibilities)))
+ (if versions
+ (setq file-version-assoc-list (cons (cons fn versions)
+ file-version-assoc-list)))))
+
+(defun dired-trample-file-versions (ignore fn)
+ (let* ((start-vn (string-match "\\.~[0-9]+~$" fn))
+ base-version-list)
+ (and start-vn
+ (setq base-version-list ; there was a base version to which
+ (assoc (substring fn 0 start-vn) ; this looks like a
+ file-version-assoc-list)) ; subversion
+ (not (memq (string-to-int (substring fn (+ 2 start-vn)))
+ base-version-list)) ; this one doesn't make the cut
+ (dired-flag-this-line-for-DEATH))))
+
+(defun dired-flag-this-line-for-DEATH ()
+ (beginning-of-line)
+ (delete-char 1)
+ (insert "D"))
+
+(defun dired-flag-backup-files ()
+ "Flag all backup files (names ending with ~) for deletion."
+ (interactive)
+ (save-excursion
+ (let ((buffer-read-only nil))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (and (not (looking-at " d"))
+ (not (eolp))
+ (if (fboundp 'backup-file-name-p)
+ (let ((fn (dired-get-filename t t)))
+ (if fn (backup-file-name-p fn)))
+ (end-of-line)
+ (forward-char -1)
+ (looking-at "~"))
+ (progn (beginning-of-line)
+ (delete-char 1)
+ (insert "D")))
+ (forward-line 1)))))
+
+(defun dired-flag-backup-and-auto-save-files ()
+ "Flag all backup and temporary files for deletion.
+Backup files have names ending in ~. Auto save file names usually
+start with #."
+ (interactive)
+ (dired-flag-backup-files)
+ (dired-flag-auto-save-files))
+
+(defun dired-rename-file (to-file)
+ "Rename this file to TO-FILE."
+ (interactive
+ (list (read-file-name (format "Rename %s to: "
+ (file-name-nondirectory (dired-get-filename)))
+ nil (dired-get-filename))))
+ (setq to-file (expand-file-name to-file))
+ (rename-file (dired-get-filename) to-file)
+ (let ((buffer-read-only nil))
+ (beginning-of-line)
+ (delete-region (point) (progn (forward-line 1) (point)))
+ (setq to-file (expand-file-name to-file))
+ (dired-add-entry (file-name-directory to-file)
+ (file-name-nondirectory to-file))))
+
+(defun dired-copy-file (to-file)
+ "Copy this file to TO-FILE."
+ (interactive "FCopy to: ")
+ (copy-file (dired-get-filename) to-file)
+ (setq to-file (expand-file-name to-file))
+ (dired-add-entry (file-name-directory to-file)
+ (file-name-nondirectory to-file)))
+
+(defun dired-add-entry (directory filename)
+ ;; If tree dired is implemented, this function will have to do
+ ;; something smarter with the directory. Currently, just check
+ ;; default directory, if same, add the new entry at point. With tree
+ ;; dired, should call 'dired-current-directory' or similar. Note
+ ;; that this adds the entry 'out of order' if files sorted by time,
+ ;; etc.
+ (if (string-equal directory default-directory)
+ (let ((buffer-read-only nil))
+ (beginning-of-line)
+ (call-process "ls" nil t nil
+ "-d" dired-listing-switches (concat directory filename))
+ (forward-line -1)
+ (insert " ")
+ (dired-move-to-filename)
+ (let* ((beg (point))
+ (end (progn (end-of-line) (point))))
+ (setq filename (buffer-substring beg end))
+ (delete-region beg end)
+ (insert (file-name-nondirectory filename)))
+ (beginning-of-line))))
+
+(defun dired-compress ()
+ "Compress this file."
+ (interactive)
+ (let* ((buffer-read-only nil)
+ (error-buffer (get-buffer-create " *Dired compress output*"))
+ (from-file (dired-get-filename))
+ (to-file (concat from-file ".Z")))
+ (if (string-match "\\.Z$" from-file)
+ (error "%s is already compressed!" from-file))
+ (message "Compressing %s..." from-file)
+ (unwind-protect
+ (progn
+ (save-excursion
+ (set-buffer error-buffer)
+ (erase-buffer))
+ ;; Must have default-directory of dired buffer in call-process
+ (call-process "compress" nil error-buffer nil "-f" from-file)
+ (if (save-excursion
+ (set-buffer error-buffer)
+ (= 0 (buffer-size)))
+ (progn
+ (message "Compressing %s... done" from-file)
+ (kill-buffer error-buffer))
+ (display-buffer error-buffer)
+ (setq error-buffer nil)
+ (error "Compress error on %s." from-file)))
+ (if error-buffer (kill-buffer error-buffer)))
+ (dired-redisplay to-file)))
+
+(defun dired-uncompress ()
+ "Uncompress this file."
+ (interactive)
+ (let* ((buffer-read-only nil)
+ (error-buffer (get-buffer-create " *Dired compress output*"))
+ (from-file (dired-get-filename))
+ (to-file (substring from-file 0 -2)))
+ (if (string-match "\\.Z$" from-file) nil
+ (error "%s is not compressed!" from-file))
+ (message "Uncompressing %s..." from-file)
+ (unwind-protect
+ (progn
+ (save-excursion
+ (set-buffer error-buffer)
+ (erase-buffer))
+ ;; Must have default-directory of dired buffer in call-process
+ (call-process "uncompress" nil error-buffer nil "-f" from-file)
+ (if (save-excursion
+ (set-buffer error-buffer)
+ (= 0 (buffer-size)))
+ (progn
+ (message "Uncompressing %s... done" from-file)
+ (kill-buffer error-buffer))
+ (display-buffer error-buffer)
+ (setq error-buffer nil)
+ (error "Uncompress error on %s." from-file)))
+ (if error-buffer (kill-buffer error-buffer)))
+ (dired-redisplay to-file)))
+
+(defun dired-byte-recompile ()
+ "Byte recompile this file."
+ (interactive)
+ (let* ((buffer-read-only nil)
+ (from-file (dired-get-filename))
+ (to-file (substring from-file 0 -3)))
+ (if (string-match "\\.el$" from-file) nil
+ (error "%s is uncompilable!" from-file))
+ (byte-compile-file from-file)))
+
+(defun dired-chmod (mode)
+ "Change mode of this file."
+ (interactive "sChange to Mode: ")
+ (let ((buffer-read-only nil)
+ (file (dired-get-filename)))
+ (call-process "/bin/chmod" nil nil nil mode file)
+ (dired-redisplay file)))
+
+(defun dired-chgrp (group)
+ "Change group of this file."
+ (interactive "sChange to Group: ")
+ (let ((buffer-read-only nil)
+ (file (dired-get-filename)))
+ (call-process "/bin/chgrp" nil nil nil group file)
+ (dired-redisplay file)))
+
+(defun dired-chown (owner)
+ "Change Owner of this file."
+ (interactive "sChange to Owner: ")
+ (let ((buffer-read-only nil)
+ (file (dired-get-filename)))
+ (call-process (if (memq system-type '(hpux usg-unix-v silicon-graphics-unix))
+ "/bin/chown" "/etc/chown")
+ nil nil nil owner file)
+ (dired-redisplay file)))
+
+(defun dired-redisplay (file) "Redisplay this line."
+ (beginning-of-line)
+ (delete-region (point) (progn (forward-line 1) (point)))
+ (if file (dired-add-entry (file-name-directory file)
+ (file-name-nondirectory file)))
+ (dired-move-to-filename))
+
+(defun dired-do-deletions ()
+ "In dired, delete the files flagged for deletion."
+ (interactive)
+ (let (delete-list answer)
+ (save-excursion
+ (goto-char 1)
+ (while (re-search-forward "^D" nil t)
+ (setq delete-list
+ (cons (cons (dired-get-filename t) (1- (point)))
+ delete-list))))
+ (if (null delete-list)
+ (message "(No deletions requested)")
+ (save-window-excursion
+ (switch-to-buffer " *Deletions*")
+ (erase-buffer)
+ (setq fill-column 70)
+ (let ((l (reverse delete-list)))
+ ;; Files should be in forward order for this loop.
+ (while l
+ (if (> (current-column) 59)
+ (insert ?\n)
+ (or (bobp)
+ (indent-to (* (/ (+ (current-column) 19) 20) 20) 1)))
+ (insert (car (car l)))
+ (setq l (cdr l))))
+ (goto-char (point-min))
+ (setq answer (yes-or-no-p "Delete these files? ")))
+ (if answer
+ (let ((l delete-list)
+ failures)
+ ;; Files better be in reverse order for this loop!
+ ;; That way as changes are made in the buffer
+ ;; they do not shift the lines still to be changed.
+ (while l
+ (goto-char (cdr (car l)))
+ (let ((buffer-read-only nil))
+ (condition-case ()
+ (let ((fn (concat default-directory (car (car l)))))
+ (if (file-directory-p fn)
+ ;; This used to call delete-file if rmdir
+ ;; did not delete the file,
+ ;; but that made it too easy for root to spaz.
+ (call-process "rmdir" nil nil nil fn)
+ (delete-file fn))
+ (delete-region (point)
+ (progn (forward-line 1) (point))))
+ (error (delete-char 1)
+ (insert " ")
+ (setq failures (cons (car (car l)) failures)))))
+ (setq l (cdr l)))
+ (if failures
+ (message "Deletions failed: %s"
+ (prin1-to-string failures))))))))
+
+(provide 'dired)
diff --git a/lisp/dired.elc b/lisp/dired.elc
new file mode 100644
index 00000000000..ac01032403f
--- /dev/null
+++ b/lisp/dired.elc
Binary files differ
diff --git a/lisp/disass.el b/lisp/disass.el
new file mode 100644
index 00000000000..77e5a7fc17d
--- /dev/null
+++ b/lisp/disass.el
@@ -0,0 +1,446 @@
+;;; Disassembler for compiled Emacs Lisp code
+;; Copyright (C) 1986 Free Software Foundation
+;;; By Doug Cutting (doug@csli.stanford.edu)
+
+;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+(require 'byte-compile "bytecomp")
+
+(defvar disassemble-column-1-indent 4 "*")
+
+(defvar disassemble-column-2-indent 9 "*")
+
+(defvar disassemble-recursive-indent 3 "*")
+
+;(defun d (x)
+; (interactive "xDiss ")
+; (with-output-to-temp-buffer "*Disassemble*"
+; (disassemble-internal (list 'lambda '() x ''return-value)
+; standard-output 0 t)))
+
+(defun disassemble (object &optional stream indent interactive-p)
+ "Print disassembled code for OBJECT on (optional) STREAM.
+OBJECT can be a function name, lambda expression or any function object
+returned by SYMBOL-FUNCTION. If OBJECT is not already compiled, we will
+compile it (but not redefine it)."
+ (interactive (list (intern (completing-read "Disassemble function: "
+ obarray 'fboundp t))
+ nil 0 t))
+ (or indent (setq indent 0)) ;Default indent to zero
+ (if interactive-p
+ (with-output-to-temp-buffer "*Disassemble*"
+ (disassemble-internal object standard-output indent t))
+ (disassemble-internal object (or stream standard-output) indent nil))
+ nil)
+
+(defun disassemble-internal (obj stream indent interactive-p)
+ (let ((macro 'nil)
+ (name 'nil)
+ (doc 'nil)
+ args)
+ (while (symbolp obj)
+ (setq name obj
+ obj (symbol-function obj)))
+ (if (subrp obj)
+ (error "Can't disassemble #<subr %s>" name))
+ (if (eq (car obj) 'macro) ;handle macros
+ (setq macro t
+ obj (cdr obj)))
+ (if (not (eq (car obj) 'lambda))
+ (error "not a function"))
+ (if (assq 'byte-code obj)
+ nil
+ (if interactive-p (message (if name
+ "Compiling %s's definition..."
+ "Compiling definition...")
+ name))
+ (setq obj (byte-compile-lambda obj))
+ (if interactive-p (message "Done compiling. Disassembling...")))
+ (setq obj (cdr obj)) ;throw lambda away
+ (setq args (car obj)) ;save arg list
+ (setq obj (cdr obj))
+ (write-spaces indent stream)
+ (princ (format "byte code%s%s%s:\n"
+ (if (or macro name) " for" "")
+ (if macro " macro" "")
+ (if name (format " %s" name) ""))
+ stream)
+ (let ((doc (and (stringp (car obj)) (car obj))))
+ (if doc
+ (progn (setq obj (cdr obj))
+ (write-spaces indent stream)
+ (princ " doc: " stream)
+ (princ doc stream)
+ (terpri stream))))
+ (write-spaces indent stream)
+ (princ " args: " stream)
+ (prin1 args stream)
+ (terpri stream)
+ (let ((interactive (car (cdr (assq 'interactive obj)))))
+ (if interactive
+ (progn (write-spaces indent stream)
+ (princ " interactive: " stream)
+ (if (eq (car-safe interactive) 'byte-code)
+ (disassemble-1 interactive stream
+ (+ indent disassemble-recursive-indent))
+ (prin1 interactive stream)
+ (terpri stream)))))
+ (setq obj (assq 'byte-code obj)) ;obj is now call to byte-code
+ (disassemble-1 obj stream indent))
+ (if interactive-p
+ (message "")))
+
+(defun disassemble-1 (obj &optional stream indent)
+ "Prints the byte-code call OBJ to (optional) STREAM.
+OBJ should be a call to BYTE-CODE generated by the byte compiler."
+ (or indent (setq indent 0)) ;default indent to 0
+ (or stream (setq stream standard-output))
+ (let ((bytes (car (cdr obj))) ;the byte code
+ (ptr -1) ;where we are in it
+ (constants (car (cdr (cdr obj)))) ;constant vector
+ ;(next-indent indent)
+ offset tmp length)
+ (setq length (length bytes))
+ (terpri stream)
+ (while (< (setq ptr (1+ ptr)) length)
+ ;(setq indent next-indent)
+ (write-spaces indent stream) ;indent to recursive indent
+ (princ (setq tmp (prin1-to-string ptr)) stream) ;print line #
+ (write-char ?\ stream)
+ (write-spaces (- disassemble-column-1-indent (length tmp) 1)
+ stream)
+ (setq op (aref bytes ptr)) ;fetch opcode
+ ;; Note: as offsets are either encoded in opcodes or stored as
+ ;; bytes in the code, this function (disassemble-offset)
+ ;; can set OP and/or PTR.
+ (setq offset (disassemble-offset));fetch offset
+ (setq tmp (aref byte-code-vector op))
+ (if (consp tmp)
+ (setq ;next-indent (if (numberp (cdr tmp))
+ ; (+ indent (cdr tmp))
+ ; (+ indent (funcall (cdr tmp) offset)))
+ tmp (car tmp)))
+ (setq tmp (symbol-name tmp))
+ (princ tmp stream) ;print op-name for opcode
+ (if (null offset)
+ nil
+ (write-char ?\ stream)
+ (write-spaces (- disassemble-column-2-indent (length tmp) 1)
+ stream) ;indent to col 2
+ (princ ;print offset
+ (cond ((or (eq op byte-varref)
+ (eq op byte-varset)
+ (eq op byte-varbind))
+ ;; it's a varname (atom)
+ (aref constants offset)) ;fetch it from constants
+ ((or (eq op byte-goto)
+ (eq op byte-goto-if-nil)
+ (eq op byte-goto-if-not-nil)
+ (eq op byte-goto-if-nil-else-pop)
+ (eq op byte-goto-if-not-nil-else-pop)
+ (eq op byte-call)
+ (eq op byte-unbind))
+ ;; it's a number
+ offset) ;return it
+ ((or (eq op byte-constant)
+ (eq op byte-constant2))
+ ;; it's a constant
+ (setq tmp (aref constants offset))
+ ;; but is constant byte code?
+ (cond ((and (eq (car-safe tmp) 'lambda)
+ (assq 'byte-code tmp))
+ (princ "<compiled lambda>" stream)
+ (terpri stream)
+ (disassemble ;recurse on compiled lambda
+ tmp
+ stream
+ (+ indent disassemble-recursive-indent))
+ "")
+ ((eq (car-safe tmp) 'byte-code)
+ (princ "<byte code>" stream)
+ (terpri stream)
+ (disassemble-1 ;recurse on byte-code object
+ tmp
+ stream
+ (+ indent disassemble-recursive-indent))
+ "")
+ ((eq (car-safe (car-safe tmp)) 'byte-code)
+ (princ "(<byte code>...)" stream)
+ (terpri stream)
+ (mapcar ;recurse on list of byte-code objects
+ (function (lambda (obj)
+ (disassemble-1
+ obj
+ stream
+ (+ indent disassemble-recursive-indent))))
+ tmp)
+ "")
+ ((and (eq tmp 'byte-code)
+ (eq (aref bytes (+ ptr 4)) (+ byte-call 3)))
+ ;; this won't catch cases where args are pushed w/
+ ;; constant2.
+ (setq ptr (+ ptr 4))
+ "<compiled call to byte-code. compiled code compiled?>")
+ (t
+ ;; really just a constant
+ (let ((print-escape-newlines t))
+ (prin1-to-string tmp)))))
+ (t "<error in disassembler>"))
+ stream))
+ (terpri stream)))
+ nil)
+
+
+(defun disassemble-offset ()
+ "Don't call this!"
+ ;; fetch and return the offset for the current opcode.
+ ;; return NIL if this opcode has no offset
+ ;; OP, PTR and BYTES are used and set dynamically
+ (let (tem)
+ (cond ((< op byte-nth)
+ (setq tem (logand op 7))
+ (setq op (logand op 248))
+ (cond ((eq tem 6)
+ (setq ptr (1+ ptr)) ;offset in next byte
+ (aref bytes ptr))
+ ((eq tem 7)
+ (setq ptr (1+ ptr)) ;offset in next 2 bytes
+ (+ (aref bytes ptr)
+ (progn (setq ptr (1+ ptr))
+ (lsh (aref bytes ptr) 8))))
+ (t tem))) ;offset was in opcode
+ ((>= op byte-constant)
+ (setq tem (- op byte-constant)) ;offset in opcode
+ (setq op byte-constant)
+ tem)
+ ((or (= op byte-constant2)
+ (and (>= op byte-goto)
+ (<= op byte-goto-if-not-nil-else-pop)))
+ (setq ptr (1+ ptr)) ;offset in next 2 bytes
+ (+ (aref bytes ptr)
+ (progn (setq ptr (1+ ptr))
+ (lsh (aref bytes ptr) 8))))
+ (t nil)))) ;no offset
+
+
+(defun write-spaces (n &optional stream)
+ "Print N spaces to (optional) STREAM."
+ (or stream (setq stream standard-output))
+ (if (< n 0) (setq n 0))
+ (if (eq stream (current-buffer))
+ (insert-char ?\ n)
+ (while (> n 0)
+ (write-char ?\ stream)
+ (setq n (1- n)))))
+
+(defconst byte-code-vector
+ '[<not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ (varref . 1)
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ (varset . -1)
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ (varbind . 0);Pops a value, "pushes" a binding
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ (call . -); #'-, not -1!
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ (unbind . -);"pops" bindings
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ (nth . -1)
+ symbolp
+ consp
+ stringp
+ listp
+ (eq . -1)
+ (memq . -1)
+ not
+ car
+ cdr
+ (cons . -1)
+ list1
+ (list2 . -1)
+ (list3 . -2)
+ (list4 . -3)
+ length
+ (aref . -1)
+ (aset . -2)
+ symbol-value
+ symbol-function
+ (set . -1)
+ (fset . -1)
+ (get . -1)
+ (substring . -2)
+ (concat2 . -1)
+ (concat3 . -2)
+ (concat4 . -3)
+ sub1
+ add1
+ (eqlsign . -1) ;=
+ (gtr . -1) ;>
+ (lss . -1) ;<
+ (leq . -1) ;<=
+ (geq . -1) ;>=
+ (diff . -1) ;-
+ negate ;unary -
+ (plus . -1) ;+
+ (max . -1)
+ (min . -1)
+ <not-an-opcode>
+ (point . 1)
+ (mark\(obsolete\) . 1)
+ goto-char
+ insert
+ (point-max . 1)
+ (point-min . 1)
+ char-after
+ (following-char . 1)
+ (preceding-char . 1)
+ (current-column . 1)
+ (indent-to . 1)
+ (scan-buffer\(obsolete\) . -2)
+ (eolp . 1)
+ (eobp . 1)
+ (bolp . 1)
+ (bobp . 1)
+ (current-buffer . 1)
+ set-buffer
+ (read-char . 1)
+ set-mark\(obsolete\)
+ interactive-p
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ (constant2 . 1)
+ goto;>>>
+ goto-if-nil;>>
+ goto-if-not-nil;>>
+ (goto-if-nil-else-pop . -1)
+ (goto-if-not-nil-else-pop . -1)
+ return
+ (discard . -1)
+ (dup . 1)
+ (save-excursion . 1);Pushes a binding
+ (save-window-excursion . 1);Pushes a binding
+ (save-restriction . 1);Pushes a binding
+ (catch . -1);Takes one argument, returns a value
+ (unwind-protect . 1);Takes one argument, pushes a binding, returns a value
+ (condition-case . -2);Takes three arguments, returns a value
+ (temp-output-buffer-setup . -1)
+ temp-output-buffer-show
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ <not-an-opcode>
+ (constant . 1)
+ ])
+
diff --git a/lisp/disass.elc b/lisp/disass.elc
new file mode 100644
index 00000000000..531c744c832
--- /dev/null
+++ b/lisp/disass.elc
Binary files differ
diff --git a/lisp/disp-table.el b/lisp/disp-table.el
deleted file mode 100644
index c0fe4dfe8af..00000000000
--- a/lisp/disp-table.el
+++ /dev/null
@@ -1,115 +0,0 @@
-;; Functions for dealing with char tables.
-;; Copyright (C) 1987 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-
-;; Written by Howard Gayle. See case-table.el for details.
-
-(require 'case-table)
-
-(defun rope-to-vector (rope)
- (let* ((len (/ (length rope) 2))
- (vector (make-vector len nil))
- (i 0))
- (while (< i len)
- (aset vector i (rope-elt rope i))
- (setq i (1+ i)))))
-
-(defun describe-display-table (DT)
- "Describe the display-table DT in a help buffer."
- (with-output-to-temp-buffer "*Help*"
- (princ "\nTruncation glyf: ")
- (prin1 (aref dt 256))
- (princ "\nWrap glyf: ")
- (prin1 (aref dt 257))
- (princ "\nEscape glyf: ")
- (prin1 (aref dt 258))
- (princ "\nCtrl glyf: ")
- (prin1 (aref dt 259))
- (princ "\nSelective display rope: ")
- (prin1 (rope-to-vector (aref dt 260)))
- (princ "\nCharacter display ropes:\n")
- (let ((vector (make-vector 256 nil))
- (i 0))
- (while (< i 256)
- (aset vector i
- (if (stringp (aref dt i))
- (rope-to-vector (aref dt i))
- (aref dt i)))
- (setq i (1+ i)))
- (describe-vector vector))
- (print-help-return-message)))
-
-(defun describe-current-display-table ()
- "Describe the display-table in use in the selected window and buffer."
- (interactive)
- (describe-display-table
- (or (window-display-table (selected-window))
- buffer-display-table
- standard-display-table)))
-
-(defun make-display-table ()
- (make-vector 261 nil))
-
-(defun standard-display-8bit (l h)
- "Display characters in the range [L, H] literally."
- (while (<= l h)
- (if (and (>= l ?\ ) (< l 127))
- (if standard-display-table (aset standard-display-table l nil))
- (or standard-display-table
- (setq standard-display-table (make-vector 261 nil)))
- (aset standard-display-table l l))
- (setq l (1+ l))))
-
-(defun standard-display-ascii (c s)
- "Display character C using string S."
- (or standard-display-table
- (setq standard-display-table (make-vector 261 nil)))
- (aset standard-display-table c (apply 'make-rope (append s nil))))
-
-(defun standard-display-g1 (c sc)
- "Display character C as character SC in the g1 character set."
- (or standard-display-table
- (setq standard-display-table (make-vector 261 nil)))
- (aset standard-display-table c
- (make-rope (create-glyf (concat "\016" (char-to-string sc) "\017")))))
-
-(defun standard-display-graphic (c gc)
- "Display character C as character GC in graphics character set."
- (or standard-display-table
- (setq standard-display-table (make-vector 261 nil)))
- (aset standard-display-table c
- (make-rope (create-glyf (concat "\e(0" (char-to-string gc) "\e(B")))))
-
-(defun standard-display-underline (c uc)
- "Display character C as character UC plus underlining."
- (or standard-display-table
- (setq standard-display-table (make-vector 261 nil)))
- (aset standard-display-table c
- (make-rope (create-glyf (concat "\e[4m" (char-to-string uc) "\e[m")))))
-
-(defun create-glyf (string)
- (let ((i 256))
- (while (and (< i 65536) (aref glyf-table i)
- (not (string= (aref glyf-table i) string)))
- (setq i (1+ i)))
- (if (= i 65536)
- (error "No free glyf codes remain"))
- (aset glyf-table i string)))
-
-(provide 'disp-table)
diff --git a/lisp/play/dissociate.el b/lisp/dissociate.el
index b6ac2fa4ea8..6b5c373160b 100644
--- a/lisp/play/dissociate.el
+++ b/lisp/dissociate.el
@@ -54,12 +54,12 @@ Default is 2."
(setq start (point))
(if (eq move-function 'forward-char)
(progn
- (setq end (+ start (+ move-amount (random 16))))
+ (setq end (+ start (+ move-amount (logand 15 (random)))))
(if (> end (point-max))
- (setq end (+ 1 move-amount (random 16))))
+ (setq end (+ 1 move-amount (logand 15 (random)))))
(goto-char end))
(funcall move-function
- (+ move-amount (random 16))))
+ (+ move-amount (logand 15 (random)))))
(setq end (point)))
(let ((opoint (point)))
(insert-buffer-substring inbuf start end)
diff --git a/lisp/dissociate.elc b/lisp/dissociate.elc
new file mode 100644
index 00000000000..868787c4937
--- /dev/null
+++ b/lisp/dissociate.elc
Binary files differ
diff --git a/lisp/doctex.el b/lisp/doctex.el
new file mode 100644
index 00000000000..39a2e821ea1
--- /dev/null
+++ b/lisp/doctex.el
@@ -0,0 +1,189 @@
+;;; Grind GNU Emacs DOC file into LaTeX input
+;;; Copyright (C) 1987 Kyle E. Jones, Tor Lillqvist
+
+;;; This file may be redistributed provided the above copyright
+;;; notice appears on all copies and that the further free redistribution
+;;; of this file is not in any way restricted by those who
+;;; redistribute it.
+
+;;; Based on Kyle E. Jones's grind-DOC package.
+
+;;; This software is distributed 'as is', without warranties of any kind.
+
+;;; This file is not part of GNU Emacs.
+
+;;; The document that is the output from the (LaTeXify-DOC) function is
+;;; part of GNU Emacs.
+
+
+(defvar LaTeXify-DOC-style "report"
+ "*Should be bound to a string indicating what LaTeX document style
+should be used to format the DOC file. If this variable is set to nil
+the report style will be used.")
+
+(defvar LaTeXify-DOC-style-options ""
+ "*A string containing a list of document style options for LaTeX")
+
+(defun LaTeXify-DOC () (interactive)
+ "Reads the etc/DOC-xx.xx.x file into a buffer and converts it to a form
+suitable as LaTeX input."
+ ;
+ ; Make sure we can deal with the macro package and the point size.
+ ;
+ (cond
+ ((not (stringp LaTeXify-DOC-style))
+ (error "LaTeXify-DOC-style must be a string")))
+ ;
+ ; Select the DOC file.
+ ;
+ (find-file (expand-file-name
+ (if (fboundp 'dump-emacs)
+ (concat "DOC-" emacs-version)
+ "DOC")
+ exec-directory))
+ (setq buffer-read-only nil)
+ (auto-save-mode 0)
+ (set-visited-file-name (concat (buffer-file-name) ".tex"))
+ (delete-other-windows)
+ ;
+ ; Save-excursion just in case the DOC file was already selected.
+ ;
+ (save-excursion
+ (let (case-fold-search mode-line-format varstart-point bufstring name odot)
+ ;
+ ; The first thing we must do is convert the \[COMMAND] sequences
+ ; into the keys that the COMMANDs are bound to.
+ ;
+ (setq mode-line-format
+ " Grinding the DOC file... be patient.")
+ (sit-for 0)
+ (replace-regexp "\\\\{\\(\\s_\\|\\sw\\)*}"
+ "]]bgroup]]obeylines\\&]]egroup")
+ (setq bufstring (substitute-command-keys (buffer-string)))
+ (erase-buffer)
+ (insert bufstring)
+ ;
+ ; Here we make each docstring begin and end with C-_ for
+ ; easier manipulation. This is undone later.
+ ;
+ (goto-char (1+ (point-min)))
+ (replace-string "\C-_" "\C-_\C-_" nil)
+ (goto-char (point-max))
+ (insert "\C-_")
+ ;
+ ; Sort the docstrings. This implicitly separates function
+ ; documentation from the variable documentation.
+ ;
+ (sort-regexp-fields nil "\C-_\\([FV].*\\)[^\C-_]*\C-_" "\\1"
+ (point-min) (point-max))
+ ;
+ ; Handle TeX special characters
+ ;
+ (goto-char (point-min))
+ (mapcar
+ '(lambda (x) (save-excursion (eval x)))
+ '((replace-string "#" "]]#")
+ (replace-string "$" "]]$")
+ (replace-string "%" "]]%")
+ (replace-string "&" "]]&")
+ (replace-string "~" "]]verb+~+")
+ (replace-string "_" "]]verb+_+")
+ (replace-string "^" "]]verb+^+")
+ (replace-string "\\" "]]verb+]]+")
+ (replace-string "{" "]]{")
+ (replace-string "}" "]]}")
+ (replace-string "<" "]]verb+<+")
+ (replace-string ">" "]]verb+>+")
+ (replace-string "]]" "\\")))
+ ;
+ ; Now add the indentation commands and put ( ...) around the functions
+ ;
+ (save-restriction
+ (goto-char (point-min))
+ (search-forward "\C-_V" (point-max) nil 1)
+ (backward-char 2)
+ (narrow-to-region (point-min) (dot))
+ (goto-char (point-min))
+ (insert "\\section*{Functions}\n"
+ "\\begin{description}\n")
+ (while (search-forward "\C-_F" (point-max) t 1)
+ (delete-char -2)
+ (insert "\n\\item[\\sf(")
+ (end-of-line 1)
+ (insert " ...)]")
+ (search-forward "\C-_" (point-max) nil 1)
+ (delete-char -1))
+ (insert "\\end{description}\n"))
+ (insert "\\section*{Variables}
+Variables whose documentation begins with an
+asterisk `*' are user definable options. These variables are
+used to customize Emacs. Other variables are generally of
+interest only to Emacs Lisp programmers.
+\\begin{description}\n")
+ (while (search-forward "\C-_V" (point-max) t 1)
+ (delete-char -2)
+ (insert "\n\\item[\\sf ")
+ (end-of-line 1)
+ (insert "]")
+ (search-forward "\C-_" (point-max) nil 1)
+ (delete-char -1))
+ (insert "\\end{description}\n"
+ "\\end{document}\n")
+ ;
+ ; Try to make those parameters that are in all-caps look better
+ ;
+ (goto-char (point-min))
+ (mapcar
+ '(lambda (x) (save-excursion (eval x)))
+ '((replace-regexp "[A-Z][A-Z]+" "\n{\\\\lowercase{\\\\sf \\&}}" nil)
+ (replace-string "\\lowercase{\\sf TAB}" "{\\tt TAB}")
+ (replace-string "\\lowercase{\\sf LFD}" "{\\tt LFD}")
+ (replace-string "\\lowercase{\\sf RET}" "{\\tt RET}")
+ (replace-string "\\lowercase{\\sf ESC}" "{\\tt ESC}")
+ (replace-string "\\lowercase{\\sf SPC}" "{\\tt SPC}")
+ (replace-string "\\lowercase{\\sf DEL}" "{\\tt DEL}")))
+ ;
+ ; Handle document style and front matter
+ ;
+ (goto-char (point-min))
+ (insert "\\documentstyle["
+ LaTeXify-DOC-style-options
+ "]{" LaTeXify-DOC-style "}\n"
+ "\\begin{document}\n"
+ "\\title{GNU Emacs Lisp Reference \\\\\n"
+ "Version " emacs-version " \\\\\n"
+ "\\large (gouged with a blunt instrument from the DOC file)}\n"
+ "\\author{Richard M. Stallman}\n"
+ "\\date{" (substring emacs-build-time 4 8)
+ (substring emacs-build-time 20) "}\n"
+ "\\maketitle\n")
+ ;
+ ; Insert the GNU Emacs copyright notice.
+ ;
+ (insert
+ "\\begin{centering}\n"
+ "Copyright \\copyright" (substring emacs-build-time 20)
+ " Free Software Foundation, Inc. \\\\\n"
+ "\\end{centering}
+\\vspace{\\baselineskip}
+\\noindent
+This document 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+\\newpage\\sloppy\n")
+ ;
+ ; That's it
+ ;
+ (message "Grinding completed. Behold!"))))
diff --git a/lisp/doctor.el b/lisp/doctor.el
new file mode 100644
index 00000000000..3c85b7227de
--- /dev/null
+++ b/lisp/doctor.el
@@ -0,0 +1,1614 @@
+;; Psychological help for frustrated users.
+;; Copyright (C) 1985, 1987 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+(defun doctor-cadr (x) (car (cdr x)))
+(defun doctor-caddr (x) (car (cdr (cdr x))))
+(defun doctor-cddr (x) (cdr (cdr x)))
+
+(defun doctor-member (x y)
+ "Like memq, but uses equal for comparison"
+ (while (and y (not (equal x (car y))))
+ (setq y (cdr y)))
+ y)
+
+(defun random-range (top)
+ "Return a random nonnegative integer less than TOP."
+ (let ((tem (% (random) top)))
+ (if (< tem 0) (- tem) tem)))
+
+(defun // (x) x)
+
+(defmacro $ (what)
+ "quoted arg form of doctor-$"
+ (list 'doctor-$ (list 'quote what)))
+
+(defun doctor-$ (what)
+ "Return the car of a list, rotating the list each time"
+ (let* ((vv (symbol-value what))
+ (first (car vv))
+ (ww (append (cdr vv) (list first))))
+ (set what ww)
+ first))
+
+(defvar doctor-mode-map nil)
+(if doctor-mode-map
+ nil
+ (setq doctor-mode-map (make-sparse-keymap))
+ (define-key doctor-mode-map "\n" 'doctor-read-print)
+ (define-key doctor-mode-map "\r" 'doctor-ret-or-read))
+
+(defun doctor-mode ()
+ "Major mode for running the Doctor (Eliza) program.
+Like Text mode with Auto Fill mode
+except that RET when point is after a newline, or LFD at any time,
+reads the sentence before point, and prints the Doctor's answer."
+ (interactive)
+ (text-mode)
+ (make-doctor-variables)
+ (use-local-map doctor-mode-map)
+ (setq major-mode 'doctor-mode)
+ (setq mode-name "Doctor")
+ (turn-on-auto-fill)
+ (doctor-type '(i am the psychotherapist \.
+ ($ please) ($ describe) your ($ problems) \.
+ each time you are finished talking, type \R\E\T twice \.))
+ (insert "\n"))
+
+(defun make-doctor-variables ()
+ (make-local-variable 'monosyllables)
+ (setq monosyllables
+ "
+ Your attitude at the end of the session was wholly unacceptable.
+ Please try to come back next time with a willingness to speak more
+ freely. If you continue to refuse to talk openly, there is little
+ I can do to help!
+")
+ (make-local-variable 'typos)
+ (setq typos
+ (mapcar (function (lambda (x)
+ (put (car x) 'doctor-correction (doctor-cadr x))
+ (put (doctor-cadr x) 'doctor-expansion (doctor-caddr x))
+ (car x)))
+ '((theyll they\'ll (they will))
+ (theyre they\'re (they are))
+ (hes he\'s (he is))
+ (he7s he\'s (he is))
+ (im i\'m (you are))
+ (i7m i\'m (you are))
+ (isa is\ a (is a))
+ (thier their (their))
+ (dont don\'t (do not))
+ (don7t don\'t (do not))
+ (you7re you\'re (i am))
+ (you7ve you\'ve (i have))
+ (you7ll you\'ll (i will)))))
+ (make-local-variable 'found)
+ (setq found nil)
+ (make-local-variable 'owner)
+ (setq owner nil)
+ (make-local-variable 'history)
+ (setq history nil)
+ (make-local-variable '*debug*)
+ (setq *debug* nil)
+ (make-local-variable 'inter)
+ (setq inter
+ '((well\,)
+ (hmmm \.\.\.\ so\,)
+ (so)
+ (\.\.\.and)
+ (then)))
+ (make-local-variable 'continue)
+ (setq continue
+ '((continue)
+ (proceed)
+ (go on)
+ (keep going) ))
+ (make-local-variable 'relation)
+ (setq relation
+ '((your relationship with)
+ (something you remember about)
+ (your feelings toward)
+ (some experiences you have had with)
+ (how you feel about)))
+ (make-local-variable 'fears)
+ (setq fears '( (($ whysay) you are ($ afraidof) (// feared) \?)
+ (you seem terrified by (// feared) \.)
+ (when did you first feel ($ afraidof) (// feared) \?) ))
+ (make-local-variable 'sure)
+ (setq sure '((sure)(positive)(certain)(absolutely sure)))
+ (make-local-variable 'afraidof)
+ (setq afraidof '( (afraid of) (frightened by) (scared of) ))
+ (make-local-variable 'areyou)
+ (setq areyou '( (are you)(have you been)(have you been) ))
+ (make-local-variable 'isrelated)
+ (setq isrelated '( (has something to do with)(is related to)
+ (could be the reason for) (is caused by)(is because of)))
+ (make-local-variable 'arerelated)
+ (setq arerelated '((have something to do with)(are related to)
+ (could have caused)(could be the reason for) (are caused by)
+ (are because of)))
+ (make-local-variable 'moods)
+ (setq moods '( (($ areyou)(// found) often \?)
+ (what causes you to be (// found) \?)
+ (($ whysay) you are (// found) \?) ))
+ (make-local-variable 'maybe)
+ (setq maybe
+ '((maybe)
+ (perhaps)
+ (possibly)))
+ (make-local-variable 'whatwhen)
+ (setq whatwhen
+ '((what happened when)
+ (what would happen if)))
+ (make-local-variable 'hello)
+ (setq hello
+ '((how do you do \?) (hello \.) (howdy!) (hello \.) (hi \.) (hi there \.)))
+ (make-local-variable 'drnk)
+ (setq drnk
+ '((do you drink a lot of (// found) \?)
+ (do you get drunk often \?)
+ (($ describe) your drinking habits \.) ))
+ (make-local-variable 'drugs)
+ (setq drugs '( (do you use (// found) often \?)(($ areyou)
+ addicted to (// found) \?)(do you realize that drugs can
+ be very harmful \?)(($ maybe) you should try to quit using (// found)
+ \.)))
+ (make-local-variable 'whywant)
+ (setq whywant '( (($ whysay) (// subj) might ($ want) (// obj) \?)
+ (how does it feel to want \?)
+ (why should (// subj) get (// obj) \?)
+ (when did (// subj) first ($ want) (// obj) \?)
+ (($ areyou) obsessed with (// obj) \?)
+ (why should i give (// obj) to (// subj) \?)
+ (have you ever gotten (// obj) \?) ))
+ (make-local-variable 'canyou)
+ (setq canyou '((of course i can \.)
+ (why should i \?)
+ (what makes you think i would even want to \?)
+ (i am the doctor\, i can do anything i damn please \.)
+ (not really\, it\'s not up to me \.)
+ (depends\, how important is it \?)
+ (i could\, but i don\'t think it would be a wise thing to do \.)
+ (can you \?)
+ (maybe i can\, maybe i can\'t \.\.\.)
+ (i don\'t think i should do that \.)))
+ (make-local-variable 'want)
+ (setq want '( (want) (desire) (wish) (want) (hope) ))
+ (make-local-variable 'shortlst)
+ (setq shortlst
+ '((can you elaborate on that \?)
+ (($ please) continue \.)
+ (go on\, don\'t be afraid \.)
+ (i need a little more detail please \.)
+ (you\'re being a bit brief\, ($ please) go into detail \.)
+ (can you be more explicit \?)
+ (and \?)
+ (($ please) go into more detail \?)
+ (you aren\'t being very talkative today\!)
+ (is that all there is to it \?)
+ (why must you respond so briefly \?)))
+
+ (make-local-variable 'famlst)
+ (setq famlst
+ '((tell me ($ something) about (// owner) family \.)
+ (you seem to dwell on (// owner) family \.)
+ (($ areyou) hung up on (// owner) family \?)))
+ (make-local-variable 'huhlst)
+ (setq huhlst
+ '((($ whysay)(// sent) \?)
+ (is it because of ($ things) that you say (// sent) \?) ))
+ (make-local-variable 'longhuhlst)
+ (setq longhuhlst
+ '((($ whysay) that \?)
+ (i don\'t understand \.)
+ (($ thlst))
+ (($ areyou) ($ afraidof) that \?)))
+ (make-local-variable 'feelings)
+ (setq feelings-about
+ '((feelings about)
+ (aprehensions toward)
+ (thoughts on)
+ (emotions toward)))
+ (make-local-variable 'random)
+ (setq random-adjective
+ '((vivid)
+ (emotionally stimulating)
+ (exciting)
+ (boring)
+ (interesting)
+ (recent)
+ (random) ;How can we omit this?
+ (unusual)
+ (shocking)
+ (embarrassing)))
+ (make-local-variable 'whysay)
+ (setq whysay
+ '((why do you say)
+ (what makes you believe)
+ (are you sure that)
+ (do you really think)
+ (what makes you think) ))
+ (make-local-variable 'isee)
+ (setq isee
+ '((i see \.\.\.)
+ (yes\,)
+ (i understand \.)
+ (oh \.) ))
+ (make-local-variable 'please)
+ (setq please
+ '((please\,)
+ (i would appreciate it if you would)
+ (perhaps you could)
+ (please\,)
+ (would you please)
+ (why don\'t you)
+ (could you)))
+ (make-local-variable 'bye)
+ (setq bye
+ '((my secretary will send you a bill \.)
+ (bye bye \.)
+ (see ya \.)
+ (ok\, talk to you some other time \.)
+ (talk to you later \.)
+ (ok\, have fun \.)
+ (ciao \.)))
+ (make-local-variable 'something)
+ (setq something
+ '((something)
+ (more)
+ (how you feel)))
+ (make-local-variable 'things)
+ (setq things
+ '(;(your interests in computers) ;; let's make this less computer oriented
+ ;(the machines you use)
+ (your plans)
+ ;(your use of computers)
+ (your life)
+ ;(other machines you use)
+ (the people you hang around with)
+ ;(computers you like)
+ (problems at school)
+ (any hobbies you have)
+ ;(other computers you use)
+ (your sex life)
+ (hangups you have)
+ (your inhibitions)
+ (some problems in your childhood)
+ ;(knowledge of computers)
+ (some problems at home)))
+ (make-local-variable 'describe)
+ (setq describe
+ '((describe)
+ (tell me about)
+ (talk about)
+ (discuss)
+ (tell me more about)
+ (elaborate on)))
+ (make-local-variable 'ibelieve)
+ (setq ibelieve
+ '((i believe) (i think) (i have a feeling) (it seems to me that)
+ (it looks like)))
+ (make-local-variable 'problems)
+ (setq problems '( (problems)
+ (inhibitions)
+ (hangups)
+ (difficulties)
+ (anxieties)
+ (frustrations) ))
+ (make-local-variable 'bother)
+ (setq bother
+ '((does it bother you that)
+ (are you annoyed that)
+ (did you ever regret)
+ (are you sorry)
+ (are you satisfied with the fact that)))
+ (make-local-variable 'machlst)
+ (setq machlst
+ '((you have your mind on (// found) \, it seems \.)
+ (you think too much about (// found) \.)
+ (you should try taking your mind off of (// found)\.)
+ (are you a computer hacker \?)))
+ (make-local-variable 'qlist)
+ (setq qlist
+ '((what do you think \?)
+ (i\'ll ask the questions\, if you don\'t mind!)
+ (i could ask the same thing myself \.)
+ (($ please) allow me to do the questioning \.)
+ (i have asked myself that question many times \.)
+ (($ please) try to answer that question yourself \.)))
+ (make-local-variable 'elist)
+ (setq elist
+ '((($ please) try to calm yourself \.)
+ (you seem very excited \. relax \. ($ please) ($ describe) ($ things)
+ \.)
+ (you\'re being very emotional \. calm down \.)))
+ (make-local-variable 'foullst)
+ (setq foullst
+ '((($ please) watch your tongue!)
+ (($ please) avoid such unwholesome thoughts \.)
+ (($ please) get your mind out of the gutter \.)
+ (such lewdness is not appreciated \.)))
+ (make-local-variable 'deathlst)
+ (setq deathlst
+ '((this is not a healthy way of thinking \.)
+ (($ bother) you\, too\, may die someday \?)
+ (i am worried by your obssession with this topic!)
+ (did you watch a lot of crime and violence on television as a child \?))
+ )
+ (make-local-variable 'sexlst)
+ (setq sexlst
+ '((($ areyou) ($ afraidof) sex \?)
+ (($ describe)($ something) about your sexual history \.)
+ (($ please)($ describe) your sex life \.\.\.)
+ (($ describe) your ($ feelings-about) your sexual partner \.)
+ (($ describe) your most ($ random-adjective) sexual experience \.)
+ (($ areyou) satisfied with (// lover) \.\.\. \?)))
+ (make-local-variable 'neglst)
+ (setq neglst
+ '((why not \?)
+ (($ bother) i ask that \?)
+ (why not \?)
+ (why not \?)
+ (how come \?)
+ (($ bother) i ask that \?)))
+ (make-local-variable 'beclst)
+ (setq beclst '(
+ (is it because (// sent) that you came to me \?)
+ (($ bother)(// sent) \?)
+ (when did you first know that (// sent) \?)
+ (is the fact that (// sent) the real reason \?)
+ (does the fact that (// sent) explain anything else \?)
+ (($ areyou)($ sure)(// sent) \? ) ))
+ (make-local-variable 'shortbeclst)
+ (setq shortbeclst '(
+ (($ bother) i ask you that \?)
+ (that\'s not much of an answer!)
+ (($ inter) why won\'t you talk about it \?)
+ (speak up!)
+ (($ areyou) ($ afraidof) talking about it \?)
+ (don\'t be ($ afraidof) elaborating \.)
+ (($ please) go into more detail \.)))
+ (make-local-variable 'thlst)
+ (setq thlst '(
+ (($ maybe)($ things)($ arerelated) this \.)
+ (is it because of ($ things) that you are going through all this \?)
+ (how do you reconcile ($ things) \? )
+ (($ maybe) this ($ isrelated)($ things) \?) ))
+ (make-local-variable 'remlst)
+ (setq remlst '( (earlier you said ($ history) \?)
+ (you mentioned that ($ history) \?)
+ (($ whysay)($ history) \? ) ))
+ (make-local-variable 'toklst)
+ (setq toklst
+ '((is this how you relax \?)
+ (how long have you been smoking grass \?)
+ (($ areyou) ($ afraidof) of being drawn to using harder stuff \?)))
+ (make-local-variable 'states)
+ (setq states
+ '((do you get (// found) often \?)
+ (do you enjoy being (// found) \?)
+ (what makes you (// found) \?)
+ (how often ($ areyou)(// found) \?)
+ (when were you last (// found) \?)))
+ (make-local-variable 'replist)
+ (setq replist
+ '((i . (you))
+ (my . (your))
+ (me . (you))
+ (you . (me))
+ (your . (my))
+ (mine . (yours))
+ (yours . (mine))
+ (our . (your))
+ (ours . (yours))
+ (we . (you))
+ (dunno . (do not know))
+;; (yes . ())
+ (no\, . ())
+ (yes\, . ())
+ (ya . (i))
+ (aint . (am not))
+ (wanna . (want to))
+ (gimme . (give me))
+ (gotta . (have to))
+ (gonna . (going to))
+ (never . (not ever))
+ (doesn\'t . (does not))
+ (don\'t . (do not))
+ (aren\'t . (are not))
+ (isn\'t . (is not))
+ (won\'t . (will not))
+ (can\'t . (cannot))
+ (haven\'t . (have not))
+ (i\'m . (you are))
+ (ourselves . (yourselves))
+ (myself . (yourself))
+ (yourself . (myself))
+ (you\'re . (i am))
+ (you\'ve . (i have))
+ (i\'ve . (you have))
+ (i\'ll . (you will))
+ (you\'ll . (i shall))
+ (i\'d . (you would))
+ (you\'d . (i would))
+ (here . (there))
+ (please . ())
+ (eh\, . ())
+ (eh . ())
+ (oh\, . ())
+ (oh . ())
+ (shouldn\'t . (should not))
+ (wouldn\'t . (would not))
+ (won\'t . (will not))
+ (hasn\'t . (has not))))
+ (make-local-variable 'stallmanlst)
+ (setq stallmanlst '(
+ (($ describe) your ($ feelings-about) him \.)
+ (($ areyou) a friend of Stallman \?)
+ (($ bother) Stallman is ($ random-adjective) \?)
+ (($ ibelieve) you are ($ afraidof) him \.)))
+ (make-local-variable 'schoollst)
+ (setq schoollst '(
+ (($ describe) your (// found) \.)
+ (($ bother) your grades could ($ improve) \?)
+ (($ areyou) ($ afraidof) (// found) \?)
+ (($ maybe) this ($ isrelated) to your attitude \.)
+ (($ areyou) absent often \?)
+ (($ maybe) you should study ($ something) \.)))
+ (make-local-variable 'improve)
+ (setq improve '((improve) (be better) (be improved) (be higher)))
+ (make-local-variable 'elizalst)
+ (setq elizalst '(
+ (($ areyou) ($ sure) \?)
+ (($ ibelieve) you have ($ problems) with (// found) \.)
+ (($ whysay) (// sent) \?)))
+ (make-local-variable 'sportslst)
+ (setq sportslst '(
+ (tell me ($ something) about (// found) \.)
+ (($ describe) ($ relation) (// found) \.)
+ (do you find (// found) ($ random-adjective) \?)))
+ (make-local-variable 'mathlst)
+ (setq mathlst '(
+ (($ describe) ($ something) about math \.)
+ (($ maybe) your ($ problems) ($ arerelated) (// found) \.)
+ (i do\'nt know much (// found) \, but ($ continue)
+ anyway \.)))
+ (make-local-variable 'zippylst)
+ (setq zippylst '(
+ (($ areyou) Zippy \?)
+ (($ ibelieve) you have some serious ($ problems) \.)
+ (($ bother) you are a pinhead \?)))
+ (make-local-variable 'chatlst)
+ (setq chatlst '(
+ (($ maybe) we could chat \.)
+ (($ please) ($ describe) ($ something) about chat mode \.)
+ (($ bother) our discussion is so ($ random-adjective) \?)))
+ (make-local-variable 'abuselst)
+ (setq abuselst '(
+ (($ please) try to be less abusive \.)
+ (($ describe) why you call me (// found) \.)
+ (i\'ve had enough of you!)))
+ (make-local-variable 'abusewords)
+ (setq abusewords '(boring bozo clown clumsy cretin dumb dummy
+ fool foolish gnerd gnurd idiot jerk
+ lose loser louse lousy luse luser
+ moron nerd nurd oaf oafish reek
+ stink stupid tool toolish twit))
+ (make-local-variable 'howareyoulst)
+ (setq howareyoulst '((how are you) (hows it going) (hows it going eh)
+ (how\'s it going) (how\'s it going eh) (how goes it)
+ (whats up) (whats new) (what\'s up) (what\'s new)
+ (howre you) (how\'re you) (how\'s everything)
+ (how is everything) (how do you do)
+ (how\'s it hanging) (que pasa)
+ (how are you doing) (what do you say)))
+ (make-local-variable 'whereoutp)
+ (setq whereoutp '( huh remem rthing ) )
+ (make-local-variable 'subj)
+ (setq subj nil)
+ (make-local-variable 'verb)
+ (setq verb nil)
+ (make-local-variable 'obj)
+ (setq obj nil)
+ (make-local-variable 'feared)
+ (setq feared nil)
+ (make-local-variable 'observation-list)
+ (setq observation-list nil)
+ (make-local-variable 'repetitive-shortness)
+ (setq repetitive-shortness '(0 . 0))
+ (make-local-variable '**mad**)
+ (setq **mad** nil)
+ (make-local-variable 'rms-flag)
+ (setq rms-flag nil)
+ (make-local-variable 'eliza-flag)
+ (setq eliza-flag nil)
+ (make-local-variable 'zippy-flag)
+ (setq zippy-flag nil)
+ (make-local-variable 'lover)
+ (setq lover '(your partner))
+ (make-local-variable 'bak)
+ (setq bak nil)
+ (make-local-variable 'lincount)
+ (setq lincount 0)
+ (make-local-variable '*print-upcase*)
+ (setq *print-upcase* nil)
+ (make-local-variable '*print-space*)
+ (setq *print-space* nil)
+ (make-local-variable 'howdyflag)
+ (setq howdyflag nil)
+ (make-local-variable 'object)
+ (setq object nil))
+
+;; Define equivalence classes of words that get treated alike.
+
+(defun doctor-meaning (x) (get x 'doctor-meaning))
+
+(defmacro doctor-put-meaning (symb val)
+ "Store the base meaning of a word on the property list"
+ (list 'put (list 'quote symb) ''doctor-meaning val))
+
+(doctor-put-meaning howdy 'howdy)
+(doctor-put-meaning hi 'howdy)
+(doctor-put-meaning greetings 'howdy)
+(doctor-put-meaning hello 'howdy)
+(doctor-put-meaning tops20 'mach)
+(doctor-put-meaning tops-20 'mach)
+(doctor-put-meaning tops 'mach)
+(doctor-put-meaning pdp11 'mach)
+(doctor-put-meaning computer 'mach)
+(doctor-put-meaning unix 'mach)
+(doctor-put-meaning machine 'mach)
+(doctor-put-meaning computers 'mach)
+(doctor-put-meaning machines 'mach)
+(doctor-put-meaning pdp11s 'mach)
+(doctor-put-meaning foo 'mach)
+(doctor-put-meaning foobar 'mach)
+(doctor-put-meaning multics 'mach)
+(doctor-put-meaning macsyma 'mach)
+(doctor-put-meaning teletype 'mach)
+(doctor-put-meaning la36 'mach)
+(doctor-put-meaning vt52 'mach)
+(doctor-put-meaning zork 'mach)
+(doctor-put-meaning trek 'mach)
+(doctor-put-meaning startrek 'mach)
+(doctor-put-meaning advent 'mach)
+(doctor-put-meaning pdp 'mach)
+(doctor-put-meaning dec 'mach)
+(doctor-put-meaning commodore 'mach)
+(doctor-put-meaning vic 'mach)
+(doctor-put-meaning bbs 'mach)
+(doctor-put-meaning modem 'mach)
+(doctor-put-meaning baud 'mach)
+(doctor-put-meaning macintosh 'mach)
+(doctor-put-meaning vax 'mach)
+(doctor-put-meaning vms 'mach)
+(doctor-put-meaning ibm 'mach)
+(doctor-put-meaning pc 'mach)
+(doctor-put-meaning bitching 'foul)
+(doctor-put-meaning shit 'foul)
+(doctor-put-meaning bastard 'foul)
+(doctor-put-meaning damn 'foul)
+(doctor-put-meaning damned 'foul)
+(doctor-put-meaning hell 'foul)
+(doctor-put-meaning suck 'foul)
+(doctor-put-meaning sucking 'foul)
+(doctor-put-meaning sux 'foul)
+(doctor-put-meaning ass 'foul)
+(doctor-put-meaning whore 'foul)
+(doctor-put-meaning bitch 'foul)
+(doctor-put-meaning asshole 'foul)
+(doctor-put-meaning shrink 'foul)
+(doctor-put-meaning pot 'toke)
+(doctor-put-meaning grass 'toke)
+(doctor-put-meaning weed 'toke)
+(doctor-put-meaning marijuana 'toke)
+(doctor-put-meaning acapulco 'toke)
+(doctor-put-meaning columbian 'toke)
+(doctor-put-meaning tokin 'toke)
+(doctor-put-meaning joint 'toke)
+(doctor-put-meaning toke 'toke)
+(doctor-put-meaning toking 'toke)
+(doctor-put-meaning tokin\' 'toke)
+(doctor-put-meaning toked 'toke)
+(doctor-put-meaning roach 'toke)
+(doctor-put-meaning pills 'drug)
+(doctor-put-meaning dope 'drug)
+(doctor-put-meaning acid 'drug)
+(doctor-put-meaning lsd 'drug)
+(doctor-put-meaning speed 'drug)
+(doctor-put-meaning heroin 'drug)
+(doctor-put-meaning hash 'drug)
+(doctor-put-meaning cocaine 'drug)
+(doctor-put-meaning uppers 'drug)
+(doctor-put-meaning downers 'drug)
+(doctor-put-meaning loves 'loves)
+(doctor-put-meaning love 'love)
+(doctor-put-meaning loved 'love)
+(doctor-put-meaning hates 'hates)
+(doctor-put-meaning dislikes 'hates)
+(doctor-put-meaning hate 'hate)
+(doctor-put-meaning hated 'hate)
+(doctor-put-meaning dislike 'hate)
+(doctor-put-meaning stoned 'state)
+(doctor-put-meaning drunk 'state)
+(doctor-put-meaning drunken 'state)
+(doctor-put-meaning high 'state)
+(doctor-put-meaning horny 'state)
+(doctor-put-meaning blasted 'state)
+(doctor-put-meaning happy 'state)
+(doctor-put-meaning paranoid 'state)
+(doctor-put-meaning wish 'desire)
+(doctor-put-meaning wishes 'desire)
+(doctor-put-meaning want 'desire)
+(doctor-put-meaning desire 'desire)
+(doctor-put-meaning like 'desire)
+(doctor-put-meaning hope 'desire)
+(doctor-put-meaning hopes 'desire)
+(doctor-put-meaning desires 'desire)
+(doctor-put-meaning wants 'desire)
+(doctor-put-meaning desires 'desire)
+(doctor-put-meaning likes 'desire)
+(doctor-put-meaning needs 'desire)
+(doctor-put-meaning need 'desire)
+(doctor-put-meaning frustrated 'mood)
+(doctor-put-meaning depressed 'mood)
+(doctor-put-meaning annoyed 'mood)
+(doctor-put-meaning upset 'mood)
+(doctor-put-meaning unhappy 'mood)
+(doctor-put-meaning excited 'mood)
+(doctor-put-meaning worried 'mood)
+(doctor-put-meaning lonely 'mood)
+(doctor-put-meaning angry 'mood)
+(doctor-put-meaning mad 'mood)
+(doctor-put-meaning pissed 'mood)
+(doctor-put-meaning jealous 'mood)
+(doctor-put-meaning afraid 'fear)
+(doctor-put-meaning terrified 'fear)
+(doctor-put-meaning fear 'fear)
+(doctor-put-meaning scared 'fear)
+(doctor-put-meaning frightened 'fear)
+(doctor-put-meaning virginity 'sexnoun)
+(doctor-put-meaning virgins 'sexnoun)
+(doctor-put-meaning virgin 'sexnoun)
+(doctor-put-meaning cock 'sexnoun)
+(doctor-put-meaning cocks 'sexnoun)
+(doctor-put-meaning dick 'sexnoun)
+(doctor-put-meaning dicks 'sexnoun)
+(doctor-put-meaning cunt 'sexnoun)
+(doctor-put-meaning cunts 'sexnoun)
+(doctor-put-meaning prostitute 'sexnoun)
+(doctor-put-meaning condom 'sexnoun)
+(doctor-put-meaning sex 'sexnoun)
+(doctor-put-meaning rapes 'sexnoun)
+(doctor-put-meaning wife 'family)
+(doctor-put-meaning family 'family)
+(doctor-put-meaning brothers 'family)
+(doctor-put-meaning sisters 'family)
+(doctor-put-meaning parent 'family)
+(doctor-put-meaning parents 'family)
+(doctor-put-meaning brother 'family)
+(doctor-put-meaning sister 'family)
+(doctor-put-meaning father 'family)
+(doctor-put-meaning mother 'family)
+(doctor-put-meaning husband 'family)
+(doctor-put-meaning siblings 'family)
+(doctor-put-meaning grandmother 'family)
+(doctor-put-meaning grandfather 'family)
+(doctor-put-meaning maternal 'family)
+(doctor-put-meaning paternal 'family)
+(doctor-put-meaning stab 'death)
+(doctor-put-meaning murder 'death)
+(doctor-put-meaning murders 'death)
+(doctor-put-meaning suicide 'death)
+(doctor-put-meaning suicides 'death)
+(doctor-put-meaning kill 'death)
+(doctor-put-meaning kills 'death)
+(doctor-put-meaning die 'death)
+(doctor-put-meaning dies 'death)
+(doctor-put-meaning died 'death)
+(doctor-put-meaning dead 'death)
+(doctor-put-meaning death 'death)
+(doctor-put-meaning deaths 'death)
+(doctor-put-meaning pain 'symptoms)
+(doctor-put-meaning ache 'symptoms)
+(doctor-put-meaning fever 'symptoms)
+(doctor-put-meaning sore 'symptoms)
+(doctor-put-meaning aching 'symptoms)
+(doctor-put-meaning stomachache 'symptoms)
+(doctor-put-meaning headache 'symptoms)
+(doctor-put-meaning hurts 'symptoms)
+(doctor-put-meaning disease 'symptoms)
+(doctor-put-meaning virus 'symptoms)
+(doctor-put-meaning vomit 'symptoms)
+(doctor-put-meaning vomiting 'symptoms)
+(doctor-put-meaning barf 'symptoms)
+(doctor-put-meaning toothache 'symptoms)
+(doctor-put-meaning hurt 'symptoms)
+(doctor-put-meaning rum 'alcohol)
+(doctor-put-meaning gin 'alcohol)
+(doctor-put-meaning vodka 'alcohol)
+(doctor-put-meaning alcohol 'alcohol)
+(doctor-put-meaning bourbon 'alcohol)
+(doctor-put-meaning beer 'alcohol)
+(doctor-put-meaning wine 'alcohol)
+(doctor-put-meaning whiskey 'alcohol)
+(doctor-put-meaning scotch 'alcohol)
+(doctor-put-meaning fuck 'sexverb)
+(doctor-put-meaning fucked 'sexverb)
+(doctor-put-meaning screw 'sexverb)
+(doctor-put-meaning screwing 'sexverb)
+(doctor-put-meaning fucking 'sexverb)
+(doctor-put-meaning rape 'sexverb)
+(doctor-put-meaning raped 'sexverb)
+(doctor-put-meaning kiss 'sexverb)
+(doctor-put-meaning kissing 'sexverb)
+(doctor-put-meaning kisses 'sexverb)
+(doctor-put-meaning screws 'sexverb)
+(doctor-put-meaning fucks 'sexverb)
+(doctor-put-meaning because 'conj)
+(doctor-put-meaning but 'conj)
+(doctor-put-meaning however 'conj)
+(doctor-put-meaning besides 'conj)
+(doctor-put-meaning anyway 'conj)
+(doctor-put-meaning that 'conj)
+(doctor-put-meaning except 'conj)
+(doctor-put-meaning why 'conj)
+(doctor-put-meaning how 'conj)
+(doctor-put-meaning until 'when)
+(doctor-put-meaning when 'when)
+(doctor-put-meaning whenever 'when)
+(doctor-put-meaning while 'when)
+(doctor-put-meaning since 'when)
+(doctor-put-meaning rms 'rms)
+(doctor-put-meaning stallman 'rms)
+(doctor-put-meaning school 'school)
+(doctor-put-meaning schools 'school)
+(doctor-put-meaning skool 'school)
+(doctor-put-meaning grade 'school)
+(doctor-put-meaning grades 'school)
+(doctor-put-meaning teacher 'school)
+(doctor-put-meaning teachers 'school)
+(doctor-put-meaning classes 'school)
+(doctor-put-meaning professor 'school)
+(doctor-put-meaning prof 'school)
+(doctor-put-meaning profs 'school)
+(doctor-put-meaning professors 'school)
+(doctor-put-meaning mit 'school)
+(doctor-put-meaning emacs 'eliza)
+(doctor-put-meaning eliza 'eliza)
+(doctor-put-meaning liza 'eliza)
+(doctor-put-meaning elisa 'eliza)
+(doctor-put-meaning weizenbaum 'eliza)
+(doctor-put-meaning doktor 'eliza)
+(doctor-put-meaning atheletics 'sports)
+(doctor-put-meaning baseball 'sports)
+(doctor-put-meaning basketball 'sports)
+(doctor-put-meaning football 'sports)
+(doctor-put-meaning frisbee 'sports)
+(doctor-put-meaning gym 'sports)
+(doctor-put-meaning gymnastics 'sports)
+(doctor-put-meaning hockey 'sports)
+(doctor-put-meaning lacrosse 'sports)
+(doctor-put-meaning soccer 'sports)
+(doctor-put-meaning softball 'sports)
+(doctor-put-meaning sports 'sports)
+(doctor-put-meaning swimming 'sports)
+(doctor-put-meaning swim 'sports)
+(doctor-put-meaning tennis 'sports)
+(doctor-put-meaning volleyball 'sports)
+(doctor-put-meaning math 'math)
+(doctor-put-meaning mathematics 'math)
+(doctor-put-meaning mathematical 'math)
+(doctor-put-meaning theorem 'math)
+(doctor-put-meaning axiom 'math)
+(doctor-put-meaning lemma 'math)
+(doctor-put-meaning algebra 'math)
+(doctor-put-meaning algebraic 'math)
+(doctor-put-meaning trig 'math)
+(doctor-put-meaning trigonometry 'math)
+(doctor-put-meaning trigonometric 'math)
+(doctor-put-meaning geometry 'math)
+(doctor-put-meaning geometric 'math)
+(doctor-put-meaning calculus 'math)
+(doctor-put-meaning arithmetic 'math)
+(doctor-put-meaning zippy 'zippy)
+(doctor-put-meaning zippy 'zippy)
+(doctor-put-meaning pinhead 'zippy)
+(doctor-put-meaning chat 'chat)
+
+(defun doctor ()
+ "Switch to *doctor* buffer and start giving psychotherapy."
+ (interactive)
+ (switch-to-buffer "*doctor*")
+ (doctor-mode))
+
+(defun doctor-ret-or-read (arg)
+ "Insert a newline if preceding character is not a newline,
+Otherwise call the Doctor to parse preceding sentence"
+ (interactive "*p")
+ (if (= (preceding-char) ?\n)
+ (doctor-read-print)
+ (newline arg)))
+
+(defun doctor-read-print nil
+ "top level loop"
+ (interactive)
+ (let ((sent (doctor-readin)))
+ (insert "\n")
+ (setq lincount (1+ lincount))
+ (doctor-doc sent)
+ (insert "\n")
+ (setq bak sent)))
+
+(defun doctor-readin nil
+ "Read a sentence. Return it as a list of words"
+ (let (sentence)
+ (backward-sentence 1)
+ (while (not (eobp))
+ (setq sentence (append sentence (list (doctor-read-token)))))
+ sentence))
+
+(defun doctor-read-token ()
+ "read one word from buffer"
+ (prog1 (intern (downcase (buffer-substring (point)
+ (progn
+ (forward-word 1)
+ (point)))))
+ (re-search-forward "\\Sw*")))
+
+;; Main processing function for sentences that have been read.
+
+(defun doctor-doc (sent)
+ (cond
+ ((equal sent '(foo))
+ (doctor-type '(bar! ($ please)($ continue))))
+ ((doctor-member sent howareyoulst)
+ (doctor-type '(i\'m ok \. ($ describe) yourself \.)))
+ ((or (doctor-member sent '((good bye) (see you later) (i quit) (so long)
+ (go away) (get lost)))
+ (memq (car sent)
+ '(bye halt break quit done exit goodbye
+ bye\, stop pause goodbye\, stop pause)))
+ (doctor-type ($ bye)))
+ ((and (eq (car sent) 'you)
+ (memq (doctor-cadr sent) abusewords))
+ (setq found (doctor-cadr sent))
+ (doctor-type ($ abuselst)))
+ ((eq (car sent) 'whatmeans)
+ (doctor-def (doctor-cadr sent)))
+ ((equal sent '(parse))
+ (doctor-type (list 'subj '= subj ", "
+ 'verb '= verb "\n"
+ 'object 'phrase '= obj ","
+ 'noun 'form '= object "\n"
+ 'current 'keyword 'is found
+ ", "
+ 'most 'recent 'possessive
+ 'is owner "\n"
+ 'sentence 'used 'was
+ "..."
+ '(// bak))))
+ ;; ((eq (car sent) 'forget)
+ ;; (set (doctor-cadr sent) nil)
+ ;; (doctor-type '(($ isee)($ please)
+ ;; ($ continue)\.)))
+ (t
+ (if (doctor-defq sent) (doctor-define sent found))
+ (if (> (length sent) 12)(doctor-shorten sent))
+ (setq sent (doctor-correct-spelling (doctor-replace sent replist)))
+ (cond ((and (not (memq 'me sent))(not (memq 'i sent))
+ (memq 'am sent))
+ (setq sent (doctor-replace sent '((am . (are)))))))
+ (cond ((equal (car sent) 'yow) (doctor-zippy))
+ ((< (length sent) 2)
+ (cond ((eq (doctor-meaning (car sent)) 'howdy)
+ (doctor-howdy))
+ (t (doctor-short))))
+ (t
+ (if (memq 'am sent)
+ (setq sent (doctor-replace sent '((me . (i))))))
+ (setq sent (doctor-fixup sent))
+ (if (and (eq (car sent) 'do) (eq (doctor-cadr sent) 'not))
+ (cond ((zerop (random-range 3))
+ (doctor-type '(are you ($ afraidof) that \?)))
+ ((zerop (random-range 2))
+ (doctor-type '(don\'t tell me what to do \. i am the
+ psychiatrist here!))
+ (doctor-rthing))
+ (t
+ (doctor-type '(($ whysay) that i shouldn\'t
+ (doctor-cddr sent)
+ \?))))
+ (doctor-go (doctor-wherego sent))))))))
+
+;; Things done to process sentences once read.
+
+(defun doctor-correct-spelling (sent)
+ "correct the spelling and expand each word in sentence"
+ (if sent
+ (apply 'append (mapcar '(lambda (word)
+ (if (memq word typos)
+ (get (get word 'doctor-correction) 'doctor-expansion)
+ (list word)))
+ sent))))
+
+(defun doctor-shorten (sent)
+ "Make a sentence managably short using a few hacks"
+ (let (foo
+ retval
+ (temp '(because but however besides anyway until
+ while that except why how)))
+ (while temp
+ (setq foo (memq (car temp) sent))
+ (if (and foo
+ (> (length foo) 3))
+ (setq sent foo
+ sent (doctor-fixup sent)
+ temp nil
+ retval t)
+ (setq temp (cdr temp))))
+ retval))
+
+(defun doctor-define (sent found)
+ (doctor-svo sent found 1 nil)
+ (and
+ (doctor-nounp subj)
+ (not (doctor-pronounp subj))
+ subj
+ (doctor-meaning object)
+ (put subj 'doctor-meaning (doctor-meaning object))
+ t))
+
+(defun doctor-defq (sent)
+ "Set global var found to first keyword found in sentence SENT"
+ (setq found nil)
+ (let ((temp '(means applies mean refers refer related
+ similar defined associated linked like same)))
+ (while temp
+ (if (memq (car temp) sent)
+ (setq found (car temp)
+ temp nil)
+ (setq temp (cdr temp)))))
+ found)
+
+(defun doctor-def (x)
+ (progn
+ (doctor-type (list 'the 'word x 'means (doctor-meaning x) 'to 'me))
+ nil))
+
+(defun doctor-forget ()
+ "Delete the last element of the history list"
+ (setq history (reverse (cdr (reverse history)))))
+
+(defun doctor-query (x)
+ "Prompt for a line of input from the minibuffer until a noun or a
+verb word is seen. Put dialogue in buffer."
+ (let (a
+ (prompt (concat (doctor-make-string x)
+ " what \? "))
+ retval)
+ (while (not retval)
+ (while (not a)
+ (insert ?\n
+ prompt
+ (read-string prompt)
+ ?\n)
+ (setq a (doctor-readin)))
+ (while (and a (not retval))
+ (cond ((doctor-nounp (car a))
+ (setq retval (car a)))
+ ((doctor-verbp (car a))
+ (setq retval (doctor-build
+ (doctor-build x " ")
+ (car a))))
+ ((setq a (cdr a))))))
+ retval))
+
+(defun doctor-subjsearch (sent key type)
+ "Search for the subject of a sentence SENT, looking for the noun closest to
+and preceding KEY by at least TYPE words. Set global variable subj to the
+subject noun, and return the portion of the sentence following it"
+ (let ((i (- (length sent) (length (memq key sent)) type)))
+ (while (and (> i -1) (not (doctor-nounp (nth i sent))))
+ (setq i (1- i)))
+ (cond ((> i -1)
+ (setq subj (nth i sent))
+ (nthcdr (1+ i) sent))
+ (t
+ (setq subj 'you)
+ nil))))
+
+(defun doctor-nounp (x)
+ "Returns t if the symbol argument is a noun"
+ (or (doctor-pronounp x)
+ (not (or (doctor-verbp x)
+ (equal x 'not)
+ (doctor-prepp x)
+ (doctor-modifierp x) )) ))
+
+(defun doctor-pronounp (x)
+ "Returns t if the symbol argument is a pronoun"
+ (memq x '(
+ i me mine myself
+ we us ours ourselves ourself
+ you yours yourself yourselves
+ he him himself she hers herself
+ it that those this these things thing
+ they them themselves theirs
+ anybody everybody somebody
+ anyone everyone someone
+ anything something everything)))
+
+(mapcar (function (lambda (x) (put x 'doctor-sentence-type 'verb)))
+ '(abort aborted aborts ask asked asks am
+ applied applies apply are associate
+ associated ate
+ be became become becomes becoming
+ been being believe belived believes
+ bit bite bites bore bored bores boring bought buy buys buying
+ call called calling calls came can caught catch come
+ contract contracted contracts control controlled controls
+ could croak croaks croaked cut cuts
+ dare dared define defines dial dialed dials did die died dies
+ dislike disliked
+ dislikes do does drank drink drinks drinking
+ drive drives driving drove dying
+ eat eating eats expand expanded expands
+ expect expected expects expel expels expeled expelled
+ explain explained explains
+ fart farts feel feels felt fight fights find finds finding
+ forget forgets forgot fought found fuck fucked
+ fucking fucks
+ gave get gets getting give gives go goes going gone got gotten
+ had harm harms has hate hated hates have having
+ hear heard hears hearing help helped helping helps
+ hit hits hope hoped hopes hurt hurts
+ implies imply is
+ join joined joins jump jumped jumps
+ keep keeping keeps kept
+ kill killed killing kills kiss kissed kisses kissing
+ knew know knows
+ laid lay lays let lets lie lied lies like liked likes
+ liking listen listens
+ login look looked looking looks
+ lose losing lost
+ love loved loves loving
+ luse lusing lust lusts
+ made make makes making may mean means meant might
+ move moved moves moving must
+ need needed needs
+ order ordered orders ought
+ paid pay pays pick picked picking picks
+ placed placing prefer prefers put puts
+ ran rape raped rapes
+ read reading reads recall receive received receives
+ refer refered referred refers
+ relate related relates remember remembered remembers
+ romp romped romps run running runs
+ said sang sat saw say says
+ screw screwed screwing screws scrod see sees seem seemed
+ seems seen sell selling sells
+ send sendind sends sent shall shoot shot should
+ sing sings sit sits sitting sold studied study
+ take takes taking talk talked talking talks tell tells telling
+ think thinks
+ thought told took tooled touch touched touches touching
+ transfer transfered transfers transmit transmits transmitted
+ type types types typing
+ walk walked walking walks want wanted wants was watch
+ watched watching went were will wish would work worked works
+ write writes writing wrote use used uses using))
+
+(defun doctor-verbp (x) (if (symbolp x)
+ (eq (get x 'doctor-sentence-type) 'verb)))
+
+(defun doctor-plural (x)
+ "form the plural of the word argument"
+ (let ((foo (doctor-make-string x)))
+ (cond ((string-equal (substring foo -1) "s")
+ (cond ((string-equal (substring foo -2 -1) "s")
+ (intern (concat foo "es")))
+ (t x)))
+ ((string-equal (substring foo -1) "y")
+ (intern (concat (substring foo 0 -1)
+ "ies")))
+ (t (intern (concat foo "s"))))))
+
+(defun doctor-setprep (sent key)
+ (let ((val)
+ (foo (memq key sent)))
+ (cond ((doctor-prepp (doctor-cadr foo))
+ (setq val (doctor-getnoun (doctor-cddr foo)))
+ (cond (val val)
+ (t 'something)))
+ ((doctor-articlep (doctor-cadr foo))
+ (setq val (doctor-getnoun (doctor-cddr foo)))
+ (cond (val (doctor-build (doctor-build (doctor-cadr foo) " ") val))
+ (t 'something)))
+ (t 'something))))
+
+(defun doctor-getnoun (x)
+ (cond ((null x)(setq object 'something))
+ ((atom x)(setq object x))
+ ((eq (length x) 1)
+ (setq object (cond
+ ((doctor-nounp (setq object (car x))) object)
+ (t (doctor-query object)))))
+ ((eq (car x) 'to)
+ (doctor-build 'to\ (doctor-getnoun (cdr x))))
+ ((doctor-prepp (car x))
+ (doctor-getnoun (cdr x)))
+ ((not (doctor-nounp (car x)))
+ (doctor-build (doctor-build (cdr (assq (car x)
+ (append
+ '((a . this)
+ (some . this)
+ (one . that))
+ (list
+ (cons
+ (car x) (car x))))))
+ " ")
+ (doctor-getnoun (cdr x))))
+ (t (setq object (car x))) ))
+
+(defun doctor-modifierp (x)
+ (or (doctor-adjectivep x)
+ (doctor-adverbp x)
+ (doctor-othermodifierp x)))
+
+(defun doctor-adjectivep (x)
+ (or (numberp x)
+ (doctor-nmbrp x)
+ (doctor-articlep x)
+ (doctor-colorp x)
+ (doctor-sizep x)
+ (doctor-possessivepronounp x)))
+
+(defun doctor-adverbp (xx)
+ (string-equal (substring (doctor-make-string xx) -2) "ly"))
+
+(defun doctor-articlep (x)
+ (memq x '(the a an)))
+
+(defun doctor-nmbrp (x)
+ (memq x '(one two three four five six seven eight nine ten
+ eleven twelve thirteen fourteen fifteen
+ sixteen seventeen eighteen nineteen
+ twenty thirty forty fifty sixty seventy eighty ninety
+ hundred thousand million billion
+ half quarter
+ first second third fourth fifth
+ sixth seventh eighth nineth tenth)))
+
+(defun doctor-colorp (x)
+ (memq x '(beige black blue brown crimson
+ gray grey green
+ orange pink purple red tan tawny
+ violet white yellow)))
+
+(defun doctor-sizep (x)
+ (memq x '(big large tall fat wide thick
+ small petite short thin skinny)))
+
+(defun doctor-possessivepronounp (x)
+ (memq x '(my your his her our their)))
+
+(defun doctor-othermodifierp (x)
+ (memq x '(all also always amusing any anyway associated awesome
+ bad beautiful best better but certain clear
+ ever every fantastic fun funny
+ good great gross growdy however if ignorant
+ less linked losing lusing many more much
+ never nice obnoxious often poor pretty real related rich
+ similar some stupid super superb
+ terrible terrific too total tubular ugly very)))
+
+(defun doctor-prepp (x)
+ (memq x '(about above after around as at
+ before beneath behind beside between by
+ for from in inside into
+ like near next of on onto over
+ same through thru to toward towards
+ under underneath with without)))
+
+(defun doctor-remember (thing)
+ (cond ((null history)
+ (setq history (list thing)))
+ (t (setq history (append history (list thing))))))
+
+(defun doctor-type (x)
+ (setq x (doctor-fix-2 x))
+ (doctor-txtype (doctor-assm x)))
+
+(defun doctor-fixup (sent)
+ (setq sent (append
+ (cdr
+ (assq (car sent)
+ (append
+ '((me i)
+ (him he)
+ (her she)
+ (them they)
+ (okay)
+ (well)
+ (sigh)
+ (hmm)
+ (hmmm)
+ (hmmmm)
+ (hmmmmm)
+ (gee)
+ (sure)
+ (great)
+ (oh)
+ (fine)
+ (ok)
+ (no))
+ (list (list (car sent)
+ (car sent))))))
+ (cdr sent)))
+ (doctor-fix-2 sent))
+
+(defun doctor-fix-2 (sent)
+ (let ((foo sent))
+ (while foo
+ (if (and (eq (car foo) 'me)
+ (doctor-verbp (doctor-cadr foo)))
+ (rplaca foo 'i)
+ (cond ((eq (car foo) 'you)
+ (cond ((memq (doctor-cadr foo) '(am be been is))
+ (rplaca (cdr foo) 'are))
+ ((memq (doctor-cadr foo) '(has))
+ (rplaca (cdr foo) 'have))
+ ((memq (doctor-cadr foo) '(was))
+ (rplaca (cdr foo) 'were))))
+ ((equal (car foo) 'i)
+ (cond ((memq (doctor-cadr foo) '(are is be been))
+ (rplaca (cdr foo) 'am))
+ ((memq (doctor-cadr foo) '(were))
+ (rplaca (cdr foo) 'was))
+ ((memq (doctor-cadr foo) '(has))
+ (rplaca (cdr foo) 'have))))
+ ((and (doctor-verbp (car foo))
+ (eq (doctor-cadr foo) 'i)
+ (not (doctor-verbp (car (doctor-cddr foo)))))
+ (rplaca (cdr foo) 'me))
+ ((and (eq (car foo) 'a)
+ (doctor-vowelp (string-to-char
+ (doctor-make-string (doctor-cadr foo)))))
+ (rplaca foo 'an))
+ ((and (eq (car foo) 'an)
+ (not (doctor-vowelp (string-to-char
+ (doctor-make-string (doctor-cadr foo))))))
+ (rplaca foo 'a)))
+ (setq foo (cdr foo))))
+ sent))
+
+(defun doctor-vowelp (x)
+ (memq x '(?a ?e ?i ?o ?u)))
+
+(defun doctor-replace (sent rlist)
+ "Replaces any element of SENT that is the car of a replacement element
+pair in RLIST"
+ (apply 'append
+ (mapcar
+ (function
+ (lambda (x)
+ (cdr (or (assq x rlist) ; either find a replacement
+ (list x x))))) ; or fake an identity mapping
+ sent)))
+
+(defun doctor-wherego (sent)
+ (cond ((null sent)($ whereoutp))
+ ((null (doctor-meaning (car sent)))
+ (doctor-wherego (cond ((zerop (random-range 2))
+ (reverse (cdr sent)))
+ (t (cdr sent)))))
+ (t
+ (setq found (car sent))
+ (doctor-meaning (car sent)))))
+
+(defun doctor-svo (sent key type mem)
+ "Find subject, verb and object in sentence SENT with focus on word KEY.
+TYPE is number of words preceding KEY to start looking for subject. MEM is
+t if results are to be put on doctor's memory stack. Return is in global
+variables subj, verb and object"
+ (let ((foo (doctor-subjsearch sent key type) sent))
+ (or foo
+ (setq foo sent
+ mem nil))
+ (while (and (null (doctor-verbp (car foo))) (cdr foo))
+ (setq foo (cdr foo)))
+ (setq verb (car foo))
+ (setq obj (doctor-getnoun (cdr foo)))
+ (cond ((eq object 'i)(setq object 'me))
+ ((eq subj 'me)(setq subj 'i)))
+ (cond (mem (doctor-remember (list subj verb obj))))))
+
+(defun doctor-possess (sent key)
+ "Set possessive in SENT for keyword KEY. Hack on previous word, setting
+global variable owner to possibly correct result"
+ (let* ((i (- (length sent) (length (memq key sent)) 1))
+ (prev (if (< i 0) 'your
+ (nth i sent))))
+ (setq owner (if (or (doctor-possessivepronounp prev)
+ (string-equal "s"
+ (substring (doctor-make-string prev)
+ -1)))
+ prev
+ 'your))))
+
+;; Output of replies.
+
+(defun doctor-txtype (ans)
+ "Output to buffer a list of symbols or strings as a sentence"
+ (setq *print-upcase* t *print-space* nil)
+ (mapcar 'doctor-type-symbol ans)
+ (insert "\n"))
+
+(defun doctor-type-symbol (word)
+ "Output a symbol to the buffer with some fancy case and spacing hacks"
+ (setq word (doctor-make-string word))
+ (if (string-equal word "i") (setq word "I"))
+ (if *print-upcase*
+ (progn
+ (setq word (capitalize word))
+ (if *print-space*
+ (insert " "))))
+ (cond ((or (string-match "^[.,;:?! ]" word)
+ (not *print-space*))
+ (insert word))
+ (t (insert ?\ word)))
+ (if (> (current-column) fill-column)
+ (apply auto-fill-hook nil))
+ (setq *print-upcase* (string-match "[.?!]$" word)
+ *print-space* t))
+
+(defun doctor-build (str1 str2)
+ "Make a symbol out of the concatenation of the two non-list arguments"
+ (cond ((null str1) str2)
+ ((null str2) str1)
+ ((and (atom str1)
+ (atom str2))
+ (intern (concat (doctor-make-string str1)
+ (doctor-make-string str2))))
+ (t nil)))
+
+(defun doctor-make-string (obj)
+ (cond ((stringp obj) obj)
+ ((symbolp obj) (symbol-name obj))
+ ((numberp obj) (int-to-string obj))
+ (t "")))
+
+(defun doctor-concat (x y)
+ "like append, but force atomic arguments to be lists"
+ (append
+ (if (and x (atom x)) (list x) x)
+ (if (and y (atom y)) (list y) y)))
+
+(defun doctor-assm (proto)
+ (cond ((null proto) nil)
+ ((atom proto) (list proto))
+ ((atom (car proto))
+ (cons (car proto) (doctor-assm (cdr proto))))
+ (t (doctor-concat (doctor-assm (eval (car proto))) (doctor-assm (cdr proto))))))
+
+;; Functions that handle specific words or meanings when found.
+
+(defun doctor-go (destination)
+ "Call a doctor- function"
+ (funcall (intern (concat "doctor-" (doctor-make-string destination)))))
+
+(defun doctor-desire1 ()
+ (doctor-go ($ whereoutp)))
+
+(defun doctor-huh ()
+ (cond ((< (length sent) 9) (doctor-type ($ huhlst)))
+ (t (doctor-type ($ longhuhlst)))))
+
+(defun doctor-rthing () (doctor-type ($ thlst)))
+
+(defun doctor-remem () (cond ((null history)(doctor-huh))
+ ((doctor-type ($ remlst)))))
+
+(defun doctor-howdy ()
+ (cond ((not howdyflag)
+ (doctor-type '(($ hello) what brings you to see me \?))
+ (setq howdyflag t))
+ (t
+ (doctor-type '(($ ibelieve) we\'ve introduced ourselves already \.))
+ (doctor-type '(($ please) ($ describe) ($ things) \.)))))
+
+(defun doctor-when ()
+ (cond ((< (length (memq found sent)) 3)(doctor-short))
+ (t
+ (setq sent (cdr (memq found sent)))
+ (setq sent (doctor-fixup sent))
+ (doctor-type '(($ whatwhen)(// sent) \?)))))
+
+(defun doctor-conj ()
+ (cond ((< (length (memq found sent)) 4)(doctor-short))
+ (t
+ (setq sent (cdr (memq found sent)))
+ (setq sent (doctor-fixup sent))
+ (cond ((eq (car sent) 'of)
+ (doctor-type '(are you ($ sure) that is the real reason \?))
+ (setq things (cons (cdr sent) things)))
+ (t
+ (doctor-remember sent)
+ (doctor-type ($ beclst)))))))
+
+(defun doctor-short ()
+ (cond ((= (car repetitive-shortness) (1- lincount))
+ (rplacd repetitive-shortness
+ (1+ (cdr repetitive-shortness))))
+ (t
+ (rplacd repetitive-shortness 1)))
+ (rplaca repetitive-shortness lincount)
+ (cond ((> (cdr repetitive-shortness) 6)
+ (cond ((not **mad**)
+ (doctor-type '(($ areyou)
+ just trying to see what kind of things
+ i have in my vocabulary \? please try to
+ carry on a reasonable conversation!))
+ (setq **mad** t))
+ (t
+ (doctor-type '(i give up \. you need a lesson in creative
+ writing \.\.\.))
+ ;;(push monosyllables observation-list)
+ )))
+ (t
+ (cond ((equal sent (doctor-assm '(yes)))
+ (doctor-type '(($ isee) ($ inter) ($ whysay) this is so \?)))
+ ((equal sent (doctor-assm '(because)))
+ (doctor-type ($ shortbeclst)))
+ ((equal sent (doctor-assm '(no)))
+ (doctor-type ($ neglst)))
+ (t (doctor-type ($ shortlst)))))))
+
+(defun doctor-alcohol () (doctor-type ($ drnk)))
+
+(defun doctor-desire ()
+ (let ((foo (memq found sent)))
+ (cond ((< (length foo) 2)
+ (doctor-go (doctor-build (doctor-meaning found) 1)))
+ ((memq (doctor-cadr foo) '(a an))
+ (rplacd foo (append '(to have) (cdr foo)))
+ (doctor-svo sent found 1 nil)
+ (doctor-remember (list subj 'would 'like obj))
+ (doctor-type ($ whywant)))
+ ((not (eq (doctor-cadr foo) 'to))
+ (doctor-go (doctor-build (doctor-meaning found) 1)))
+ (t
+ (doctor-svo sent found 1 nil)
+ (doctor-remember (list subj 'would 'like obj))
+ (doctor-type ($ whywant))))))
+
+(defun doctor-drug ()
+ (doctor-type ($ drugs))
+ (doctor-remember (list 'you 'used found)))
+
+(defun doctor-toke ()
+ (doctor-type ($ toklst)))
+
+(defun doctor-state ()
+ (doctor-type ($ states))(doctor-remember (list 'you 'were found)))
+
+(defun doctor-mood ()
+ (doctor-type ($ moods))(doctor-remember (list 'you 'felt found)))
+
+(defun doctor-fear ()
+ (setq feared (doctor-setprep sent found))
+ (doctor-type ($ fears))
+ (doctor-remember (list 'you 'were 'afraid 'of feared)))
+
+(defun doctor-hate ()
+ (doctor-svo sent found 1 t)
+ (cond ((memq 'not sent) (doctor-forget) (doctor-huh))
+ ((equal subj 'you)
+ (doctor-type '(why do you (// verb)(// obj) \?)))
+ (t (doctor-type '(($ whysay)(list subj verb obj))))))
+
+(defun doctor-symptoms ()
+ (doctor-type '(($ maybe) you should consult a doctor of medicine\,
+ i am a psychiatrist \.)))
+
+(defun doctor-hates ()
+ (doctor-svo sent found 1 t)
+ (doctor-hates1))
+
+(defun doctor-hates1 ()
+ (doctor-type '(($ whysay)(list subj verb obj))))
+
+(defun doctor-loves ()
+ (doctor-svo sent found 1 t)
+ (doctor-qloves))
+
+(defun doctor-qloves ()
+ (doctor-type '(($ bother)(list subj verb obj) \?)))
+
+(defun doctor-love ()
+ (doctor-svo sent found 1 t)
+ (cond ((memq 'not sent) (doctor-forget) (doctor-huh))
+ ((memq 'to sent) (doctor-hates1))
+ (t
+ (cond ((equal object 'something)
+ (setq object '(this person you love))))
+ (cond ((equal subj 'you)
+ (setq lover obj)
+ (cond ((equal lover '(this person you love))
+ (setq lover '(your partner))
+ (doctor-forget)
+ (doctor-type '(with whom are you in love \?)))
+ ((doctor-type '(($ please)
+ ($ describe)
+ ($ relation)
+ (// lover)
+ \.)))))
+ ((equal subj 'i)
+ (doctor-txtype '(we were discussing you!)))
+ (t (doctor-forget)
+ (setq obj 'someone)
+ (setq verb (doctor-build verb 's))
+ (doctor-qloves))))))
+
+(defun doctor-mach ()
+ (setq found (doctor-plural found))
+ (doctor-type ($ machlst)))
+
+(defun doctor-sexnoun () (doctor-sexverb))
+
+(defun doctor-sexverb ()
+ (if (or (memq 'me sent)(memq 'myself sent)(memq 'i sent))
+ (doctor-foul)
+ (doctor-type ($ sexlst))))
+
+(defun doctor-death () (doctor-type ($ deathlst)))
+
+(defun doctor-foul ()
+ (doctor-type ($ foullst)))
+
+(defun doctor-family ()
+ (doctor-possess sent found)
+ (doctor-type ($ famlst)))
+
+;; I did not add this -- rms.
+(defun doctor-rms ()
+ (cond (rms-flag (doctor-type ($ stallmanlst)))
+ (t (setq rms-flag t) (doctor-type '(do you know Stallman \?)))))
+
+(defun doctor-school nil (doctor-type ($ schoollst)))
+
+(defun doctor-eliza ()
+ (cond (eliza-flag (doctor-type ($ elizalst)))
+ (t (setq eliza-flag t)
+ (doctor-type '((// found) \? hah !
+ ($ please) ($ continue) \.)))))
+
+(defun doctor-sports () (doctor-type ($ sportslst)))
+
+(defun doctor-math () (doctor-type ($ mathlst)))
+
+(defun doctor-zippy ()
+ (cond (zippy-flag (doctor-type ($ zippylst)))
+ (t (setq zippy-flag t)
+ (doctor-type '(yow! are we interactive yet \?)))))
+
+
+(defun doctor-chat () (doctor-type ($ chatlst)))
diff --git a/lisp/doctor.elc b/lisp/doctor.elc
new file mode 100644
index 00000000000..62929b7af12
--- /dev/null
+++ b/lisp/doctor.elc
Binary files differ
diff --git a/lisp/ebuff-menu.el b/lisp/ebuff-menu.el
new file mode 100644
index 00000000000..72de2dd8c4f
--- /dev/null
+++ b/lisp/ebuff-menu.el
@@ -0,0 +1,244 @@
+; buggestions to mly@ai.ai.mit.edu
+
+;; who says one can't have typeout windows in gnu emacs?
+;; like ^r select buffer from its emacs lunar or tmacs libraries.
+
+;; Copyright (C) 1985, 1986 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+(require 'electric)
+
+;; this depends on the format of list-buffers (from src/buffer.c) and
+;; on stuff in lisp/buff-menu.el
+
+(defvar electric-buffer-menu-mode-map nil)
+(defun electric-buffer-list (arg)
+ "Vaguely like ITS lunar select buffer;
+combining typeoutoid buffer listing with menuoid buffer selection.
+
+This pops up a buffer describing the set of emacs buffers.
+If the very next character typed is a space then the buffer list
+ window disappears.
+
+Otherwise, one may move around in the buffer list window, marking
+ buffers to be selected, saved or deleted.
+
+To exit and select a new buffer, type Space when the cursor is on the
+ appropriate line of the buffer-list window.
+
+Other commands are much like those of buffer-menu-mode.
+
+Calls value of electric-buffer-menu-mode-hook on entry if non-nil.
+
+\\{electric-buffer-menu-mode-map}"
+ (interactive "P")
+ (let (select buffer)
+ (save-window-excursion
+ (save-window-excursion (list-buffers arg))
+ (setq buffer (window-buffer (Electric-pop-up-window "*Buffer List*")))
+ (unwind-protect
+ (progn
+ (set-buffer buffer)
+ (Electric-buffer-menu-mode)
+ (setq select
+ (catch 'electric-buffer-menu-select
+ (message "<<< Press Space to bury the buffer list >>>")
+ (if (= (setq unread-command-char (read-char)) ?\ )
+ (progn (setq unread-command-char -1)
+ (throw 'electric-buffer-menu-select nil)))
+ (let ((first (progn (goto-char (point-min))
+ (forward-line 2)
+ (point)))
+ (last (progn (goto-char (point-max))
+ (forward-line -1)
+ (point)))
+ (goal-column 0))
+ (goto-char first)
+ (Electric-command-loop 'electric-buffer-menu-select
+ nil
+ t
+ 'electric-buffer-menu-looper
+ (cons first last))))))
+ (set-buffer buffer)
+ (Buffer-menu-mode)
+ (bury-buffer buffer)
+ (message "")))
+ (if select
+ (progn (set-buffer buffer)
+ (let ((opoint (point-marker)))
+ (Buffer-menu-execute)
+ (goto-char (point-min))
+ (if (prog1 (search-forward "\n>" nil t)
+ (goto-char opoint) (set-marker opoint nil))
+ (Buffer-menu-select)
+ (switch-to-buffer (Buffer-menu-buffer t))))))))
+
+(defun electric-buffer-menu-looper (state condition)
+ (cond ((and condition
+ (not (memq (car condition) '(buffer-read-only
+ end-of-buffer
+ beginning-of-buffer))))
+ (signal (car condition) (cdr condition)))
+ ((< (point) (car state))
+ (goto-char (point-min))
+ (forward-line 2))
+ ((> (point) (cdr state))
+ (goto-char (point-max))
+ (forward-line -1)
+ (if (pos-visible-in-window-p (point-max))
+ (recenter -1)))))
+
+(put 'Electric-buffer-menu-mode 'mode-class 'special)
+(defun Electric-buffer-menu-mode ()
+ "Major mode for editing a list of buffers.
+Each line describes one of the buffers in Emacs.
+Letters do not insert themselves; instead, they are commands.
+\\{electric-buffer-menu-mode-map}
+
+C-g or C-c C-c -- exit buffer menu, returning to previous window and buffer
+ configuration. If the very first character typed is a space, it
+ also has this effect.
+Space -- select buffer of line point is on.
+ Also show buffers marked with m in other windows,
+ deletes buffers marked with \"D\", and saves those marked with \"S\".
+m -- mark buffer to be displayed.
+~ -- clear modified-flag on that buffer.
+s -- mark that buffer to be saved.
+d or C-d -- mark that buffer to be deleted.
+u -- remove all kinds of marks from current line.
+v -- view buffer, returning when done.
+Delete -- back up a line and remove marks.
+
+
+Entry to this mode via command \\[electric-buffer-list] calls the value of
+electric-buffer-menu-mode-hook if it is non-nil."
+ (kill-all-local-variables)
+ (use-local-map electric-buffer-menu-mode-map)
+ (setq mode-name "Electric Buffer Menu")
+ (setq mode-line-buffer-identification "Electric Buffer List")
+ (if (memq 'mode-name mode-line-format)
+ (progn (setq mode-line-format (copy-sequence mode-line-format))
+ (setcar (memq 'mode-name mode-line-format) "Buffers")))
+ (make-local-variable 'Helper-return-blurb)
+ (setq Helper-return-blurb "return to buffer editing")
+ (setq truncate-lines t)
+ (setq buffer-read-only t)
+ (setq major-mode 'Electric-buffer-menu-mode)
+ (goto-char (point-min))
+ (if (search-forward "\n." nil t) (forward-char -1))
+ (run-hooks 'electric-buffer-menu-mode-hook))
+
+;; generally the same as Buffer-menu-mode-map
+;; (except we don't indirect to global-map)
+(put 'Electric-buffer-menu-undefined 'suppress-keymap t)
+(if electric-buffer-menu-mode-map
+ nil
+ (let ((map (make-keymap)))
+ (fillarray map 'Electric-buffer-menu-undefined)
+ (define-key map "\e" (make-keymap))
+ (fillarray (lookup-key map "\e") 'Electric-buffer-menu-undefined)
+ (define-key map "\C-z" 'suspend-emacs)
+ (define-key map "v" 'Electric-buffer-menu-mode-view-buffer)
+ (define-key map "\C-h" 'Helper-help)
+ (define-key map "?" 'Helper-describe-bindings)
+ (define-key map "\C-c" nil)
+ (define-key map "\C-c\C-c" 'Electric-buffer-menu-quit)
+ (define-key map "\C-]" 'Electric-buffer-menu-quit)
+ (define-key map "q" 'Electric-buffer-menu-quit)
+ (define-key map " " 'Electric-buffer-menu-select)
+ (define-key map "\C-l" 'recenter)
+ (define-key map "s" 'Buffer-menu-save)
+ (define-key map "d" 'Buffer-menu-delete)
+ (define-key map "k" 'Buffer-menu-delete)
+ (define-key map "\C-d" 'Buffer-menu-delete-backwards)
+ ;(define-key map "\C-k" 'Buffer-menu-delete)
+ (define-key map "\177" 'Buffer-menu-backup-unmark)
+ (define-key map "~" 'Buffer-menu-not-modified)
+ (define-key map "u" 'Buffer-menu-unmark)
+ (let ((i ?0))
+ (while (<= i ?9)
+ (define-key map (char-to-string i) 'digit-argument)
+ (define-key map (concat "\e" (char-to-string i)) 'digit-argument)
+ (setq i (1+ i))))
+ (define-key map "-" 'negative-argument)
+ (define-key map "\e-" 'negative-argument)
+ (define-key map "m" 'Buffer-menu-mark)
+ (define-key map "\C-u" 'universal-argument)
+ (define-key map "\C-p" 'previous-line)
+ (define-key map "\C-n" 'next-line)
+ (define-key map "p" 'previous-line)
+ (define-key map "n" 'next-line)
+ (define-key map "\C-v" 'scroll-up)
+ (define-key map "\ev" 'scroll-down)
+ (define-key map "\e\C-v" 'scroll-other-window)
+ (define-key map "\e>" 'end-of-buffer)
+ (define-key map "\e<" 'beginning-of-buffer)
+ (setq electric-buffer-menu-mode-map map)))
+
+(defun Electric-buffer-menu-exit ()
+ (interactive)
+ (setq unread-command-char last-input-char)
+ ;; for robustness
+ (condition-case ()
+ (throw 'electric-buffer-menu-select nil)
+ (error (Buffer-menu-mode)
+ (other-buffer))))
+
+(defun Electric-buffer-menu-select ()
+ "Leave Electric Buffer Menu, selecting buffers and executing changes.
+Saves buffers marked \"S\". Deletes buffers marked \"K\".
+Selects buffer at point and displays buffers marked \">\" in other
+windows."
+ (interactive)
+ (throw 'electric-buffer-menu-select (point)))
+
+(defun Electric-buffer-menu-quit ()
+ "Leave Electric Buffer Menu, restoring previous window configuration.
+Does not execute select, save, or delete commands."
+ (interactive)
+ (throw 'electric-buffer-menu-select nil))
+
+(defun Electric-buffer-menu-undefined ()
+ (interactive)
+ (ding)
+ (message (if (and (eq (key-binding "\C-c\C-c") 'Electric-buffer-menu-quit)
+ (eq (key-binding " ") 'Electric-buffer-menu-select)
+ (eq (key-binding "\C-h") 'Helper-help)
+ (eq (key-binding "?") 'Helper-describe-bindings))
+ "Type C-c C-c to exit, Space to select, C-h for help, ? for commands"
+ (substitute-command-keys "\
+Type \\[Electric-buffer-menu-quit] to exit, \
+\\[Electric-buffer-menu-select] to select, \
+\\[Helper-help] for help, \\[Helper-describe-bindings] for commands.")))
+ (sit-for 4))
+
+(defun Electric-buffer-menu-mode-view-buffer ()
+ "View buffer on current line in Electric Buffer Menu.
+Returns to Electric Buffer Menu when done."
+ (interactive)
+ (let ((bufnam (Buffer-menu-buffer nil)))
+ (if bufnam
+ (view-buffer bufnam)
+ (ding)
+ (message "Buffer %s does not exist!" bufnam)
+ (sit-for 4))))
+
+
+
+
diff --git a/lisp/ebuff-menu.elc b/lisp/ebuff-menu.elc
new file mode 100644
index 00000000000..e6963d1e4c3
--- /dev/null
+++ b/lisp/ebuff-menu.elc
Binary files differ
diff --git a/lisp/echistory.el b/lisp/echistory.el
index f50c4e66c91..692afadba66 100644
--- a/lisp/echistory.el
+++ b/lisp/echistory.el
@@ -24,7 +24,7 @@
(defun Electric-command-history-redo-expression (&optional noconfirm)
"Edit current history line in minibuffer and execute result.
-With prefix arg NOCONFIRM, execute current line as-is without editing."
+With prefix argument NOCONFIRM, execute current line as is without editing."
(interactive "P")
(let (todo)
(save-excursion
@@ -73,23 +73,35 @@ With prefix arg NOCONFIRM, execute current line as-is without editing."
(define-key electric-history-map "\e\C-v" 'scroll-other-window))
(defvar electric-command-history-hook nil
- "If non-nil, its value is called by `electric-command-history'.")
+ "If non-nil, its value is called by electric-command-history.")
(defun electric-command-history ()
- "\\<electric-history-map>Major mode for examining and redoing commands from `command-history'.
-This pops up a window with the Command History listing.
-The number of command listed is controlled by `list-command-history-max'.
-The command history is filtered by `list-command-history-filter' if non-nil.
+ "Major mode for examining and redoing commands from command-history.
+The number of command listed is controlled by list-command-history-max.
+The command history is filtered by list-command-history-filter if non-nil.
Combines typeout Command History list window with menu like selection
of an expression from the history for re-evaluation in the *original* buffer.
-The history displayed is filtered by `list-command-history-filter' if non-nil.
+The history displayed is filtered by list-command-history-filter if non-nil.
-Like Emacs-Lisp mode except that characters do not insert themselves and
-Tab and Linefeed do not indent. Instead these commands are provided:
-\\{electric-history-map}
+This pops up a window with the Command History listing. If the very
+next character typed is Space, the listing is killed and the previous
+window configuration is restored. Otherwise, you can browse in the
+Command History with Return moving down and Delete moving up, possibly
+selecting an expression to be redone with Space or quitting with `Q'.
-Calls the value of `electric-command-history-hook' if that is non-nil.
+Like Emacs-Lisp Mode except that characters do not insert themselves and
+Tab and linefeed do not indent. Instead these commands are provided:
+Space or ! edit then evaluate current line in history inside
+ the ORIGINAL buffer which invoked this mode.
+ The previous window configuration is restored
+ unless the invoked command changes it.
+C-c C-c, C-], Q Quit and restore previous window configuration.
+LFD, RET Move to the next line in the history.
+DEL Move to the previous line in the history.
+? Provides a complete list of commands.
+
+Calls the value of electric-command-history-hook if that is non-nil
The Command History listing is recomputed each time this mode is invoked."
(interactive)
(let ((electric-history-in-progress t)
diff --git a/lisp/echistory.elc b/lisp/echistory.elc
new file mode 100644
index 00000000000..12ecb8fd0f4
--- /dev/null
+++ b/lisp/echistory.elc
Binary files differ
diff --git a/lisp/edmacro.el b/lisp/edmacro.el
deleted file mode 100644
index a59edee69a0..00000000000
--- a/lisp/edmacro.el
+++ /dev/null
@@ -1,640 +0,0 @@
-;; Keyboard macro editor for GNU Emacs. Version 1.02.
-;; Copyright (C) 1990 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;; Original from: Dave Gillespie, daveg@csvax.caltech.edu.
-
-;; To use, type `M-x edit-last-kbd-macro' to edit the most recently
-;; defined keyboard macro. If you have used `M-x name-last-kbd-macro'
-;; to give a keyboard macro a name, type `M-x edit-kbd-macro' to edit
-;; the macro by name. When you are done editing, type `C-c C-c' to
-;; record your changes back into the original keyboard macro.
-
-;;; The user-level commands for editing macros.
-
-(defun edit-last-kbd-macro (&optional prefix buffer hook)
- "Edit the most recently defined keyboard macro."
- (interactive "P")
- (edmacro-edit-macro last-kbd-macro
- (function (lambda (x arg) (setq last-kbd-macro x)))
- prefix buffer hook))
-
-(defun edit-kbd-macro (cmd &optional prefix buffer hook in-hook out-hook)
- "Edit a keyboard macro which has been given a name by `name-last-kbd-macro'.
-\(See also `edit-last-kbd-macro'.)"
- (interactive "CCommand name: \nP")
- (and cmd
- (edmacro-edit-macro (if in-hook
- (funcall in-hook cmd)
- (symbol-function cmd))
- (or out-hook
- (list 'lambda '(x arg)
- (list 'fset
- (list 'quote cmd)
- 'x)))
- prefix buffer hook cmd)))
-
-(defun read-kbd-macro (start end)
- "Read the region as a keyboard macro definition.
-The region is interpreted as spelled-out keystrokes, e.g., \"M-x abc RET\".
-The resulting macro is installed as the \"current\" keyboard macro.
-
-Symbols: RET, SPC, TAB, DEL, LFD, NUL; C-key; M-key. (Must be uppercase.)
- REM marks the rest of a line as a comment.
- Whitespace is ignored; other characters are copied into the macro."
- (interactive "r")
- (setq last-kbd-macro (edmacro-parse-keys (buffer-substring start end)))
- (if (and (string-match "\\`\C-x(" last-kbd-macro)
- (string-match "\C-x)\\'" last-kbd-macro))
- (setq last-kbd-macro (substring last-kbd-macro 2 -2))))
-
-;;; Formatting a keyboard macro as human-readable text.
-
-(defun edmacro-print-macro (macro-str local-map)
- (let ((save-map (current-local-map))
- (print-escape-newlines t)
- key-symbol key-str key-last prefix-arg this-prefix)
- (unwind-protect
- (progn
- (use-local-map local-map)
- (while (edmacro-peek-char)
- (edmacro-read-key)
- (setq this-prefix prefix-arg)
- (or (memq key-symbol '(digit-argument
- negative-argument
- universal-argument))
- (null prefix-arg)
- (progn
- (cond ((consp prefix-arg)
- (insert (format "prefix-arg (%d)\n"
- (car prefix-arg))))
- ((eq prefix-arg '-)
- (insert "prefix-arg -\n"))
- ((numberp prefix-arg)
- (insert (format "prefix-arg %d\n" prefix-arg))))
- (setq prefix-arg nil)))
- (cond ((null key-symbol)
- (insert "type \"")
- (edmacro-insert-string macro-str)
- (insert "\"\n")
- (setq macro-str ""))
- ((eq key-symbol 'digit-argument)
- (edmacro-prefix-arg key-last nil prefix-arg))
- ((eq key-symbol 'negative-argument)
- (edmacro-prefix-arg ?- nil prefix-arg))
- ((eq key-symbol 'universal-argument)
- (let* ((c-u 4) (argstartchar key-last)
- (char (edmacro-read-char)))
- (while (= char argstartchar)
- (setq c-u (* 4 c-u)
- char (edmacro-read-char)))
- (edmacro-prefix-arg char c-u nil)))
- ((eq key-symbol 'self-insert-command)
- (insert "insert ")
- (if (and (>= key-last 32) (<= key-last 126))
- (let ((str ""))
- (while (or (and (eq key-symbol
- 'self-insert-command)
- (< (length str) 60)
- (>= key-last 32)
- (<= key-last 126))
- (and (memq key-symbol
- '(backward-delete-char
- delete-backward-char
- backward-delete-char-untabify))
- (> (length str) 0)))
- (if (eq key-symbol 'self-insert-command)
- (setq str (concat str
- (char-to-string key-last)))
- (setq str (substring str 0 -1)))
- (edmacro-read-key))
- (insert "\"" str "\"\n")
- (edmacro-unread-chars key-str))
- (insert "\"")
- (edmacro-insert-string (char-to-string key-last))
- (insert "\"\n")))
- ((and (eq key-symbol 'quoted-insert)
- (edmacro-peek-char))
- (insert "quoted-insert\n")
- (let ((ch (edmacro-read-char))
- ch2)
- (if (and (>= ch ?0) (<= ch ?7))
- (progn
- (setq ch (- ch ?0)
- ch2 (edmacro-read-char))
- (if ch2
- (if (and (>= ch2 ?0) (<= ch2 ?7))
- (progn
- (setq ch (+ (* ch 8) (- ch2 ?0))
- ch2 (edmacro-read-char))
- (if ch2
- (if (and (>= ch2 ?0) (<= ch2 ?7))
- (setq ch (+ (* ch 8) (- ch2 ?0)))
- (edmacro-unread-chars ch2))))
- (edmacro-unread-chars ch2)))))
- (if (or (and (>= ch ?0) (<= ch ?7))
- (< ch 32) (> ch 126))
- (insert (format "type \"\\%03o\"\n" ch))
- (insert "type \"" (char-to-string ch) "\"\n"))))
- ((memq key-symbol '(isearch-forward
- isearch-backward
- isearch-forward-regexp
- isearch-backward-regexp))
- (insert (symbol-name key-symbol) "\n")
- (edmacro-isearch-argument))
- ((eq key-symbol 'execute-extended-command)
- (edmacro-read-argument obarray 'commandp))
- (t
- (let ((cust (get key-symbol 'edmacro-print)))
- (if cust
- (funcall cust)
- (insert (symbol-name key-symbol))
- (indent-to 30)
- (insert " # ")
- (edmacro-insert-string key-str)
- (insert "\n")
- (let ((int (edmacro-get-interactive key-symbol)))
- (if (string-match "\\`\\*" int)
- (setq int (substring int 1)))
- (while (> (length int) 0)
- (cond ((= (aref int 0) ?a)
- (edmacro-read-argument
- obarray nil))
- ((memq (aref int 0) '(?b ?B ?D ?f ?F ?n
- ?s ?S ?x ?X))
- (edmacro-read-argument))
- ((and (= (aref int 0) ?c)
- (edmacro-peek-char))
- (insert "type \"")
- (edmacro-insert-string
- (char-to-string
- (edmacro-read-char)))
- (insert "\"\n"))
- ((= (aref int 0) ?C)
- (edmacro-read-argument
- obarray 'commandp))
- ((= (aref int 0) ?k)
- (edmacro-read-key)
- (if key-symbol
- (progn
- (insert "type \"")
- (edmacro-insert-string key-str)
- (insert "\"\n"))
- (edmacro-unread-chars key-str)))
- ((= (aref int 0) ?N)
- (or this-prefix
- (edmacro-read-argument)))
- ((= (aref int 0) ?v)
- (edmacro-read-argument
- obarray 'user-variable-p)))
- (let ((nl (string-match "\n" int)))
- (setq int (if nl
- (substring int (1+ nl))
- "")))))))))))
- (use-local-map save-map))))
-
-(defun edmacro-prefix-arg (char c-u value)
- (let ((sign 1))
- (if (and (numberp value) (< value 0))
- (setq sign -1 value (- value)))
- (if (eq value '-)
- (setq sign -1 value nil))
- (while (and char (= ?- char))
- (setq sign (- sign) c-u nil)
- (setq char (edmacro-read-char)))
- (while (and char (>= char ?0) (<= char ?9))
- (setq value (+ (* (if (numberp value) value 0) 10) (- char ?0)) c-u nil)
- (setq char (edmacro-read-char)))
- (setq prefix-arg
- (cond (c-u (list c-u))
- ((numberp value) (* value sign))
- ((= sign -1) '-)))
- (edmacro-unread-chars char)))
-
-(defun edmacro-insert-string (str)
- (let ((i 0) j ch)
- (while (< i (length str))
- (if (and (> (setq ch (aref str i)) 127)
- (< ch 160))
- (progn
- (setq ch (- ch 128))
- (insert "\\M-")))
- (if (< ch 32)
- (cond ((= ch 8) (insret "\\b"))
- ((= ch 9) (insert "\\t"))
- ((= ch 10) (insert "\\n"))
- ((= ch 13) (insert "\\r"))
- ((= ch 27) (insert "\\e"))
- (t (insert "\\C-" (char-to-string (downcase (+ ch 64))))))
- (if (< ch 127)
- (if (or (= ch 34) (= ch 92))
- (insert "\\" (char-to-string ch))
- (setq j i)
- (while (and (< (setq i (1+ i)) (length str))
- (>= (setq ch (aref str i)) 32)
- (/= ch 34) (/= ch 92)
- (< ch 127)))
- (insert (substring str j i))
- (setq i (1- i)))
- (if (memq ch '(127 255))
- (insert (format "\\%03o" ch))
- (insert "\\M-" (char-to-string (- ch 128))))))
- (setq i (1+ i)))))
-
-(defun edmacro-lookup-key (map)
- (let ((loc (and map (lookup-key map macro-str)))
- (glob (lookup-key (current-global-map) macro-str))
- (loc-str macro-str)
- (glob-str macro-str))
- (and (integerp loc)
- (setq loc-str (substring macro-str 0 loc)
- loc (lookup-key map loc-str)))
- (and (consp loc)
- (setq loc nil))
- (or loc
- (setq loc-str ""))
- (and (integerp glob)
- (setq glob-str (substring macro-str 0 glob)
- glob (lookup-key (current-global-map) glob-str)))
- (and (consp glob)
- (setq glob nil))
- (or glob
- (setq glob-str ""))
- (if (> (length glob-str) (length loc-str))
- (setq key-symbol glob
- key-str glob-str)
- (setq key-symbol loc
- key-str loc-str))
- (setq key-last (and (> (length key-str) 0)
- (logand (aref key-str (1- (length key-str))) 127)))
- key-symbol))
-
-(defun edmacro-read-argument (&optional obarray pred) ;; currently ignored
- (let ((str "")
- (min-bsp 0)
- (exec (eq key-symbol 'execute-extended-command))
- str-base)
- (while (progn
- (edmacro-lookup-key (current-global-map))
- (or (and (eq key-symbol 'self-insert-command)
- (< (length str) 60))
- (memq key-symbol
- '(backward-delete-char
- delete-backward-char
- backward-delete-char-untabify))
- (eq key-last 9)))
- (setq macro-str (substring macro-str (length key-str)))
- (or (and (eq key-last 9)
- obarray
- (let ((comp (try-completion str obarray pred)))
- (and (stringp comp)
- (> (length comp) (length str))
- (setq str comp))))
- (if (or (eq key-symbol 'self-insert-command)
- (and (or (eq key-last 9)
- (<= (length str) min-bsp))
- (setq min-bsp (+ (length str) (length key-str)))))
- (setq str (concat str key-str))
- (setq str (substring str 0 -1)))))
- (setq str-base str
- str (concat str key-str)
- macro-str (substring macro-str (length key-str)))
- (if exec
- (let ((comp (try-completion str-base obarray pred)))
- (if (if (stringp comp)
- (and (commandp (intern comp))
- (setq str-base comp))
- (commandp (intern str-base)))
- (insert str-base "\n")
- (insert "execute-extended-command\n")
- (insert "type \"")
- (edmacro-insert-string str)
- (insert "\"\n")))
- (if (> (length str) 0)
- (progn
- (insert "type \"")
- (edmacro-insert-string str)
- (insert "\"\n"))))))
-
-(defun edmacro-isearch-argument ()
- (let ((str "")
- (min-bsp 0)
- ch)
- (while (and (setq ch (edmacro-read-char))
- (or (<= ch 127) (not search-exit-option))
- (not (eq ch search-exit-char))
- (or (eq ch search-repeat-char)
- (eq ch search-reverse-char)
- (eq ch search-delete-char)
- (eq ch search-yank-word-char)
- (eq ch search-yank-line-char)
- (eq ch search-quote-char)
- (eq ch ?\r)
- (eq ch ?\t)
- (not search-exit-option)
- (and (/= ch 127) (>= ch 32))))
- (if (and (eq ch search-quote-char)
- (edmacro-peek-char))
- (setq str (concat str (char-to-string ch)
- (char-to-string (edmacro-read-char)))
- min-bsp (length str))
- (if (or (and (< ch 127) (>= ch 32))
- (eq ch search-yank-word-char)
- (eq ch search-yank-line-char)
- (and (or (not (eq ch search-delete-char))
- (<= (length str) min-bsp))
- (setq min-bsp (1+ (length str)))))
- (setq str (concat str (char-to-string ch)))
- (setq str (substring str 0 -1)))))
- (if (eq ch search-exit-char)
- (if (= (length str) 0) ;; non-incremental search
- (progn
- (setq str (concat str (char-to-string ch)))
- (and (eq (edmacro-peek-char) ?\C-w)
- (progn
- (setq str (concat str "\C-w"))
- (edmacro-read-char)))
- (if (> (length str) 0)
- (progn
- (insert "type \"")
- (edmacro-insert-string str)
- (insert "\"\n")))
- (edmacro-read-argument)
- (setq str "")))
- (edmacro-unread-chars ch))
- (if (> (length str) 0)
- (progn
- (insert "type \"")
- (edmacro-insert-string str)
- (insert "\\e\"\n")))))
-
-;;; Get the next keystroke-sequence from the input stream.
-;;; Sets key-symbol, key-str, and key-last as a side effect.
-(defun edmacro-read-key ()
- (edmacro-lookup-key (current-local-map))
- (and key-symbol
- (setq macro-str (substring macro-str (length key-str)))))
-
-(defun edmacro-peek-char ()
- (and (> (length macro-str) 0)
- (aref macro-str 0)))
-
-(defun edmacro-read-char ()
- (and (> (length macro-str) 0)
- (prog1
- (aref macro-str 0)
- (setq macro-str (substring macro-str 1)))))
-
-(defun edmacro-unread-chars (chars)
- (and (integerp chars)
- (setq chars (char-to-string chars)))
- (and chars
- (setq macro-str (concat chars macro-str))))
-
-(defun edmacro-dump (mac)
- (set-mark-command nil)
- (insert "\n\n")
- (edmacro-print-macro mac (current-local-map)))
-
-;;; Parse a string of spelled-out keystrokes, as produced by key-description.
-
-(defun edmacro-parse-keys (str)
- (let ((pos 0)
- (mac "")
- part)
- (while (and (< pos (length str))
- (string-match "[^ \t\n]+" str pos))
- (setq pos (match-end 0)
- part (substring str (match-beginning 0) (match-end 0))
- mac (concat mac
- (if (and (> (length part) 2)
- (= (aref part 1) ?-)
- (= (aref part 0) ?M))
- (progn
- (setq part (substring part 2))
- "\e")
- (if (and (> (length part) 4)
- (= (aref part 0) ?C)
- (= (aref part 1) ?-)
- (= (aref part 2) ?M)
- (= (aref part 3) ?-))
- (progn
- (setq part (concat "C-" (substring part 4)))
- "\e")
- ""))
- (or (cdr (assoc part '( ( "NUL" . "\0" )
- ( "RET" . "\r" )
- ( "LFD" . "\n" )
- ( "TAB" . "\t" )
- ( "ESC" . "\e" )
- ( "SPC" . " " )
- ( "DEL" . "\177" )
- ( "C-?" . "\177" )
- ( "C-2" . "\0" )
- ( "C-SPC" . "\0") )))
- (and (equal part "REM")
- (setq pos (or (string-match "\n" str pos)
- (length str)))
- "")
- (and (= (length part) 3)
- (= (aref part 0) ?C)
- (= (aref part 1) ?-)
- (char-to-string (logand (aref part 2) 31)))
- part))))
- mac))
-
-;;; Parse a keyboard macro description in edmacro-print-macro's format.
-
-(defun edmacro-read-macro (&optional map)
- (or map (setq map (current-local-map)))
- (let ((macro-str ""))
- (while (not (progn
- (skip-chars-forward " \t\n")
- (eobp)))
- (cond ((looking-at "#")) ;; comment
- ((looking-at "prefix-arg[ \t]*-[ \t]*\n")
- (edmacro-append-chars "\C-u-"))
- ((looking-at "prefix-arg[ \t]*\\(-?[0-9]+\\)[ \t]*\n")
- (edmacro-append-chars (concat "\C-u" (edmacro-match-string 1))))
- ((looking-at "prefix-arg[ \t]*(\\([0-9]+\\))[ \t]*\n")
- (let ((val (string-to-int (edmacro-match-string 1))))
- (while (> val 1)
- (or (= (% val 4) 0)
- (error "Bad prefix argument value"))
- (edmacro-append-chars "\C-u")
- (setq val (/ val 4)))))
- ((looking-at "prefix-arg")
- (error "Bad prefix argument syntax"))
- ((looking-at "insert ")
- (forward-char 7)
- (edmacro-append-chars (read (current-buffer)))
- (if (< (current-column) 7)
- (forward-line -1)))
- ((looking-at "type ")
- (forward-char 5)
- (edmacro-append-chars (read (current-buffer)))
- (if (< (current-column) 5)
- (forward-line -1)))
- ((looking-at "keys \\(.*\\)\n")
- (goto-char (1- (match-end 0)))
- (edmacro-append-chars (edmacro-parse-keys
- (buffer-substring (match-beginning 1)
- (match-end 1)))))
- ((looking-at "\\([-a-zA-z0-9_]+\\)[ \t]*\\(.*\\)\n")
- (let* ((func (intern (edmacro-match-string 1)))
- (arg (edmacro-match-string 2))
- (cust (get func 'edmacro-read)))
- (if cust
- (funcall cust arg)
- (or (commandp func)
- (error "Not an Emacs command"))
- (or (equal arg "")
- (string-match "\\`#" arg)
- (error "Unexpected argument to command"))
- (let ((keys
- (or (where-is-internal func map t)
- (where-is-internal func (current-global-map) t))))
- (if keys
- (edmacro-append-chars keys)
- (edmacro-append-chars (concat "\ex"
- (symbol-name func)
- "\n")))))))
- (t (error "Syntax error")))
- (forward-line 1))
- macro-str))
-
-(defun edmacro-append-chars (chars)
- (setq macro-str (concat macro-str chars)))
-
-(defun edmacro-match-string (n)
- (if (match-beginning n)
- (buffer-substring (match-beginning n) (match-end n))
- ""))
-
-(defun edmacro-get-interactive (func)
- (if (symbolp func)
- (let ((cust (get func 'edmacro-interactive)))
- (if cust
- cust
- (edmacro-get-interactive (symbol-function func))))
- (or (and (eq (car-safe func) 'lambda)
- (let ((int (if (consp (nth 2 func))
- (nth 2 func)
- (nth 3 func))))
- (and (eq (car-safe int) 'interactive)
- (stringp (nth 1 int))
- (nth 1 int))))
- "")))
-
-(put 'search-forward 'edmacro-interactive "s")
-(put 'search-backward 'edmacro-interactive "s")
-(put 'word-search-forward 'edmacro-interactive "s")
-(put 'word-search-backward 'edmacro-interactive "s")
-(put 're-search-forward 'edmacro-interactive "s")
-(put 're-search-backward 'edmacro-interactive "s")
-(put 'switch-to-buffer 'edmacro-interactive "B")
-(put 'kill-buffer 'edmacro-interactive "B")
-(put 'rename-buffer 'edmacro-interactive "B\nB")
-(put 'goto-char 'edmacro-interactive "N")
-(put 'global-set-key 'edmacro-interactive "k\nC")
-(put 'global-unset-key 'edmacro-interactive "k")
-(put 'local-set-key 'edmacro-interactive "k\nC")
-(put 'local-unset-key 'edmacro-interactive "k")
-
-;;; Think about kbd-macro-query
-
-;;; Edit a keyboard macro in another buffer.
-;;; (Prefix argument is currently ignored.)
-
-(defun edmacro-edit-macro (mac repl &optional prefix buffer hook arg)
- (or (stringp mac)
- (error "Not a keyboard macro"))
- (let ((oldbuf (current-buffer))
- (local (current-local-map))
- (buf (get-buffer-create (or buffer "*Edit Macro*"))))
- (set-buffer buf)
- (kill-all-local-variables)
- (use-local-map edmacro-mode-map)
- (setq buffer-read-only nil
- major-mode 'edmacro-mode
- mode-name "Edit Macro")
- (set (make-local-variable 'edmacro-original-buffer) oldbuf)
- (set (make-local-variable 'edmacro-replace-function) repl)
- (set (make-local-variable 'edmacro-replace-argument) arg)
- (set (make-local-variable 'edmacro-finish-hook) hook)
- (erase-buffer)
- (insert "# Keyboard Macro Editor. Press C-c C-c to finish; press C-x k RET to cancel.\n")
- (insert "# Original keys: " (key-description mac) "\n\n")
- (message "Formatting keyboard macro...")
- (edmacro-print-macro mac local)
- (switch-to-buffer buf)
- (goto-char (point-min))
- (forward-line 3)
- (recenter '(4))
- (set-buffer-modified-p nil)
- (message "Formatting keyboard macro...done")
- (run-hooks 'edmacro-format-hook)))
-
-(defun edmacro-finish-edit ()
- (interactive)
- (or (and (boundp 'edmacro-original-buffer)
- (boundp 'edmacro-replace-function)
- (boundp 'edmacro-replace-argument)
- (boundp 'edmacro-finish-hook)
- (eq major-mode 'edmacro-mode))
- (error "This command is valid only in buffers created by `edit-kbd-macro'."))
- (let ((buf (current-buffer))
- (str (buffer-string))
- (func edmacro-replace-function)
- (arg edmacro-replace-argument)
- (hook edmacro-finish-hook))
- (goto-char (point-min))
- (run-hooks 'edmacro-compile-hook)
- (and (buffer-modified-p)
- func
- (progn
- (message "Compiling keyboard macro...")
- (let ((mac (edmacro-read-macro
- (and (buffer-name edmacro-original-buffer)
- (save-excursion
- (set-buffer edmacro-original-buffer)
- (current-local-map))))))
- (and (buffer-name edmacro-original-buffer)
- (switch-to-buffer edmacro-original-buffer))
- (funcall func mac arg))
- (message "Compiling keyboard macro...done")))
- (kill-buffer buf)
- (if hook
- (funcall hook arg))))
-
-(defun edmacro-mode ()
- "\\<edmacro-mode-map>Keyboard Macro Editing mode. Press \\[edmacro-finish-edit] to save and exit.
-To abort the edit, just kill this buffer with \\[kill-buffer] RET.
-
-The keyboard macro is represented as a series of M-x style command names.
-Keystrokes which do not correspond to simple M-x commands are written as
-\"type\" commands. When you press \\[edmacro-finish-edit], edmacro converts each command
-back into a suitable keystroke sequence; \"type\" commands are converted
-directly back into keystrokes."
- (interactive)
- (error "This mode can be enabled only by `edit-kbd-macro' or `edit-last-kbd-macro'."))
-(put 'edmacro-mode 'mode-class 'special)
-
-(if (boundp 'edmacro-mode-map) ()
- (setq edmacro-mode-map (make-sparse-keymap))
- (define-key edmacro-mode-map "\C-c\C-c" 'edmacro-finish-edit))
diff --git a/lisp/edt-doc.el b/lisp/edt-doc.el
new file mode 100644
index 00000000000..30cbc14799d
--- /dev/null
+++ b/lisp/edt-doc.el
@@ -0,0 +1,106 @@
+;; From mike@yetti.UUCP Fri Aug 29 12:49:28 1986
+;; Path: mit-prep!mit-hermes!mit-eddie!genrad!panda!husc6!seismo!mnetor!yetti!mike
+;; From: mike@yetti.UUCP (Mike Clarkson )
+;; Newsgroups: net.sources
+;; Subject: Gnu Emacs EDT Emulation - Introduction - 1/3
+;; Date: 27 Aug 86 23:30:33 GMT
+;; Reply-To: mike@yetti.UUCP (Mike Clarkson )
+;; Organization: York University Computer Science
+;;
+;; Here's my EDT emulation for GNU Emacs that is based on the EDT emulation
+;; for Gosling's Emacs sent out on the net a couple of years ago by Lynn Olson
+;; at Tektronics. This emulation was widely distributed as the file edt.ml
+;; in the maclib directory of most Emacs distributions.
+;;
+;; My emulation consists of two files: edt.el and edtdoc.el. The edtdoc.el file
+;; is the documentation, that you can add to the beginning of edt.el if you
+;; want. I have split them because I have been loading the edt.el file a lot
+;; during debugging.
+;;
+;; I will gladly take all criticisms and complaints to heart, and will fix
+;; what bugs I can find. As this is my first elisp hack, you may have to
+;; root out a few nasties hidden in the code. Please let me know if you
+;; find any (sorry,
+;; no rewards :-). I would also be interested if there are better,
+;; cleaner, faster ways of doing some of the things that I have done.
+;;
+;; You must understand some design considerations that I had in mind.
+;; The intention was not really to "emulate" EDT, but rather to take advantage
+;; of the years of EDT experience that had accumulated in my right hand,
+;; while at the same time taking advantage of EMACS.
+;;
+;; Some major differences are:
+;;
+;; HELP is describe-key;
+;; GOLD/HELP is describe-function;
+;; FIND is isearch-forward/backward;
+;; GOLD/HELP is occur-menu, which finds all occurrences of a search string;
+;; ENTER is other-window;
+;; SUBS is subprocess-command. Note that you will have to change this
+;; yourself to shell if you are running Un*x;
+;; PAGE is next-paragraph, because that's more useful than page.
+;; SPECINS is copy-to-killring;
+;; GOLD/GOLD is mark-section-wisely, which is my command to mark the
+;; section in a manner consistent with the major-mode. It
+;; uses mark-defun for emacs-lisp, lisp, mark-c-function for C,
+;; and mark-paragraph for other modes.
+;;
+;;
+;; Some subtle differences are:
+;;
+;; APPEND is append-to-buffer. One doesn't append to the kill ring much
+;; and SPECINS is now copy-to-killring;
+;; REPLACE is replace-regexp;
+;; FILL is fill-region-wisely, which uses indent-region for C, lisp
+;; emacs-lisp, and fill-region for others. It asks if you really
+;; want to fill-region in TeX-mode, because I find this to be
+;; very dangerous.
+;; CHNGCASE is case-flip for the character under the cursor only.
+;; I felt that case-flip region is unlikely, as usually you
+;; upcase-region or downcase region. Also, unlike EDT it
+;; is independent of the direction you are going, as that
+;; drives me nuts.
+;;
+;; I use Emacs definition of what a word is. This is considerably different from
+;; what EDT thinks a word is. This is not good for dyed-in-the-wool EDT fans,
+;; but is probably preferable for experienced Emacs users. My assumption is that
+;; the former are a dying breed now that GNU Emacs has made it to VMS, but let me
+;; know how you feel. Also, when you undelete a word it leave the point at the
+;; end of the undeleted text, rather than the beginning. I might change this
+;; as I'm not sure if I like this or not. I'm also not sure if I want it to
+;; set the mark each time you delete a character or word.
+;;
+;; Backspace does not invoke beginning-of-line, because ^H is the help prefix,
+;; and I felt it should be left as such. You can change this if you like.
+;;
+;; The ADVANCE and BACKUP keys do not work as terminators for forward or
+;; backward searches. In Emacs, all search strings are terminated by return.
+;; The searches will however go forward or backward depending on your current
+;; direction. Also, when you change directions, the mode line will not be
+;; updated immediately, but only when you next execute an emacs function.
+;; Personally, I consider this to be a bug, not a feature.
+;;
+;; This should also work with VT-2xx's, though I haven't tested it extensively
+;; on those terminals. It assumes that the CSI-map of vt_200.el has been defined.
+;;
+;; There are also a whole bunch of GOLD letter, and GOLD character bindings:
+;; look at edtdoc.el for them, or better still, look at the edt.el lisp code,
+;; because after all, in the true Lisp tradition, the source code is *assumed*
+;; to be self-documenting :-)
+;;
+;; Mike Clarkson, ...!allegra \ BITNET: mike@YUYETTI or
+;; CRESS, York University, ...!decvax \ SYMALG@YUSOL
+;; 4700 Keele Street, ...!ihnp4 > !utzoo!yetti!mike
+;; North York, Ontario, ...!linus /
+;; CANADA M3J 1P3. ...!watmath / Phone: +1 (416) 736-2100 x 7767
+;;
+;; Note that I am not on ARPA, and must gateway any ARPA mail through BITNET or
+;; UUCP. If you have a UUCP or BITNET address please use it for communication
+;; so that I can reach you directly. If you have both, the BITNET address
+;; is preferred.
+;; --
+;; Mike Clarkson, ...!allegra \ BITNET: mike@YUYETTI or
+;; CRESS, York University, ...!decvax \ SYMALG@YUSOL
+;; 4700 Keele Street, ...!ihnp4 > !utzoo!yetti!mike
+;; North York, Ontario, ...!linus /
+;; CANADA M3J 1P3. ...!watmath / Phone: +1 (416) 737-2100 x 7767
diff --git a/lisp/emulation/edt.el b/lisp/edt.el
index 5a2611d9460..8bacf8ef464 100644
--- a/lisp/emulation/edt.el
+++ b/lisp/edt.el
@@ -21,16 +21,16 @@
(require 'keypad)
(defvar edt-last-deleted-lines ""
- "Last text deleted by an EDT emulation `line-delete' command.")
+ "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.")
+ "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.")
+ "Last text deleted by an EDT emulation character-delete command.")
(defun 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 EDT `undelete-lines' command."
+They are saved for the EDT undelete-lines command."
(interactive "p")
(let ((beg (point)))
(forward-line num)
@@ -43,7 +43,7 @@ They are saved for the EDT `undelete-lines' command."
(defun 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 EDT `undelete-lines' command."
+They are saved for the EDT undelete-lines command."
(interactive "p")
(let ((beg (point)))
(forward-char 1)
@@ -54,7 +54,7 @@ They are saved for the EDT `undelete-lines' command."
(defun delete-current-word (num)
"Delete one or specified number of words after point.
-They are saved for the EDT `undelete-words' command."
+They are saved for the EDT undelete-words command."
(interactive "p")
(let ((beg (point)))
(forward-word num)
@@ -62,9 +62,9 @@ They are saved for the EDT `undelete-words' command."
(buffer-substring beg (point)))
(delete-region beg (point))))
-(defun edt-delete-previous-word (num)
+(defun delete-previous-word (num)
"Delete one or specified number of words before point.
-They are saved for the EDT `undelete-words' command."
+They are saved for the EDT undelete-words command."
(interactive "p")
(let ((beg (point)))
(forward-word (- num))
@@ -74,7 +74,7 @@ They are saved for the EDT `undelete-words' command."
(defun delete-current-char (num)
"Delete one or specified number of characters after point.
-They are saved for the EDT `undelete-chars' command."
+They are saved for the EDT undelete-chars command."
(interactive "p")
(setq edt-last-deleted-chars
(buffer-substring (point) (min (point-max) (+ (point) num))))
@@ -82,24 +82,24 @@ They are saved for the EDT `undelete-chars' command."
(defun delete-previous-char (num)
"Delete one or specified number of characters before point.
-They are saved for the EDT `undelete-chars' command."
+They are saved for the EDT undelete-chars command."
(interactive "p")
(setq edt-last-deleted-chars
(buffer-substring (max (point-min) (- (point) num)) (point)))
(delete-region (max (point-min) (- (point) num)) (point)))
(defun undelete-lines ()
- "Yank lines deleted by last EDT `line-delete' command."
+ "Yank lines deleted by last EDT line-deletion command."
(interactive)
(insert edt-last-deleted-lines))
(defun undelete-words ()
- "Yank words deleted by last EDT `word-delete' command."
+ "Yank words deleted by last EDT word-deletion command."
(interactive)
(insert edt-last-deleted-words))
(defun undelete-chars ()
- "Yank characters deleted by last EDT `character-delete' command."
+ "Yank characters deleted by last EDT character-deletion command."
(interactive)
(insert edt-last-deleted-chars))
@@ -185,7 +185,7 @@ Accepts a prefix argument for the number of paragraphs."
(goto-char (/ (* (point-max) perc) 100))))
(defun update-mode-line ()
- "Ensure mode-line reflects all changes."
+ "Make sure mode-line in the current buffer reflects all changes."
(set-buffer-modified-p (buffer-modified-p))
(sit-for 0))
@@ -215,17 +215,17 @@ Accepts a prefix argument for the number of paragraphs."
(define-key function-keymap "0" 'backward-line) ; "0"
(update-mode-line))
-(defun edt-beginning-of-window ()
+(defun beginning-of-window ()
"Home cursor to top of window."
(interactive)
(move-to-window-line 0))
-(defun edt-line-to-bottom-of-window ()
+(defun line-to-bottom-of-window ()
"Move the current line to the top of the window."
(interactive)
(recenter -1))
-(defun edt-line-to-top-of-window ()
+(defun line-to-top-of-window ()
"Move the current line to the top of the window."
(interactive)
(recenter 0))
@@ -264,11 +264,11 @@ and mark-paragraph for other modes."
;;; Key Bindings
(defun edt-emulation-on ()
- "Emulate DEC's EDT editor.
-Note that many keys are rebound; including nearly all keypad keys.
+ "Begin emulating DEC's EDT editor.
+Certain keys are rebound; including nearly all keypad keys.
Use \\[edt-emulation-off] to undo all rebindings except the keypad keys.
Note that this function does not work if called directly from the .emacs file.
-Instead, the .emacs file should do \"(setq term-setup-hook 'edt-emulation-on)\"
+Instead, the .emacs file should do (setq term-setup-hook 'edt-emulation-on)
Then this function will be called at the time when it will work."
(interactive)
(advance-direction)
@@ -281,7 +281,7 @@ Then this function will be called at the time when it will work."
(define-key emacs-lisp-mode-map "\177" 'delete-previous-char) ;"Delete"
(define-key lisp-mode-map "\177" 'delete-previous-char) ;"Delete"
(setq edt-mode-old-linefeed (lookup-key global-map "\C-j"))
- (global-set-key "\C-j" 'edt-delete-previous-word) ;"LineFeed"
+ (global-set-key "\C-j" 'delete-previous-word) ;"LineFeed"
(define-key esc-map "?" 'apropos)) ;"<ESC>?"
(defun edt-emulation-off ()
@@ -299,7 +299,7 @@ The keys redefined by \\[edt-emulation-on] are given their old definitions."
(define-key function-keymap "d" 'next-line) ;down arrow
(define-key function-keymap "l" 'backward-char) ;right arrow
(define-key function-keymap "r" 'forward-char) ;left arrow
-(define-key function-keymap "h" 'edt-beginning-of-window) ;home
+(define-key function-keymap "h" 'beginning-of-window) ;home
(define-key function-keymap "\C-b" 'describe-key) ;PF2
(define-key function-keymap "\C-d" 'delete-current-line);PF4
(define-key function-keymap "9" 'append-to-buffer) ;9 keypad key, etc.
@@ -312,10 +312,11 @@ The keys redefined by \\[edt-emulation-on] are given their old definitions."
(define-key function-keymap "e" 'other-window) ;enter key
(define-key function-keymap "\C-a" 'GOLD-prefix) ;PF1 ("gold")
+(setq GOLD-map (make-keymap))
(fset 'GOLD-prefix GOLD-map)
-(defvar GOLD-map (make-keymap)
- "`GOLD-map' maps the function keys on the VT100 keyboard preceeded
+(defvar GOLD-map nil
+ "GOLD-map maps the function keys on the VT100 keyboard preceeded
by the PF1 key. GOLD is the ASCII the 7-bit escape sequence <ESC>OP.")
(defun define-keypad-key (keymap function-keymap-slot definition)
@@ -365,8 +366,8 @@ by the PF1 key. GOLD is the ASCII the 7-bit escape sequence <ESC>OP.")
;Bind GOLD/Keypad keys
(defun edt-bind-gold-keypad ()
- (define-keypad-key GOLD-map ?u 'edt-line-to-top-of-window) ;"up-arrow"
- (define-keypad-key GOLD-map ?d 'edt-line-to-bottom-of-window) ;"down-arrow"
+ (define-keypad-key GOLD-map ?u 'line-to-top-of-window) ;"up-arrow"
+ (define-keypad-key GOLD-map ?d 'line-to-bottom-of-window) ;"down-arrow"
(define-keypad-key GOLD-map ?l 'backward-sentence) ;"left-arrow"
(define-keypad-key GOLD-map ?r 'forward-sentence) ;"right-arrow"
(define-keypad-key GOLD-map ?\C-a 'mark-section-wisely) ;Gold "PF1"
diff --git a/lisp/edt.elc b/lisp/edt.elc
new file mode 100644
index 00000000000..6a0a77a3c30
--- /dev/null
+++ b/lisp/edt.elc
Binary files differ
diff --git a/lisp/ehelp.el b/lisp/ehelp.el
index 9755bf07b7c..48c6c5b1692 100644
--- a/lisp/ehelp.el
+++ b/lisp/ehelp.el
@@ -20,7 +20,8 @@
(provide 'ehelp)
(defvar electric-help-map ()
- "Keymap defining commands available in `electric-help-mode'.")
+ "Keymap defining commands available whilst scrolling
+through a buffer in electric-help-mode")
(put 'electric-help-undefined 'suppress-keymap t)
(if electric-help-map
@@ -44,8 +45,8 @@
(setq electric-help-map map)))
(defun electric-help-mode ()
- "`with-electric-help' temporarily places its buffer in this mode.
-\(On exit from `with-electric-help', the buffer is put in `default-major-mode'.)"
+ "with-electric-help temporarily places its buffer in this mode
+\(On exit from with-electric-help, the buffer is put in default-major-mode)"
(setq buffer-read-only t)
(setq mode-name "Help")
(setq major-mode 'help)
@@ -56,59 +57,71 @@
)
(defun with-electric-help (thunk &optional buffer noerase)
- "Arguments are THUNK &optional BUFFER NOERASE. BUFFER defaults to \"*Help*\"
-THUNK is a function of no arguments which is called to initialize
-the contents of BUFFER. BUFFER will be erased before THUNK is called unless
-NOERASE is non-nil. THUNK will be called with `standard-output' bound to
-the buffer specified by BUFFER
+ "Arguments are THUNK &optional BUFFER NOERASE.
+BUFFER defaults to \"*Help*\"
+THUNK is a function of no arguments which is called to initialise
+ the contents of BUFFER. BUFFER will be erased before THUNK is called unless
+ NOERASE is non-nil. THUNK will be called with standard-output bound to
+ the buffer specified by BUFFER
After THUNK has been called, this function \"electrically\" pops up a window
in which BUFFER is displayed and allows the user to scroll through that buffer
in electric-help-mode.
-When the user exits (with `electric-help-exit', or otherwise) the help
-buffer's window disappears (i.e., we use `save-window-excursion')
-BUFFER is put into `default-major-mode' (or `fundamental-mode') when we exit"
+When the user exits (with electric-help-exit, or otherwise) the help
+buffer's window disappears (ie we use save-window-excursion)
+BUFFER is put into default-major-mode (or fundamental-mode) when we exit"
(setq buffer (get-buffer-create (or buffer "*Help*")))
(let ((one (one-window-p t))
- (config (current-window-configuration))
- (bury nil))
- (unwind-protect
- (save-excursion
- (if one (goto-char (window-start (selected-window))))
- (let ((pop-up-windows t))
- (pop-to-buffer buffer))
- (save-excursion
- (set-buffer buffer)
- (electric-help-mode)
- (setq buffer-read-only nil)
- (or noerase (erase-buffer)))
- (let ((standard-output buffer))
- (if (not (funcall thunk))
- (progn
- (set-buffer buffer)
- (set-buffer-modified-p nil)
- (goto-char (point-min))
- (if one (shrink-window-if-larger-than-buffer (selected-window))))))
- (set-buffer buffer)
- (run-hooks 'electric-help-mode-hook)
- (if (eq (car-safe (electric-help-command-loop))
- 'retain)
- (setq config (current-window-configuration))
- (setq bury t)))
- (message "")
- (set-buffer buffer)
- (setq buffer-read-only nil)
- (condition-case ()
- (funcall (or default-major-mode 'fundamental-mode))
- (error nil))
- (set-window-configuration config)
- (if bury
- (progn
- ;;>> Perhaps this shouldn't be done.
- ;; so that when we say "Press space to bury" we mean it
- (replace-buffer-in-windows buffer)
- ;; must do this outside of save-window-excursion
- (bury-buffer buffer))))))
+ (two nil))
+ (save-window-excursion
+ (save-excursion
+ (if one (goto-char (window-start (selected-window))))
+ (let ((pop-up-windows t))
+ (pop-to-buffer buffer))
+ (unwind-protect
+ (progn
+ (save-excursion
+ (set-buffer buffer)
+ (electric-help-mode)
+ (setq buffer-read-only nil)
+ (or noerase (erase-buffer)))
+ (let ((standard-output buffer))
+ (if (funcall thunk)
+ ()
+ (set-buffer buffer)
+ (set-buffer-modified-p nil)
+ (goto-char (point-min))
+ (if one (shrink-window-if-larger-than-buffer (selected-window)))))
+ (set-buffer buffer)
+ (run-hooks 'electric-help-mode-hook)
+ (setq two (electric-help-command-loop))
+ (cond ((eq (car-safe two) 'retain)
+ (setq two (vector (window-height (selected-window))
+ (window-start (selected-window))
+ (window-hscroll (selected-window))
+ (point))))
+ (t (setq two nil))))
+
+ (message "")
+ (set-buffer buffer)
+ (setq buffer-read-only nil)
+ (condition-case ()
+ (funcall (or default-major-mode 'fundamental-mode))
+ (error nil)))))
+ (if two
+ (let ((pop-up-windows t)
+ tem)
+ (pop-to-buffer buffer)
+ (setq tem (- (window-height (selected-window)) (elt two 0)))
+ (if (> tem 0) (shrink-window tem))
+ (set-window-start (selected-window) (elt two 1) t)
+ (set-window-hscroll (selected-window) (elt two 2))
+ (goto-char (elt two 3)))
+ ;;>> Perhaps this shouldn't be done.
+ ;; so that when we say "Press space to bury" we mean it
+ (replace-buffer-in-windows buffer)
+ ;; must do this outside of save-window-excursion
+ (bury-buffer buffer))))
(defun electric-help-command-loop ()
(catch 'exit
@@ -164,13 +177,29 @@ BUFFER is put into `default-major-mode' (or `fundamental-mode') when we exit"
(throw 'exit t))
(defun electric-help-retain ()
- "Exit `electric-help', retaining the current window/buffer configuration.
+ "Exit electric-help, retaining the current window/buffer conifiguration.
\(The *Help* buffer will not be selected, but \\[switch-to-buffer-other-window] RET
will select it.)"
(interactive)
(throw 'exit '(retain)))
+;(defun electric-help-undefined ()
+; (interactive)
+; (let* ((keys (this-command-keys))
+; (n (length keys)))
+; (if (or (= n 1)
+; (and (= n 2)
+; meta-flag
+; (eq (aref keys 0) meta-prefix-char)))
+; (setq unread-command-char last-input-char
+; current-prefix-arg prefix-arg)
+; ;;>>> I don't care.
+; ;;>>> The emacs command-loop is too much pure pain to
+; ;;>>> duplicate
+; ))
+; (throw 'exit t))
+
(defun electric-help-undefined ()
(interactive)
(error "%s is undefined -- Press %s to exit"
@@ -286,6 +315,7 @@ will select it.)"
;(define-key help-map "a" 'electric-command-apropos)
+
;;;; ehelp-map
@@ -305,3 +335,4 @@ will select it.)"
(fset 'ehelp-command map)))
;; Do (define-key global-map "\C-h" 'ehelp-command) if you want to win
+
diff --git a/lisp/ehelp.elc b/lisp/ehelp.elc
new file mode 100644
index 00000000000..552d79a2455
--- /dev/null
+++ b/lisp/ehelp.elc
Binary files differ
diff --git a/lisp/electric.el b/lisp/electric.el
index be992c60f0d..a10adb1dca7 100644
--- a/lisp/electric.el
+++ b/lisp/electric.el
@@ -31,8 +31,7 @@
(n 0)
(window-min-height 0)
(buffer-read-only nil)
- (modified (buffer-modified-p))
- (buffer (current-buffer)))
+ (modified (buffer-modified-p)))
(unwind-protect
(progn
(select-window window)
@@ -45,10 +44,8 @@
(delete-region (point-min) (point))
(set-buffer-modified-p modified)
(goto-char p)
- (select-window w)
- ;; Make sure we unbind buffer-read-only
- ;; with the proper current buffer.
- (set-buffer buffer)))))
+ (select-window w)))))
+
;; This loop is the guts for non-standard modes which retain control
;; until some event occurs. It is a `do-forever', the only way out is to
diff --git a/lisp/electric.elc b/lisp/electric.elc
new file mode 100644
index 00000000000..15323a2ed9e
--- /dev/null
+++ b/lisp/electric.elc
Binary files differ
diff --git a/lisp/emacs-lisp/ring.el b/lisp/emacs-lisp/ring.el
deleted file mode 100644
index 69b1d1995ac..00000000000
--- a/lisp/emacs-lisp/ring.el
+++ /dev/null
@@ -1,101 +0,0 @@
-;;; Ring Code
-;;;============================================================================
-;;; This code defines a ring data structure. A ring is a
-;;; (hd-index tl-index . vector)
-;;; list. You can insert to, remove from, and rotate a ring. When the ring
-;;; fills up, insertions cause the oldest elts to be quietly dropped.
-;;;
-;;; HEAD = index of the newest item on the ring.
-;;; TAIL = index of the oldest item on the ring.
-;;;
-;;; These functions are used by the input history mechanism, but they can
-;;; be used for other purposes as well.
-
-(provide 'history)
-
-(defun ring-p (x)
- "T if X is a ring; NIL otherwise."
- (and (consp x) (integerp (car x))
- (consp (cdr x)) (integerp (car (cdr x)))
- (vectorp (cdr (cdr x)))))
-
-(defun make-ring (size)
- "Make a ring that can contain SIZE elts"
- (cons 1 (cons 0 (make-vector (+ size 1) nil))))
-
-(defun ring-plus1 (index veclen)
- "INDEX+1, with wraparound"
- (let ((new-index (+ index 1)))
- (if (= new-index veclen) 0 new-index)))
-
-(defun ring-minus1 (index veclen)
- "INDEX-1, with wraparound"
- (- (if (= 0 index) veclen index) 1))
-
-(defun ring-length (ring)
- "Number of elts in the ring."
- (let ((hd (car ring)) (tl (car (cdr ring))) (siz (length (cdr (cdr ring)))))
- (let ((len (if (<= hd tl) (+ 1 (- tl hd)) (+ 1 tl (- siz hd)))))
- (if (= len siz) 0 len))))
-
-(defun ring-empty-p (ring)
- (= 0 (ring-length ring)))
-
-(defun ring-insert (ring item)
- "Insert a new item onto the ring. If the ring is full, dump the oldest
-item to make room."
- (let* ((vec (cdr (cdr ring))) (len (length vec))
- (new-hd (ring-minus1 (car ring) len)))
- (setcar ring new-hd)
- (aset vec new-hd item)
- (if (ring-empty-p ring) ;overflow -- dump one off the tail.
- (setcar (cdr ring) (ring-minus1 (car (cdr ring)) len)))))
-
-(defun ring-remove (ring)
- "Remove the oldest item retained on the ring."
- (if (ring-empty-p ring) (error "Ring empty")
- (let ((tl (car (cdr ring))) (vec (cdr (cdr ring))))
- (set-car (cdr ring) (ring-minus1 tl (length vec)))
- (aref vec tl))))
-
-;;; This isn't actually used in this package. I just threw it in in case
-;;; someone else wanted it. If you want rotating-ring behavior on your history
-;;; retrieval (analagous to kill ring behavior), this function is what you
-;;; need. I should write the yank-input and yank-pop-input-or-kill to go with
-;;; this, and not bind it to a key by default, so it would be available to
-;;; people who want to bind it to a key. But who would want it? Blech.
-(defun ring-rotate (ring n)
- (if (not (= n 0))
- (if (ring-empty-p ring) ;Is this the right error check?
- (error "ring empty")
- (let ((hd (car ring)) (tl (car (cdr ring))) (vec (cdr (cdr ring))))
- (let ((len (length vec)))
- (while (> n 0)
- (setq tl (ring-plus1 tl len))
- (aset ring tl (aref ring hd))
- (setq hd (ring-plus1 hd len))
- (setq n (- n 1)))
- (while (< n 0)
- (setq hd (ring-minus1 hd len))
- (aset vec hd (aref vec tl))
- (setq tl (ring-minus1 tl len))
- (setq n (- n 1))))
- (set-car ring hd)
- (set-car (cdr ring) tl)))))
-
-(defun comint-mod (n m)
- "Returns N mod M. M is positive. Answer is guaranteed to be non-negative,
-and less than m."
- (let ((n (% n m)))
- (if (>= n 0) n
- (+ n
- (if (>= m 0) m (- m)))))) ; (abs m)
-
-(defun ring-ref (ring index)
- (let ((numelts (ring-length ring)))
- (if (= numelts 0) (error "indexed empty ring")
- (let* ((hd (car ring)) (tl (car (cdr ring))) (vec (cdr (cdr ring)))
- (index (comint-mod index numelts))
- (vec-index (comint-mod (+ index hd)
- (length vec))))
- (aref vec vec-index)))))
diff --git a/lisp/mail/emacsbug.el b/lisp/emacsbug.el
index 061fd30ee39..cf9ef90e89d 100644
--- a/lisp/mail/emacsbug.el
+++ b/lisp/emacsbug.el
@@ -25,7 +25,7 @@
;; >> internet with this address.
(defvar bug-gnu-emacs "bug-gnu-emacs@prep.ai.mit.edu"
- "Address of site maintaining mailing list for GNU Emacs bugs.")
+ "Address of site maintaining mailing list for Gnu emacs bugs.")
(defun report-emacs-bug (topic)
"Report a bug in Gnu emacs.
diff --git a/lisp/files.el b/lisp/files.el
new file mode 100644
index 00000000000..a283bd408dc
--- /dev/null
+++ b/lisp/files.el
@@ -0,0 +1,1080 @@
+;; File input and output commands for Emacs
+;; Copyright (C) 1985, 1986, 1987, 1990 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+(defconst delete-auto-save-files t
+ "*Non-nil means delete a buffer's auto-save file
+when the buffer is saved for real.")
+
+;(make-variable-buffer-local 'buffer-backed-up)
+;(defvar buffer-backed-up nil
+; "Non-nil if this buffer's file has been backed up.
+;Backing up is done before the first time the file is saved.")
+
+;;; Turn off backup files on VMS since it has version numbers.
+(defconst make-backup-files (not (eq system-type 'vax-vms))
+ "*Create a backup of each file when it is saved for the first time.
+This can be done by renaming the file or by copying.
+
+Renaming means that Emacs renames the existing file so that it is a
+backup file, then writes the buffer into a new file. Any other names
+that the old file had will now refer to the backup file.
+The new file is owned by you and its group is defaulted.
+
+Copying means that Emacs copies the existing file into the backup file,
+then writes the buffer on top of the existing file. Any other names
+that the old file had will now refer to the new (edited) file.
+The file's owner and group are unchanged.
+
+The choice of renaming or copying is controlled by the variables
+backup-by-copying, backup-by-copying-when-linked and
+backup-by-copying-when-mismatch.")
+
+(defconst backup-by-copying nil
+ "*Non-nil means always use copying to create backup files.
+See documentation of variable make-backup-files.")
+
+(defconst backup-by-copying-when-linked nil
+ "*Non-nil means use copying to create backups for files with multiple names.
+This causes the alternate names to refer to the latest version as edited.
+This variable is relevant only if backup-by-copying is nil.")
+
+(defconst backup-by-copying-when-mismatch nil
+ "*Non-nil means create backups by copying if this preserves owner or group.
+Renaming may still be used (subject to control of other variables)
+when it would not result in changing the owner or group of the file;
+that is, for files which are owned by you and whose group matches
+the default for a new file created there by you.
+This variable is relevant only if backup-by-copying is nil.")
+
+(defconst buffer-offer-save nil
+ "*Non-nil in a buffer means offer to save the buffer on exit
+even if the buffer is not visiting a file. Automatically local in
+all buffers.")
+(make-variable-buffer-local 'buffer-offer-save)
+
+(defconst file-precious-flag nil
+ "*Non-nil means protect against I/O errors while saving files.
+Some modes set this non-nil in particular buffers.")
+
+(defvar version-control nil
+ "*Control use of version numbers for backup files.
+t means make numeric backup versions unconditionally.
+nil means make them for files that have some already.
+never means do not make them.")
+
+(defvar dired-kept-versions 2
+ "*When cleaning directory, number of versions to keep.")
+
+(defvar trim-versions-without-asking nil
+ "*If true, deletes excess backup versions silently.
+Otherwise asks confirmation.")
+
+(defvar kept-old-versions 2
+ "*Number of oldest versions to keep when a new numbered backup is made.")
+
+(defvar kept-new-versions 2
+ "*Number of newest versions to keep when a new numbered backup is made.
+Includes the new backup. Must be > 0")
+
+(defconst require-final-newline nil
+ "*t says silently put a newline at the end whenever a file is saved.
+Non-nil but not t says ask user whether to add a newline in each such case.
+nil means don't add newlines.")
+
+(defconst auto-save-default t
+ "*t says by default do auto-saving of every file-visiting buffer.")
+
+(defconst auto-save-visited-file-name nil
+ "*t says auto-save a buffer in the file it is visiting, when practical.
+Normally auto-save files are written under other names.")
+
+(defconst save-abbrevs nil
+ "*Non-nil means save word abbrevs too when files are saved.
+Loading an abbrev file sets this to t.")
+
+(defconst find-file-run-dired t
+ "*Non-nil says run dired if find-file is given the name of a directory.")
+
+(defvar find-file-not-found-hooks nil
+ "List of functions to be called for find-file on nonexistent file.
+These functions are called as soon as the error is detected.
+buffer-file-name is already set up.
+The functions are called in the order given,
+until one of them returns non-nil.")
+
+(defvar find-file-hooks nil
+ "List of functions to be called after a buffer is loaded from a file.
+The buffer's local variables (if any) will have been processed before the
+functions are called.")
+
+(defvar write-file-hooks nil
+ "List of functions to be called before writing out a buffer to a file.
+If one of them returns non-nil, the file is considered already written
+and the rest are not called.")
+
+(defconst inhibit-local-variables nil
+ "*Non-nil means query before obeying a file's local-variables list.
+This applies when the local-variables list is scanned automatically
+after you find a file. If you explicitly request such a scan with
+\\[normal-mode], there is no query, regardless of this variable.")
+
+(defconst ignore-local-eval nil
+ "*Non-nil means ignore the \"variable\" `eval' in a file's local variables.
+This applies when the local-variables list is scanned automatically
+after you find a file. If you explicitly request such a scan with
+\\[normal-mode], there is no query, regardless of this variable.")
+
+;; Avoid losing in versions where CLASH_DETECTION is disabled.
+(or (fboundp 'lock-buffer)
+ (fset 'lock-buffer 'ignore))
+(or (fboundp 'unlock-buffer)
+ (fset 'unlock-buffer 'ignore))
+
+(defun pwd ()
+ "Show the current default directory."
+ (interactive nil)
+ (message "Directory %s" default-directory))
+
+(defun cd (dir)
+ "Make DIR become the current buffer's default directory."
+ (interactive "DChange default directory: ")
+ (setq dir (expand-file-name dir))
+ (if (not (eq system-type 'vax-vms))
+ (setq dir (file-name-as-directory dir)))
+ (if (not (file-directory-p dir))
+ (error "%s is not a directory" dir)
+ (setq default-directory dir))
+ (pwd))
+
+(defun load-file (file)
+ "Load the file FILE of Lisp code."
+ (interactive "fLoad file: ")
+ (load (expand-file-name file) nil nil t))
+
+(defun load-library (library)
+ "Load the library named LIBRARY.
+This is an interface to the function `load'."
+ (interactive "sLoad library: ")
+ (load library))
+
+(defun switch-to-buffer-other-window (buffer)
+ "Select buffer BUFFER in another window."
+ (interactive "BSwitch to buffer in other window: ")
+ (let ((pop-up-windows t))
+ (pop-to-buffer buffer t)))
+
+(defun find-file (filename)
+ "Edit file FILENAME.
+Switch to a buffer visiting file FILENAME,
+creating one if none already exists."
+ (interactive "FFind file: ")
+ (switch-to-buffer (find-file-noselect filename)))
+
+(defun find-file-other-window (filename)
+ "Edit file FILENAME, in another window.
+May create a new window, or reuse an existing one;
+see the function display-buffer."
+ (interactive "FFind file in other window: ")
+ (switch-to-buffer-other-window (find-file-noselect filename)))
+
+(defun find-file-read-only (filename)
+ "Edit file FILENAME but don't save without confirmation.
+Like find-file but marks buffer as read-only."
+ (interactive "fFind file read-only: ")
+ (find-file filename)
+ (setq buffer-read-only t))
+
+(defun find-alternate-file (filename)
+ "Find file FILENAME, select its buffer, kill previous buffer.
+If the current buffer now contains an empty file that you just visited
+\(presumably by mistake), use this command to visit the file you really want."
+ (interactive "FFind alternate file: ")
+ (and (buffer-modified-p)
+;;; (not buffer-read-only)
+ (not (yes-or-no-p (format "Buffer %s is modified; kill anyway? "
+ (buffer-name))))
+ (error "Aborted"))
+ (let ((obuf (current-buffer))
+ (ofile buffer-file-name)
+ (oname (buffer-name)))
+ (rename-buffer " **lose**")
+ (setq buffer-file-name nil)
+ (unwind-protect
+ (progn
+ (unlock-buffer)
+ (find-file filename))
+ (cond ((eq obuf (current-buffer))
+ (setq buffer-file-name ofile)
+ (lock-buffer)
+ (rename-buffer oname))))
+ (or (eq obuf (current-buffer))
+ (kill-buffer obuf))))
+
+(defun create-file-buffer (filename)
+ "Create a suitably named buffer for visiting FILENAME, and return it.
+FILENAME (sans directory) is used unchanged if that name is free;
+otherwise a string <2> or <3> or ... is appended to get an unused name."
+ (let ((lastname (file-name-nondirectory filename)))
+ (if (string= lastname "")
+ (setq lastname filename))
+ (generate-new-buffer lastname)))
+
+(defconst automount-dir-prefix "^/tmp_mnt/"
+ "Regexp to match the automounter prefix in a directory name.")
+
+(defun find-file-noselect (filename &optional nowarn)
+ "Read file FILENAME into a buffer and return the buffer.
+If a buffer exists visiting FILENAME, return that one,
+but verify that the file has not changed since visited or saved.
+The buffer is not selected, just returned to the caller."
+ (setq filename (expand-file-name filename))
+ ;; Get rid of the prefixes added by the automounter.
+ (if (and (string-match automount-dir-prefix filename)
+ (file-exists-p (file-name-directory
+ (substring filename (1- (match-end 0))))))
+ (setq filename (substring filename (1- (match-end 0)))))
+ (if (file-directory-p filename)
+ (if find-file-run-dired
+ (dired-noselect filename)
+ (error "%s is a directory." filename))
+ (let ((buf (get-file-buffer filename))
+ error)
+ (if buf
+ (or nowarn
+ (verify-visited-file-modtime buf)
+ (cond ((not (file-exists-p filename))
+ (error "File %s no longer exists!" filename))
+ ((yes-or-no-p
+ (if (buffer-modified-p buf)
+ "File has changed since last visited or saved. Flush your changes? "
+ "File has changed since last visited or saved. Read from disk? "))
+ (save-excursion
+ (set-buffer buf)
+ (revert-buffer t t)))))
+ (save-excursion
+ (setq buf (create-file-buffer filename))
+ (set-buffer buf)
+ (erase-buffer)
+ (condition-case ()
+ (insert-file-contents filename t)
+ (file-error
+ (setq error t)
+ ;; Run find-file-not-found-hooks until one returns non-nil.
+ (let ((hooks find-file-not-found-hooks))
+ (while (and hooks
+ (not (funcall (car hooks))))
+ (setq hooks (cdr hooks))))))
+ (setq default-directory (file-name-directory filename))
+ (after-find-file error (not nowarn))))
+ buf)))
+
+(defun after-find-file (&optional error warn)
+ "Called after finding a file and by the default revert function.
+Sets buffer mode, parses local variables.
+Optional args ERROR and WARN: ERROR non-nil means there was an
+error in reading the file. WARN non-nil means warn if there
+exists an auto-save file more recent than the visited file.
+Finishes by calling the functions in find-file-hooks."
+ (setq buffer-read-only (not (file-writable-p buffer-file-name)))
+ (if noninteractive
+ nil
+ (let* (not-serious
+ (msg
+ (cond ((not buffer-read-only)
+ (if (and warn
+ (file-newer-than-file-p (make-auto-save-file-name)
+ buffer-file-name))
+ "Auto save file is newer; consider M-x recover-file"
+ (setq not-serious t)
+ (if error "(New file)" nil)))
+ ((not error)
+ (setq not-serious t)
+ "File is write protected")
+ ((file-attributes buffer-file-name)
+ "File exists, but is read-protected.")
+ ((file-attributes (directory-file-name default-directory))
+ "File not found and directory write-protected")
+ (t
+ "File not found and directory doesn't exist"))))
+ (if msg
+ (progn
+ (message msg)
+ (or not-serious (sit-for 1 t)))))
+ (if auto-save-default
+ (auto-save-mode t)))
+ (normal-mode t)
+ (mapcar 'funcall find-file-hooks))
+
+(defun normal-mode (&optional find-file)
+ "Choose the major mode for this buffer automatically.
+Also sets up any specified local variables of the file.
+Uses the visited file name, the -*- line, and the local variables spec.
+
+This function is called automatically from `find-file'. In that case,
+if `inhibit-local-variables' is non-`nil' we require confirmation before
+processing a local variables spec. If you run `normal-mode' explicitly,
+confirmation is never required."
+ (interactive)
+ (or find-file (funcall (or default-major-mode 'fundamental-mode)))
+ (condition-case err
+ (set-auto-mode)
+ (error (message "File mode specification error: %s"
+ (prin1-to-string err))))
+ (condition-case err
+ (hack-local-variables (not find-file))
+ (error (message "File local-variables error: %s"
+ (prin1-to-string err)))))
+
+;(defvar auto-mode-alist ...) now in loaddefs.el
+(defun set-auto-mode ()
+ "Select major mode appropriate for current buffer.
+May base decision on visited file name (See variable auto-mode-list)
+or on buffer contents (-*- line or local variables spec), but does not look
+for the \"mode:\" local variable. For that, use hack-local-variables."
+ ;; Look for -*-MODENAME-*- or -*- ... mode: MODENAME; ... -*-
+ (let (beg end mode)
+ (save-excursion
+ (goto-char (point-min))
+ (skip-chars-forward " \t\n")
+ (if (and (search-forward "-*-" (save-excursion (end-of-line) (point)) t)
+ (progn
+ (skip-chars-forward " \t")
+ (setq beg (point))
+ (search-forward "-*-" (save-excursion (end-of-line) (point)) t))
+ (progn
+ (forward-char -3)
+ (skip-chars-backward " \t")
+ (setq end (point))
+ (goto-char beg)
+ (if (search-forward ":" end t)
+ (progn
+ (goto-char beg)
+ (if (let ((case-fold-search t))
+ (search-forward "mode:" end t))
+ (progn
+ (skip-chars-forward " \t")
+ (setq beg (point))
+ (if (search-forward ";" end t)
+ (forward-char -1)
+ (goto-char end))
+ (skip-chars-backward " \t")
+ (setq mode (buffer-substring beg (point))))))
+ (setq mode (buffer-substring beg end)))))
+ (funcall (intern (concat (downcase mode) "-mode")))
+ (let ((alist auto-mode-alist)
+ (name buffer-file-name))
+ (let ((case-fold-search (eq system-type 'vax-vms)))
+ ;; Remove backup-suffixes from file name.
+ (setq name (file-name-sans-versions name))
+ ;; Find first matching alist entry.
+ (while (and (not mode) alist)
+ (if (string-match (car (car alist)) name)
+ (setq mode (cdr (car alist))))
+ (setq alist (cdr alist))))
+ (if mode (funcall mode)))))))
+
+(defun hack-local-variables (&optional force)
+ "Parse, and bind or evaluate as appropriate, any local variables
+for current buffer."
+ ;; Look for "Local variables:" line in last page.
+ (save-excursion
+ (goto-char (point-max))
+ (search-backward "\n\^L" (max (- (point-max) 3000) (point-min)) 'move)
+ (if (let ((case-fold-search t))
+ (and (search-forward "Local Variables:" nil t)
+ (or (not inhibit-local-variables)
+ force
+ (save-window-excursion
+ (switch-to-buffer (current-buffer))
+ (save-excursion
+ (beginning-of-line)
+ (set-window-start (selected-window) (point)))
+ (y-or-n-p (format "Set local variables as specified at end of %s? "
+ (file-name-nondirectory buffer-file-name)))))))
+ (let ((continue t)
+ prefix prefixlen suffix beg)
+ ;; The prefix is what comes before "local variables:" in its line.
+ ;; The suffix is what comes after "local variables:" in its line.
+ (skip-chars-forward " \t")
+ (or (eolp)
+ (setq suffix (buffer-substring (point)
+ (progn (end-of-line) (point)))))
+ (goto-char (match-beginning 0))
+ (or (bolp)
+ (setq prefix
+ (buffer-substring (point)
+ (progn (beginning-of-line) (point)))))
+ (if prefix (setq prefixlen (length prefix)
+ prefix (regexp-quote prefix)))
+ (if suffix (setq suffix (concat (regexp-quote suffix) "$")))
+ (while continue
+ ;; Look at next local variable spec.
+ (if selective-display (re-search-forward "[\n\C-m]")
+ (forward-line 1))
+ ;; Skip the prefix, if any.
+ (if prefix
+ (if (looking-at prefix)
+ (forward-char prefixlen)
+ (error "Local variables entry is missing the prefix")))
+ ;; Find the variable name; strip whitespace.
+ (skip-chars-forward " \t")
+ (setq beg (point))
+ (skip-chars-forward "^:\n")
+ (if (eolp) (error "Missing colon in local variables entry"))
+ (skip-chars-backward " \t")
+ (let* ((str (buffer-substring beg (point)))
+ (var (read str))
+ val)
+ ;; Setting variable named "end" means end of list.
+ (if (string-equal (downcase str) "end")
+ (setq continue nil)
+ ;; Otherwise read the variable value.
+ (skip-chars-forward "^:")
+ (forward-char 1)
+ (setq val (read (current-buffer)))
+ (skip-chars-backward "\n")
+ (skip-chars-forward " \t")
+ (or (if suffix (looking-at suffix) (eolp))
+ (error "Local variables entry is terminated incorrectly"))
+ ;; Set the variable. "Variables" mode and eval are funny.
+ (cond ((eq var 'mode)
+ (funcall (intern (concat (downcase (symbol-name val))
+ "-mode"))))
+ ((eq var 'force) nil)
+ ((eq var 'ignore-local-eval)
+ nil)
+ ((eq var 'eval)
+ (if (or (and ignore-local-eval (not force))
+ (string= (user-login-name) "root"))
+ (message "Ignoring `eval:' in file's local variables")
+ (eval val)))
+ (t (make-local-variable var)
+ (set var val))))))))))
+
+(defun set-visited-file-name (filename)
+ "Change name of file visited in current buffer to FILENAME.
+The next time the buffer is saved it will go in the newly specified file.
+nil or empty string as argument means make buffer not be visiting any file.
+Remember to delete the initial contents of the minibuffer
+if you wish to pass an empty string as the argument."
+ (interactive "FSet visited file name: ")
+ (if filename
+ (setq filename
+ (if (string-equal filename "")
+ nil
+ (expand-file-name filename))))
+ (or (equal filename buffer-file-name)
+ (null filename)
+ (progn
+ (lock-buffer filename)
+ (unlock-buffer)))
+ (if filename
+ (let ((new-name (file-name-nondirectory filename)))
+ (if (string= new-name "")
+ (error "Empty file name"))
+ (if (file-directory-p filename)
+ (error "File %s is a directory" filename))
+ (if (eq system-type 'vax-vms)
+ (setq new-name (downcase new-name)))
+ (setq buffer-file-name filename)
+ (setq default-directory (file-name-directory buffer-file-name))
+ (or (get-buffer new-name) (rename-buffer new-name)))
+ (setq buffer-file-name nil))
+ (setq buffer-backed-up nil)
+ (clear-visited-file-modtime)
+ ;; So that C-x C-w after ftp-find-file
+ ;; writes an ordinary local file in the ordinary way.
+ (kill-local-variable 'write-file-hooks)
+ ;; So that revert works normally after theat C-x C-w.
+ (kill-local-variable 'revert-buffer-function)
+ ;; Rename the auto-save file to go with the new visited name.
+ ;; If auto-save was not already on, turn it on if appropriate.
+ (if buffer-auto-save-file-name
+ (rename-auto-save-file)
+ (auto-save-mode (and buffer-file-name auto-save-default)))
+ (if buffer-file-name
+ (set-buffer-modified-p t)))
+
+(defun write-file (filename)
+ "Write current buffer into file FILENAME.
+Makes buffer visit that file, and marks it not modified."
+ (interactive "FWrite file: ")
+ (or (null filename) (string-equal filename "")
+ (set-visited-file-name filename))
+ (set-buffer-modified-p t)
+ (save-buffer))
+
+(defun backup-buffer ()
+ "Make a backup of the disk file visited by the current buffer, if appropriate.
+This is normally done before saving the buffer the first time.
+If the value is non-nil, it is the result of `file-modes' on the original file;
+this means that the caller, after saving the buffer, should change the modes
+of the new file to agree with the old modes."
+ (and make-backup-files
+ (not buffer-backed-up)
+ (file-exists-p buffer-file-name)
+ (memq (aref (elt (file-attributes buffer-file-name) 8) 0)
+ '(?- ?l))
+ (or (< (length buffer-file-name) 5)
+ (not (string-equal "/tmp/" (substring buffer-file-name 0 5))))
+ (condition-case ()
+ (let* ((backup-info (find-backup-file-name buffer-file-name))
+ (backupname (car backup-info))
+ (targets (cdr backup-info))
+ setmodes)
+; (if (file-directory-p buffer-file-name)
+; (error "Cannot save buffer in directory %s" buffer-file-name))
+ (condition-case ()
+ (if (or file-precious-flag
+ (file-symlink-p buffer-file-name)
+ backup-by-copying
+ (and backup-by-copying-when-linked
+ (> (file-nlinks buffer-file-name) 1))
+ (and backup-by-copying-when-mismatch
+ (let ((attr (file-attributes buffer-file-name)))
+ (or (nth 9 attr)
+ (/= (nth 2 attr) (user-uid))))))
+ (copy-file buffer-file-name backupname t t)
+ (condition-case ()
+ (delete-file backupname)
+ (file-error nil))
+ (rename-file buffer-file-name backupname t)
+ (setq setmodes (file-modes backupname)))
+ (file-error
+ ;; If trouble writing the backup, write it in ~.
+ (setq backupname (expand-file-name "~/%backup%~"))
+ (message "Cannot write backup file; backing up in ~/%%backup%%~")
+ (sleep-for 1)
+ (condition-case ()
+ (delete-file backupname)
+ (file-error nil))
+ (copy-file buffer-file-name backupname t t)))
+ (setq buffer-backed-up t)
+ (if (and targets
+ (or trim-versions-without-asking
+ (y-or-n-p (format "Delete excess backup versions of %s? "
+ buffer-file-name))))
+ (while targets
+ (condition-case ()
+ (delete-file (car targets))
+ (file-error nil))
+ (setq targets (cdr targets))))
+ setmodes)
+ (file-error nil))))
+
+(defun file-name-sans-versions (name)
+ "Return FILENAME sans backup versions or strings.
+This is a separate procedure so your site-init or startup file can
+redefine it."
+ (substring name 0
+ (if (eq system-type 'vax-vms)
+ (or (string-match ";[0-9]*\\'" name)
+ (and (string-match "\\." name (string-match "[]>]" name))
+ (string-match "\\.[0-9]*\\'" name (match-end 0))))
+ (string-match "\\(\\.~[0-9]+\\)?~\\'" name))))
+
+(defun make-backup-file-name (file)
+ "Create the non-numeric backup file name for FILE.
+This is a separate function so you can redefine it for customization."
+ (concat file "~"))
+
+(defun backup-file-name-p (file)
+ "Return non-nil if FILE is a backup file name (numeric or not).
+This is a separate function so you can redefine it for customization.
+You may need to redefine file-name-sans-versions as well."
+ (string-match "~$" file))
+
+;; I believe there is no need to alter this behavior for VMS;
+;; since backup files are not made on VMS, it should not get called.
+(defun find-backup-file-name (fn)
+ "Find a file name for a backup file, and suggestions for deletions.
+Value is a list whose car is the name for the backup file
+ and whose cdr is a list of old versions to consider deleting now."
+ (if (eq version-control 'never)
+ (list (make-backup-file-name fn))
+ (let* ((base-versions (concat (file-name-nondirectory fn) ".~"))
+ (bv-length (length base-versions))
+ (possibilities (file-name-all-completions
+ base-versions
+ (file-name-directory fn)))
+ (versions (sort (mapcar 'backup-extract-version possibilities)
+ '<))
+ (high-water-mark (apply 'max (cons 0 versions)))
+ (deserve-versions-p
+ (or version-control
+ (> high-water-mark 0)))
+ (number-to-delete (- (length versions)
+ ;; -1 compensates for the backup
+ ;; we are about to make.
+ kept-old-versions kept-new-versions -1)))
+ (if (not deserve-versions-p)
+ (list (make-backup-file-name fn))
+ (cons (concat fn ".~" (int-to-string (1+ high-water-mark)) "~")
+ (if (and (> number-to-delete 0)
+ ;; Delete nothing if there is overflow
+ ;; in the number of versions to keep.
+ (>= (+ kept-new-versions kept-old-versions -1) 0))
+ (mapcar (function (lambda (n)
+ (concat fn ".~"
+ (int-to-string n) "~")))
+ (let ((v (nthcdr kept-old-versions versions)))
+ (rplacd (nthcdr (1- number-to-delete) v) ())
+ v))))))))
+
+(defun backup-extract-version (fn)
+ (if (and (string-match "[0-9]+~$" fn bv-length)
+ (= (match-beginning 0) bv-length))
+ (string-to-int (substring fn bv-length -1))
+ 0))
+
+(defun file-nlinks (filename)
+ "Return number of names file FILENAME has."
+ (car (cdr (file-attributes filename))))
+
+(defun save-buffer (&optional args)
+ "Save current buffer in visited file if modified. Versions described below.
+
+By default, makes the previous version into a backup file
+ if previously requested or if this is the first save.
+With 1 or 3 \\[universal-argument]'s, marks this version
+ to become a backup when the next save is done.
+With 2 or 3 \\[universal-argument]'s,
+ unconditionally makes the previous version into a backup file.
+With argument of 0, never makes the previous version into a backup file.
+
+If a file's name is FOO, the names of its numbered backup versions are
+ FOO.~i~ for various integers i. A non-numbered backup file is called FOO~.
+Numeric backups (rather than FOO~) will be made if value of
+ `version-control' is not the atom `never' and either there are already
+ numeric versions of the file being backed up, or `version-control' is
+ non-nil.
+We don't want excessive versions piling up, so there are variables
+ `kept-old-versions', which tells Emacs how many oldest versions to keep,
+ and `kept-new-versions', which tells how many newest versions to keep.
+ Defaults are 2 old versions and 2 new.
+`dired-kept-versions' controls dired's clean-directory (.) command.
+If `trim-versions-without-asking' is nil, system will query user
+ before trimming versions. Otherwise it does it silently."
+ (interactive "p")
+ (let ((modp (buffer-modified-p))
+ (large (> (buffer-size) 50000))
+ (make-backup-files (and make-backup-files (not (eq args 0)))))
+ (and modp (memq args '(16 64)) (setq buffer-backed-up nil))
+ (if (and modp large) (message "Saving file %s..." (buffer-file-name)))
+ (basic-save-buffer)
+ (and modp (memq args '(4 64)) (setq buffer-backed-up nil))))
+
+(defun delete-auto-save-file-if-necessary ()
+ "Delete the auto-save filename for the current buffer (if it has one)
+if variable delete-auto-save-files is non-nil."
+ (and buffer-auto-save-file-name delete-auto-save-files
+ (not (string= buffer-file-name buffer-auto-save-file-name))
+ (progn
+ (condition-case ()
+ (delete-file buffer-auto-save-file-name)
+ (file-error nil))
+ (set-buffer-auto-saved))))
+
+(defun basic-save-buffer ()
+ "Save the current buffer in its visited file, if it has been modified."
+ (interactive)
+ (if (buffer-modified-p)
+ (let (setmodes tempsetmodes)
+ (or buffer-file-name
+ (progn
+ (setq buffer-file-name
+ (expand-file-name (read-file-name "File to save in: ") nil)
+ default-directory (file-name-directory buffer-file-name))
+ (auto-save-mode auto-save-default)))
+ (if (not (file-writable-p buffer-file-name))
+ (if (yes-or-no-p
+ (format "File %s is write-protected; try to save anyway? "
+ (file-name-nondirectory buffer-file-name)))
+ (setq tempsetmodes t)
+ (error
+ "Attempt to save to a file which you aren't allowed to write")))
+ (or (verify-visited-file-modtime (current-buffer))
+ (not (file-exists-p buffer-file-name))
+ (yes-or-no-p
+ "Disk file has changed since visited or saved. Save anyway? ")
+ (error "Save not confirmed"))
+ (or buffer-backed-up
+ (setq setmodes (backup-buffer)))
+ (save-restriction
+ (widen)
+ (and (> (point-max) 1)
+ (/= (char-after (1- (point-max))) ?\n)
+ (or (eq require-final-newline t)
+ (and require-final-newline
+ (yes-or-no-p
+ (format "Buffer %s does not end in newline. Add one? "
+ (buffer-name)))))
+ (save-excursion
+ (goto-char (point-max))
+ (insert ?\n)))
+ (let ((hooks write-file-hooks)
+ (done nil))
+ (while (and hooks
+ (not (setq done (funcall (car hooks)))))
+ (setq hooks (cdr hooks)))
+ ;; If a hook returned t, file is already "written".
+ (cond (done (setq setmodes nil))
+ ((not done)
+ (if file-precious-flag
+ ;; If file is precious, rename it away before
+ ;; overwriting it.
+ (let ((rename t) nodelete
+ (file (concat buffer-file-name "#")))
+ (condition-case ()
+ (progn (rename-file buffer-file-name file t)
+ (setq setmodes (file-modes file)))
+ (file-error (setq rename nil nodelete t)))
+ (unwind-protect
+ (progn (clear-visited-file-modtime)
+ (write-region (point-min) (point-max)
+ buffer-file-name nil t)
+ (setq rename nil))
+ ;; If rename is still t, writing failed.
+ ;; So rename the old file back to original name,
+ (if rename
+ (progn
+ (rename-file file buffer-file-name t)
+ (clear-visited-file-modtime))
+ ;; Otherwise we don't need the original file,
+ ;; so flush it. Unless we already lost it.
+ (or nodelete
+ (condition-case ()
+ (delete-file file)
+ (error nil))))))
+ ;; If file not writable, see if we can make it writable
+ ;; temporarily while we write it.
+ ;; But no need to do so if we have just backed it up
+ ;; (setmodes is set) because that says we're superseding.
+ ;; Systems with version numbers need not do this.
+ (if (eq system-type 'vax-vms)
+ (setq setmodes nil tempsetmodes nil))
+ (cond ((and tempsetmodes (not setmodes))
+ ;; Change the mode back, after writing.
+ (setq setmodes (file-modes buffer-file-name))
+ (set-file-modes buffer-file-name 511)))
+ (write-region (point-min) (point-max)
+ buffer-file-name nil t)))))
+ (if setmodes
+ (condition-case ()
+ (set-file-modes buffer-file-name setmodes)
+ (error nil))))
+ (delete-auto-save-file-if-necessary))
+ (message "(No changes need to be saved)")))
+
+(defun save-some-buffers (&optional arg exiting)
+ "Save some modified file-visiting buffers. Asks user about each one.
+Optional argument (the prefix) non-nil means save all with no questions.
+Optional second argument EXITING means ask about certain non-file buffers
+ as well as about file buffers."
+ (interactive "P")
+ (let (considered (list (buffer-list)))
+ (while list
+ (let ((buffer (car list)))
+ (and (buffer-modified-p buffer)
+ (save-excursion
+ (set-buffer buffer)
+ (and
+ (or buffer-file-name
+ (and exiting buffer-offer-save (> (buffer-size) 0)))
+ (setq considered t)
+ (or arg
+ (y-or-n-p (if buffer-file-name
+ (format "Save file %s? "
+ buffer-file-name)
+ (format "Save buffer %s? " (buffer-name)))))
+ (condition-case ()
+ (save-buffer)
+ (error nil))))))
+ (setq list (cdr list)))
+ (and save-abbrevs abbrevs-changed
+ (progn
+ (setq considered t)
+ (if (or arg
+ (y-or-n-p (format "Save abbrevs in %s? " abbrev-file-name)))
+ (write-abbrev-file nil))
+ ;; Don't keep bothering user if he says no.
+ (setq abbrevs-changed nil)))
+ (if considered
+ (message "")
+ (message "(No files need saving)"))))
+
+(defun not-modified ()
+ "Mark current buffer as unmodified, not needing to be saved."
+ (interactive)
+ (message "Modification-flag cleared")
+ (set-buffer-modified-p nil))
+
+(defun toggle-read-only ()
+ "Change whether this buffer is visiting its file read-only."
+ (interactive)
+ (setq buffer-read-only (not buffer-read-only))
+ ;; Force mode-line redisplay
+ (set-buffer-modified-p (buffer-modified-p)))
+
+(defun insert-file (filename)
+ "Insert contents of file FILENAME into buffer after point.
+Set mark after the inserted text."
+ (interactive "fInsert file: ")
+ (let ((tem (insert-file-contents filename)))
+ (push-mark (+ (point) (car (cdr tem))))))
+
+(defun append-to-file (start end filename)
+ "Append the contents of the region to the end of file FILENAME.
+When called from a function, expects three arguments,
+START, END and FILENAME. START and END are buffer positions
+saying what text to write."
+ (interactive "r\nFAppend to file: ")
+ (write-region start end filename t))
+
+(defvar revert-buffer-function nil
+ "Function to use to revert this buffer, or nil to do the default.")
+
+(defun revert-buffer (&optional arg noconfirm)
+ "Replace the buffer text with the text of the visited file on disk.
+This undoes all changes since the file was visited or saved.
+If latest auto-save file is more recent than the visited file,
+asks user whether to use that instead.
+First argument (optional) non-nil means don't offer to use auto-save file.
+ This is the prefix arg when called interactively.
+
+Second argument (optional) non-nil means don't ask for confirmation at all.
+
+If revert-buffer-function's value is non-nil, it is called to do the work."
+ (interactive "P")
+ (if revert-buffer-function
+ (funcall revert-buffer-function arg noconfirm)
+ (let* ((opoint (point))
+ (auto-save-p (and (null arg) (recent-auto-save-p)
+ buffer-auto-save-file-name
+ (file-readable-p buffer-auto-save-file-name)
+ (y-or-n-p
+ "Buffer has been auto-saved recently. Revert from auto-save file? ")))
+ (file-name (if auto-save-p
+ buffer-auto-save-file-name
+ buffer-file-name)))
+ (cond ((null file-name)
+ (error "Buffer does not seem to be associated with any file"))
+ ((not (file-exists-p file-name))
+ (error "File %s no longer exists!" file-name))
+ ((or noconfirm
+ (yes-or-no-p (format "Revert buffer from file %s? "
+ file-name)))
+ ;; If file was backed up but has changed since,
+ ;; we shd make another backup.
+ (and (not auto-save-p)
+ (not (verify-visited-file-modtime (current-buffer)))
+ (setq buffer-backed-up nil))
+ ;; Discard all the undo information.
+ (or (eq buffer-undo-list t)
+ (setq buffer-undo-list nil))
+ (let ((buffer-read-only nil)
+ ;; Don't record undo info for the revert itself.
+ ;; Doing so chews up too much storage.
+ (buffer-undo-list t))
+ ;; Bind buffer-file-name to nil
+ ;; so that we don't try to lock the file.
+ (let ((buffer-file-name nil))
+ (or auto-save-p
+ (unlock-buffer))
+ (erase-buffer))
+ (insert-file-contents file-name (not auto-save-p)))
+ (goto-char (min opoint (point-max)))
+ (after-find-file nil)
+ t)))))
+
+(defun recover-file (file)
+ "Visit file FILE, but get contents from its last auto-save file."
+ (interactive "FRecover file: ")
+ (setq file (expand-file-name file))
+ (if (auto-save-file-name-p file) (error "%s is an auto-save file" file))
+ (let ((file-name (let ((buffer-file-name file))
+ (make-auto-save-file-name))))
+ (cond ((not (file-newer-than-file-p file-name file))
+ (error "Auto-save file %s not current" file-name))
+ ((save-window-excursion
+ (if (not (eq system-type 'vax-vms))
+ (with-output-to-temp-buffer "*Directory*"
+ (buffer-flush-undo standard-output)
+ (call-process "ls" nil standard-output nil
+ "-l" file file-name)))
+ (yes-or-no-p (format "Recover auto save file %s? " file-name)))
+ (switch-to-buffer (find-file-noselect file t))
+ (let ((buffer-read-only nil))
+ (erase-buffer)
+ (insert-file-contents file-name nil))
+ (after-find-file nil))
+ (t (error "Recover-file cancelled."))))
+ (setq buffer-auto-save-file-name nil)
+ (message "Auto-save off in this buffer till you do M-x auto-save-mode."))
+
+(defun kill-some-buffers ()
+ "For each buffer, ask whether to kill it."
+ (interactive)
+ (let ((list (buffer-list)))
+ (while list
+ (let* ((buffer (car list))
+ (name (buffer-name buffer)))
+ (and (not (string-equal name ""))
+ (/= (aref name 0) ? )
+ (yes-or-no-p
+ (format "Buffer %s %s. Kill? "
+ name
+ (if (buffer-modified-p buffer)
+ "HAS BEEN EDITED" "is unmodified")))
+ (kill-buffer buffer)))
+ (setq list (cdr list)))))
+
+(defun auto-save-mode (arg)
+ "Toggle auto-saving of contents of current buffer.
+With arg, turn auto-saving on if arg is positive, else off."
+ (interactive "P")
+ (setq buffer-auto-save-file-name
+ (and (if (null arg)
+ (not buffer-auto-save-file-name)
+ (or (eq arg t) (listp arg) (and (integerp arg) (> arg 0))))
+ (if (and buffer-file-name auto-save-visited-file-name
+ (not buffer-read-only))
+ buffer-file-name
+ (make-auto-save-file-name))))
+ (if (interactive-p)
+ (message "Auto-save %s (in this buffer)"
+ (if buffer-auto-save-file-name "on" "off")))
+ buffer-auto-save-file-name)
+
+(defun rename-auto-save-file ()
+ "Adjust current buffer's auto save file name for current conditions.
+Also rename any existing auto save file."
+ (let ((osave buffer-auto-save-file-name))
+ (setq buffer-auto-save-file-name
+ (make-auto-save-file-name))
+ (if (and osave buffer-auto-save-file-name
+ (not (string= buffer-auto-save-file-name buffer-file-name))
+ (not (string= buffer-auto-save-file-name osave))
+ (file-exists-p osave))
+ (rename-file osave buffer-auto-save-file-name t))))
+
+(defun make-auto-save-file-name ()
+ "Return file name to use for auto-saves of current buffer.
+Does not consider auto-save-visited-file-name; that is checked
+before calling this function.
+You can redefine this for customization.
+See also auto-save-file-name-p."
+ (if buffer-file-name
+ (concat (file-name-directory buffer-file-name)
+ "#"
+ (file-name-nondirectory buffer-file-name)
+ "#")
+ (expand-file-name (concat "#%" (buffer-name) "#"))))
+
+(defun auto-save-file-name-p (filename)
+ "Return non-nil if FILENAME can be yielded by make-auto-save-file-name.
+FILENAME should lack slashes.
+You can redefine this for customization."
+ (string-match "^#.*#$" filename))
+
+(defconst list-directory-brief-switches "-CF"
+ "*Switches for list-directory to pass to `ls' for brief listing,")
+(defconst list-directory-verbose-switches "-l"
+ "*Switches for list-directory to pass to `ls' for verbose listing,")
+
+(defun list-directory (dirname &optional verbose)
+ "Display a list of files in or matching DIRNAME, a la `ls'.
+DIRNAME is globbed by the shell if necessary.
+Prefix arg (second arg if noninteractive) means supply -l switch to `ls'.
+Actions controlled by variables list-directory-brief-switches
+ and list-directory-verbose-switches."
+ (interactive (let ((pfx current-prefix-arg))
+ (list (read-file-name (if pfx "List directory (verbose): "
+ "List directory (brief): ")
+ nil default-directory nil)
+ pfx)))
+ (let ((switches (if verbose list-directory-verbose-switches
+ list-directory-brief-switches))
+ full-dir-p)
+ (or dirname (setq dirname default-directory))
+ (if (file-directory-p dirname)
+ (progn
+ (setq full-dir-p t)
+ (or (string-match "/$" dirname)
+ (setq dirname (concat dirname "/")))))
+ (setq dirname (expand-file-name dirname))
+ (with-output-to-temp-buffer "*Directory*"
+ (buffer-flush-undo standard-output)
+ (princ "Directory ")
+ (princ dirname)
+ (terpri)
+ (if full-dir-p
+ (call-process "ls" nil standard-output nil
+ switches dirname)
+ (let ((default-directory (file-name-directory dirname)))
+ (call-process shell-file-name nil standard-output nil
+ "-c" (concat "exec ls "
+ switches " "
+ (file-name-nondirectory dirname))))))))
+
+(defun save-buffers-kill-emacs (&optional arg)
+ "Offer to save each buffer, then kill this Emacs fork.
+With prefix arg, silently save all file-visiting buffers, then kill."
+ (interactive "P")
+ (save-some-buffers arg t)
+ (and (or (not (memq t (mapcar (function
+ (lambda (buf) (and (buffer-file-name buf)
+ (buffer-modified-p buf))))
+ (buffer-list))))
+ (yes-or-no-p "Modified buffers exist; exit anyway? "))
+ (or (not (fboundp 'process-list))
+ ;; process-list is not defined on VMS.
+ (let ((processes (process-list))
+ active)
+ (while processes
+ (and (memq (process-status (car processes)) '(run stop open))
+ (let ((val (process-kill-without-query (car processes))))
+ (process-kill-without-query (car processes) val)
+ val)
+ (setq active t))
+ (setq processes (cdr processes)))
+ (or (not active)
+ (yes-or-no-p "Active processes exist; kill them and exit anyway? "))))
+ (kill-emacs)))
+
+(define-key ctl-x-map "\C-f" 'find-file)
+(define-key ctl-x-map "\C-q" 'toggle-read-only)
+(define-key ctl-x-map "\C-r" 'find-file-read-only)
+(define-key ctl-x-map "\C-v" 'find-alternate-file)
+(define-key ctl-x-map "\C-s" 'save-buffer)
+(define-key ctl-x-map "s" 'save-some-buffers)
+(define-key ctl-x-map "\C-w" 'write-file)
+(define-key ctl-x-map "i" 'insert-file)
+(define-key esc-map "~" 'not-modified)
+(define-key ctl-x-map "\C-d" 'list-directory)
+(define-key ctl-x-map "\C-c" 'save-buffers-kill-emacs)
+
+(defvar ctl-x-4-map (make-keymap)
+ "Keymap for subcommands of C-x 4")
+(fset 'ctl-x-4-prefix ctl-x-4-map)
+(define-key ctl-x-map "4" 'ctl-x-4-prefix)
+(define-key ctl-x-4-map "f" 'find-file-other-window)
+(define-key ctl-x-4-map "\C-f" 'find-file-other-window)
+(define-key ctl-x-4-map "b" 'switch-to-buffer-other-window)
diff --git a/lisp/files.elc b/lisp/files.elc
new file mode 100644
index 00000000000..c02660144fa
--- /dev/null
+++ b/lisp/files.elc
Binary files differ
diff --git a/lisp/fill.el b/lisp/fill.el
new file mode 100644
index 00000000000..e514fa14cd2
--- /dev/null
+++ b/lisp/fill.el
@@ -0,0 +1,287 @@
+;; Fill commands for Emacs
+;; Copyright (C) 1985, 1986, 1992 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+(defconst fill-individual-varying-indent nil
+ "*Controls criterion for a new paragraph in `fill-individual-paragraphs'.
+Non-nil means changing indent doesn't end a paragraph.
+That mode can handle paragraphs with extra indentation on the first line,
+but it requires separator lines between paragraphs.
+Nil means that any change in indentation starts a new paragraph.")
+
+(defun set-fill-prefix ()
+ "Set the fill-prefix to the current line up to point.
+Filling expects lines to start with the fill prefix
+and reinserts the fill prefix in each resulting line."
+ (interactive)
+ (setq fill-prefix (buffer-substring
+ (save-excursion (beginning-of-line) (point))
+ (point)))
+ (if (equal fill-prefix "")
+ (setq fill-prefix nil))
+ (if fill-prefix
+ (message "fill-prefix: \"%s\"" fill-prefix)
+ (message "fill-prefix cancelled")))
+
+(defun fill-region-as-paragraph (from to &optional justify-flag)
+ "Fill region as one paragraph: break lines to fit fill-column.
+Prefix arg means justify too.
+From program, pass args FROM, TO and JUSTIFY-FLAG."
+ (interactive "r\nP")
+ (save-restriction
+ (narrow-to-region from to)
+ (goto-char (point-min))
+ (skip-chars-forward "\n")
+ (narrow-to-region (point) (point-max))
+ (setq from (point))
+ (let ((fpre (and fill-prefix (not (equal fill-prefix ""))
+ (regexp-quote fill-prefix))))
+ ;; Delete the fill prefix from every line except the first.
+ ;; The first line may not even have a fill prefix.
+ (and fpre
+ (progn
+ (if (>= (length fill-prefix) fill-column)
+ (error "fill-prefix too long for specified width"))
+ (goto-char (point-min))
+ (forward-line 1)
+ (while (not (eobp))
+ (if (looking-at fpre)
+ (delete-region (point) (match-end 0)))
+ (forward-line 1))
+ (goto-char (point-min))
+ (and (looking-at fpre) (forward-char (length fill-prefix)))
+ (setq from (point)))))
+ ;; from is now before the text to fill,
+ ;; but after any fill prefix on the first line.
+
+ ;; Make sure sentences ending at end of line get an extra space.
+ (goto-char from)
+ (while (re-search-forward "[.?!][])""']*$" nil t)
+ (insert ? ))
+ ;; The change all newlines to spaces.
+ (subst-char-in-region from (point-max) ?\n ?\ )
+ ;; Flush excess spaces, except in the paragraph indentation.
+ (goto-char from)
+ (skip-chars-forward " \t")
+ (while (re-search-forward " *" nil t)
+ (delete-region
+ (+ (match-beginning 0)
+ (if (save-excursion
+ (skip-chars-backward " ])\"'")
+ (memq (preceding-char) '(?. ?? ?!)))
+ 2 1))
+ (match-end 0)))
+ (goto-char (point-max))
+ (delete-horizontal-space)
+ (insert " ")
+ (goto-char (point-min))
+ (let ((prefixcol 0) linebeg)
+ (while (not (eobp))
+ (setq linebeg (point))
+ (move-to-column (1+ fill-column))
+ (if (eobp)
+ nil
+ ;; Move back to start of word.
+ (skip-chars-backward "^ \n" linebeg)
+ (if (if (zerop prefixcol) (bolp) (>= prefixcol (current-column)))
+ ;; Keep at least one word even if fill prefix exceeds margin.
+ ;; This handles all but the first line of the paragraph.
+ (progn
+ (skip-chars-forward " ")
+ (skip-chars-forward "^ \n"))
+ ;; Normally, move back over the single space between the words.
+ (forward-char -1)))
+ (if (and fill-prefix (zerop prefixcol)
+ (< (- (point) (point-min)) (length fill-prefix))
+ (string= (buffer-substring (point-min) (point))
+ (substring fill-prefix 0 (- (point) (point-min)))))
+ ;; Keep at least one word even if fill prefix exceeds margin.
+ ;; This handles the first line of the paragraph.
+ (progn
+ (skip-chars-forward " ")
+ (skip-chars-forward "^ \n")))
+ ;; Replace all whitespace here with one newline.
+ ;; Insert before deleting, so we don't forget which side of
+ ;; the whitespace point or markers used to be on.
+ (skip-chars-backward " ")
+ (insert ?\n)
+ (delete-horizontal-space)
+ ;; Insert the fill prefix at start of each line.
+ ;; Set prefixcol so whitespace in the prefix won't get lost.
+ (and (not (eobp)) fill-prefix (not (equal fill-prefix ""))
+ (progn
+ (insert fill-prefix)
+ (setq prefixcol (current-column))))
+ ;; Justify the line just ended, if desired.
+ (and justify-flag (not (eobp))
+ (progn
+ (forward-line -1)
+ (justify-current-line)
+ (forward-line 1)))))))
+
+(defun fill-paragraph (arg)
+ "Fill paragraph at or after point.
+Prefix arg means justify as well."
+ (interactive "P")
+ (save-excursion
+ (forward-paragraph)
+ (or (bolp) (newline 1))
+ (let ((end (point)))
+ (backward-paragraph)
+ (fill-region-as-paragraph (point) end arg))))
+
+(defun fill-region (from to &optional justify-flag)
+ "Fill each of the paragraphs in the region.
+Prefix arg (non-nil third arg, if called from program)
+means justify as well."
+ (interactive "r\nP")
+ (save-restriction
+ (narrow-to-region from to)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (let ((initial (point))
+ (end (progn
+ (forward-paragraph 1) (point))))
+ (forward-paragraph -1)
+ (if (>= (point) initial)
+ (fill-region-as-paragraph (point) end justify-flag)
+ (goto-char end))))))
+
+(defun justify-current-line ()
+ "Add spaces to line point is in, so it ends at fill-column."
+ (interactive)
+ (save-excursion
+ (save-restriction
+ (let (ncols nwhites beg indent flags)
+ (beginning-of-line)
+ (forward-char (length fill-prefix))
+ (skip-chars-forward " \t")
+ (setq indent (current-column))
+ (setq beg (point))
+ (end-of-line)
+ (narrow-to-region beg (point))
+ (goto-char beg)
+ (while (re-search-forward " *" nil t)
+ (delete-region
+ (+ (match-beginning 0)
+ (if (save-excursion
+ (skip-chars-backward " ])\"'")
+ (memq (preceding-char) '(?. ?? ?!)))
+ 2 1))
+ (match-end 0)))
+ (goto-char beg)
+ (while (re-search-forward "[.?!][])""']*\n" nil t)
+ (forward-char -1)
+ (insert ? ))
+ (goto-char (point-max))
+ ;; Note that the buffer bounds start after the indentation,
+ ;; so the columns counted by INDENT don't appear in (current-column).
+ (setq ncols (- fill-column (current-column) indent))
+ ;; Count word-boundaries in the line.
+ (setq nwhites 0)
+ (while (search-backward " " nil t)
+ (skip-chars-backward " ")
+ (setq nwhites (1+ nwhites)))
+ (if (> nwhites 0)
+ (progn
+ ;; Add space uniformly as far as we can.
+ (goto-char (point-max))
+ (while (search-backward " " nil t)
+ (insert-char ?\ (/ ncols nwhites))
+ (skip-chars-backward " "))
+ ;; Make a bit vector for where to add the rest.
+ (setq ncols (% ncols nwhites))
+ (setq flags (make-string nwhites 0))
+ ;; Randomly set NCOLS different bits.
+ (while (> ncols 0)
+ (let ((where (% (logand 262143 (random)) nwhites)))
+ (or (> (aref flags where) 0)
+ (progn
+ (aset flags where 1)
+ (setq ncols (1- ncols))))))
+ ;; Insert a space at the boundaries flagged in the vector.
+ (goto-char (point-max))
+ (let ((where 0))
+ (while (search-backward " " nil t)
+ (if (> (aref flags where) 0)
+ (insert " "))
+ (setq where (1+ where))
+ (skip-chars-backward " ")))))))))
+
+(defun fill-individual-paragraphs (min max &optional justifyp mailp)
+ "Fill each paragraph in region according to its individual fill prefix.
+
+If `fill-individual-varying-indent' is non-nil,
+then a mere change in indentation does not end a paragraph. In this mode,
+the indentation for a paragraph is the minimum indentation of any line in it.
+
+Calling from a program, pass range to fill as first two arguments.
+
+Optional third and fourth arguments JUSTIFY-FLAG and MAIL-FLAG:
+JUSTIFY-FLAG to justify paragraphs (prefix arg),
+MAIL-FLAG for a mail message, i. e. don't fill header lines."
+ (interactive "r\nP")
+ (save-restriction
+ (save-excursion
+ (goto-char min)
+ (beginning-of-line)
+ (if mailp
+ (while (looking-at "[^ \t\n]*:")
+ (forward-line 1)))
+ (narrow-to-region (point) max)
+ ;; Loop over paragraphs.
+ (while (progn (skip-chars-forward " \t\n") (not (eobp)))
+ (beginning-of-line)
+ (let ((start (point))
+ fill-prefix fill-prefix-regexp)
+ ;; Find end of paragraph, and compute the smallest fill-prefix
+ ;; that fits all the lines in this paragraph.
+ (while (progn
+ ;; Update the fill-prefix on the first line
+ ;; and whenever the prefix good so far is too long.
+ (if (not (and fill-prefix
+ (looking-at fill-prefix-regexp)))
+ (setq fill-prefix
+ (buffer-substring (point)
+ (save-excursion (skip-chars-forward " \t") (point)))
+ fill-prefix-regexp
+ (regexp-quote fill-prefix)))
+ (forward-line 1)
+ ;; Now stop the loop if end of paragraph.
+ (and (not (eobp))
+ (if fill-individual-varying-indent
+ ;; If this line is a separator line, with or
+ ;; without prefix, end the paragraph.
+ (and
+ (not (looking-at paragraph-separate))
+ (save-excursion
+ (not (and (looking-at fill-prefix-regexp)
+ (progn (forward-char (length fill-prefix))
+ (looking-at paragraph-separate))))))
+ ;; If this line has more or less indent
+ ;; than the fill prefix wants, end the paragraph.
+ (and (looking-at fill-prefix-regexp)
+ (save-excursion
+ (not (progn (forward-char (length fill-prefix))
+ (or (looking-at paragraph-separate)
+ (looking-at paragraph-start))))))))))
+ ;; Fill this paragraph, but don't add a newline at the end.
+ (let ((had-newline (bolp)))
+ (fill-region-as-paragraph start (point) justifyp)
+ (or had-newline (delete-char -1))))))))
+
diff --git a/lisp/fill.elc b/lisp/fill.elc
new file mode 100644
index 00000000000..5474adf9d4e
--- /dev/null
+++ b/lisp/fill.elc
Binary files differ
diff --git a/lisp/find-gc.el b/lisp/find-gc.el
deleted file mode 100644
index 3504d2949d8..00000000000
--- a/lisp/find-gc.el
+++ /dev/null
@@ -1,127 +0,0 @@
-;;;; find-gc.el
-
-
-;;; Produce in unsafe-list the set of all functions that may invoke GC.
-;;; This expects the Emacs sources to live in emacs-source-directory.
-;;; It creates a temporary working directory /tmp/esrc.
-
-(defun find-gc-unsafe ()
- (trace-call-tree nil)
- (trace-use-tree)
- (find-unsafe-funcs 'Fgarbage_collect)
- (setq unsafe-list (sort unsafe-list
- (function (lambda (x y)
- (string-lessp (car x) (car y))))))
-)
-
-(setq emacs-source-directory "/usr/gnu/src/dist/src")
-
-
-;;; This does a depth-first search to find all functions that can
-;;; ultimately call the function "target". The result is an a-list
-;;; in unsafe-list; the cars are the unsafe functions, and the cdrs
-;;; are (one of) the unsafe functions that these functions directly
-;;; call.
-
-(defun find-unsafe-funcs (target)
- (setq unsafe-list (list (list target)))
- (trace-unsafe target)
-)
-
-(defun trace-unsafe (func)
- (let ((used (assq func subrs-used)))
- (or used
- (error "No subrs-used for %s" (car unsafe-list)))
- (while (setq used (cdr used))
- (or (assq (car used) unsafe-list)
- (memq (car used) noreturn-list)
- (progn
- (setq unsafe-list (cons (cons (car used) func) unsafe-list))
- (trace-unsafe (car used))))))
-)
-
-
-;;; Functions on this list are safe, even if they appear to be able
-;;; to call the target.
-
-(setq noreturn-list '( Fsignal Fthrow wrong_type_argument ))
-
-
-;;; This produces an a-list of functions in subrs-called. The cdr of
-;;; each entry is a list of functions which the function in car calls.
-
-(defun trace-call-tree (&optional already-setup)
- (message "Setting up directories...")
- (or already-setup
- (progn
- ;; Gee, wouldn't a built-in "system" function be handy here.
- (call-process "csh" nil nil nil "-c" "rm -rf /tmp/esrc")
- (call-process "csh" nil nil nil "-c" "mkdir /tmp/esrc")
- (call-process "csh" nil nil nil "-c"
- (format "ln -s %s/*.[ch] /tmp/esrc"
- emacs-source-directory))))
- (save-excursion
- (set-buffer (get-buffer-create "*Trace Call Tree*"))
- (setq subrs-called nil)
- (let ((case-fold-search nil)
- (files source-files)
- name entry)
- (while files
- (message "Compiling %s..." (car files))
- (call-process "csh" nil nil nil "-c"
- (format "gcc -dr -c /tmp/esrc/%s -o /dev/null"
- (car files)))
- (erase-buffer)
- (insert-file-contents (concat "/tmp/esrc/" (car files) ".rtl"))
- (while (re-search-forward ";; Function \\|(call_insn " nil t)
- (if (= (char-after (- (point) 3)) ?o)
- (progn
- (looking-at "[a-zA-Z0-9_]+")
- (setq name (intern (buffer-substring (match-beginning 0)
- (match-end 0))))
- (message "%s : %s" (car files) name)
- (setq entry (list name)
- subrs-called (cons entry subrs-called)))
- (if (looking-at ".*\n?.*\"\\([A-Za-z0-9_]+\\)\"")
- (progn
- (setq name (intern (buffer-substring (match-beginning 1)
- (match-end 1))))
- (or (memq name (cdr entry))
- (setcdr entry (cons name (cdr entry))))))))
- (delete-file (concat "/tmp/esrc/" (car files) ".rtl"))
- (setq files (cdr files)))))
-)
-
-
-;;; This was originally generated directory-files, but there were
-;;; too many files there that were not actually compiled. The
-;;; list below was created for a HP-UX 7.0 system.
-
-(setq source-files '("dispnew.c" "scroll.c" "xdisp.c" "window.c"
- "term.c" "cm.c" "emacs.c" "keyboard.c" "macros.c"
- "keymap.c" "sysdep.c" "buffer.c" "filelock.c"
- "insdel.c" "marker.c" "minibuf.c" "fileio.c"
- "dired.c" "filemode.c" "cmds.c" "casefiddle.c"
- "indent.c" "search.c" "regex.c" "undo.c"
- "alloc.c" "data.c" "doc.c" "editfns.c"
- "callint.c" "eval.c" "fns.c" "print.c" "lread.c"
- "abbrev.c" "syntax.c" "unexec.c" "mocklisp.c"
- "bytecode.c" "process.c" "callproc.c" "doprnt.c"
- "x11term.c" "x11fns.c"))
-
-
-;;; This produces an inverted a-list in subrs-used. The cdr of each
-;;; entry is a list of functions that call the function in car.
-
-(defun trace-use-tree ()
- (setq subrs-used (mapcar 'list (mapcar 'car subrs-called)))
- (let ((ptr subrs-called)
- p2 found)
- (while ptr
- (setq p2 (car ptr))
- (while (setq p2 (cdr p2))
- (if (setq found (assq (car p2) subrs-used))
- (setcdr found (cons (car (car ptr)) (cdr found)))))
- (setq ptr (cdr ptr))))
-)
-
diff --git a/lisp/flame.el b/lisp/flame.el
new file mode 100644
index 00000000000..0f6d57852eb
--- /dev/null
+++ b/lisp/flame.el
@@ -0,0 +1,306 @@
+;;; "Flame" program. This has a chequered past.
+;;;
+;;; The original was on a Motorola 286 running Vanilla V.1,
+;;; about 2 years ago. It was couched in terms of a yacc (I think)
+;;; script. I pulled the data out of it and rewrote it as a piece
+;;; of PL/1 on Multics. Now I've moved it into an emacs-lisp
+;;; form. If the original author cares to contact me, I'd
+;;; be very happy to credit you!
+;;;
+;;; Ian G. Batten, Batten@uk.ac.bham.multics
+;;;
+
+(random t)
+
+(defvar sentence
+ '((how can you say that (statement) \?)
+ (I can\'t believe how (adjective) you are\.)
+ (only a (der-term) like you would say that (statement) \.)
+ ((statement) \, huh\?) (so\, (statement) \?)
+ ((statement) \, right\?) (I mean\, (sentence))
+ (don\'t you realise that (statement) \?)
+ (I firmly believe that (statement) \.)
+ (let me tell you something\, you (der-term) \, (statement) \.)
+ (furthermore\, you (der-term) \, (statement) \.)
+ (I couldn\'t care less about your (thing) \.)
+ (How can you be so (adjective) \?)
+ (you make me sick\.)
+ (it\'s well known that (statement) \.)
+ ((statement) \.)
+ (it takes a (group-adj) (der-term) like you to say that (statement) \.)
+ (I don\'t want to hear about your (thing) \.)
+ (you\'re always totally wrong\.)
+ (I\'ve never heard anything as ridiculous as the idea that (statement) \.)
+ (you must be a real (der-term) to think that (statement) \.)
+ (you (adjective) (group-adj) (der-term) \!)
+ (you\'re probably (group-adj) yourself\.)
+ (you sound like a real (der-term) \.)
+ (why\, (statement) \!)
+ (I have many (group-adj) friends\.)
+ (save the (thing) s\!) (no nukes\!) (ban (thing) s\!)
+ (I\'ll bet you think that (thing) s are (adjective) \.)
+ (you know\, (statement) \.)
+ (your (quality) reminds me of a (thing) \.)
+ (you have the (quality) of a (der-term) \.)
+ ((der-term) \!)
+ ((adjective) (group-adj) (der-term) \!)
+ (you\'re a typical (group-adj) person\, totally (adjective) \.)
+ (man\, (sentence))))
+
+(defvar sentence-loop (nconc sentence sentence))
+
+
+(defvar quality
+ '((ignorance) (stupidity) (worthlessness)
+ (prejudice) (lack of intelligence) (lousiness)
+ (bad grammar) (lousy spelling)
+ (lack of common decency) (ugliness) (nastiness)
+ (subtlety) (dishonesty) ((adjective) (quality))))
+
+
+(defvar quality-loop (nconc quality quality))
+
+(defvar adjective
+ '((ignorant) (crass) (pathetic) (sick)
+ (bloated) (malignant) (perverted) (sadistic)
+ (stupid) (unpleasant) (lousy) (abusive) (bad)
+ (braindamaged) (selfish) (improper) (nasty)
+ (disgusting) (foul) (intolerable) (primitive)
+ (depressing) (dumb) (phoney)
+ ((adjective) and (adjective))
+ (as (adjective) as a (thing))))
+
+(defvar adjective-loop (nconc adjective adjective))
+
+(defvar der-term
+ '(((adjective) (der-term)) (sexist) (fascist)
+ (weakling) (coward) (beast) (peasant) (racist)
+ (cretin) (fool) (jerk) (ignoramus) (idiot)
+ (wanker) (rat) (slimebag) (DAF driver)
+ (Neanderthal) (sadist) (drunk) (capitalist)
+ (wimp) (dogmatist) (wally) (maniac)
+ (whimpering scumbag) (pea brain) (arsehole)
+ (moron) (goof) (incompetant) (lunkhead) (Nazi)
+ (SysThug) ((der-term) (der-term))))
+
+(defvar der-term-loop (nconc der-term der-term))
+
+
+(defvar thing
+ '(((adjective) (thing)) (computer)
+ (Honeywell dps8) (whale) (operation)
+ (sexist joke) (ten-incher) (dog) (MicroVAX II)
+ (source license) (real-time clock)
+ (mental problem) (sexual fantasy)
+ (venereal disease) (Jewish grandmother)
+ (cardboard cut-out) (punk haircut) (surfboard)
+ (system call) (wood-burning stove)
+ (graphics editor) (right wing death squad)
+ (disease) (vegetable) (religion)
+ (cruise missile) (bug fix) (lawyer) (copyright)
+ (PAD)))
+
+(defvar thing-loop (nconc thing thing))
+
+
+(defvar group-adj
+ '((gay) (old) (lesbian) (young) (black)
+ (Polish) ((adjective)) (white)
+ (mentally retarded) (Nicaraguan) (homosexual)
+ (dead) (underpriviledged) (religious)
+ ((thing) \-loving) (feminist) (foreign)
+ (intellectual) (crazy) (working) (unborn)
+ (Chinese) (short) ((adjective)) (poor) (rich)
+ (funny-looking) (Puerto Rican) (Mexican)
+ (Italian) (communist) (fascist) (Iranian)
+ (Moonie)))
+
+(defvar group-adj-loop (nconc group-adj group-adj))
+
+(defvar statement
+ '((your (thing) is great) ((thing) s are fun)
+ ((person) is a (der-term))
+ ((group-adj) people are (adjective))
+ (every (group-adj) person is a (der-term))
+ (most (group-adj) people have (thing) s)
+ (all (group-adj) dudes should get (thing) s)
+ ((person) is (group-adj)) (trees are (adjective))
+ (if you\'ve seen one (thing) \, you\'ve seen them all)
+ (you\'re (group-adj)) (you have a (thing))
+ (my (thing) is pretty good)
+ (the Martians are coming)
+ (the (paper) is always right)
+ (just because you read it in the (paper) that doesn\'t mean it\'s true)
+ ((person) was (group-adj))
+ ((person) \'s ghost is living in your (thing))
+ (you look like a (thing))
+ (the oceans are full of dirty fish)
+ (people are dying every day)
+ (a (group-adj) man ain\'t got nothing in the world these days)
+ (women are inherently superior to men)
+ (the system staff is fascist)
+ (there is life after death)
+ (the world is full of (der-term) s)
+ (you remind me of (person)) (technology is evil)
+ ((person) killed (person))
+ (the Russians are tapping your phone)
+ (the Earth is flat)
+ (it\'s OK to run down (group-adj) people)
+ (Multics is a really (adjective) operating system)
+ (the CIA killed (person))
+ (the sexual revolution is over)
+ (Lassie was (group-adj))
+ (the (group-adj) s have really got it all together)
+ (I was (person) in a previous life)
+ (breathing causes cancer)
+ (it\'s fun to be really (adjective))
+ ((quality) is pretty fun) (you\'re a (der-term))
+ (the (group-adj) culture is fascinating)
+ (when ya gotta go ya gotta go)
+ ((person) is (adjective))
+ ((person) \'s (quality) is (adjective))
+ (it\'s a wonderful day)
+ (everything is really a (thing))
+ (there\'s a (thing) in (person) \'s brain)
+ ((person) is a cool dude)
+ ((person) is just a figment of your imagination)
+ (the more (thing) s you have, the better)
+ (life is a (thing)) (life is (quality))
+ ((person) is (adjective))
+ ((group-adj) people are all (adjective) (der-term) s)
+ ((statement) \, and (statement))
+ ((statement) \, but (statement))
+ (I wish I had a (thing))
+ (you should have a (thing))
+ (you hope that (statement))
+ ((person) is secretly (group-adj))
+ (you wish you were (group-adj))
+ (you wish you were a (thing))
+ (I wish I were a (thing))
+ (you think that (statement))
+ ((statement) \, because (statement))
+ ((group-adj) people don\'t get married to (group-adj) people because (reason))
+ ((group-adj) people are all (adjective) because (reason))
+ ((group-adj) people are (adjective) \, and (reason))
+ (you must be a (adjective) (der-term) to think that (person) said (statement))
+ ((group-adj) people are inherently superior to (group-adj) people)
+ (God is Dead)))
+
+(defvar statement-loop (nconc statement statement))
+
+
+(defvar paper
+ '((Daily Mail) (Daily Express)
+ (Centre Bulletin) (Sun) (Daily Mirror)
+ (Daily Telegraph) (Beano) (Multics Manual)))
+
+(defvar paper-loop (nconc paper paper))
+
+
+(defvar person
+ '((Reagan) (Ken Thompson) (Dennis Ritchie)
+ (JFK) (the Pope) (Gadaffi) (Napoleon)
+ (Karl Marx) (Groucho) (Michael Jackson)
+ (Caesar) (Nietzsche) (Heidegger)
+ (Henry Kissinger) (Nixon) (Castro) (Thatcher)
+ (Attilla the Hun) (Alaric the Visigoth) (Hitler)))
+
+(defvar person-loop (nconc person person))
+
+(defvar reason
+ '((they don\'t want their children to grow up to be too lazy to steal)
+ (they can\'t tell them apart from (group-adj) dudes)
+ (they\'re too (adjective))
+ ((person) wouldn\'t have done it)
+ (they can\'t spray paint that small)
+ (they don\'t have (thing) s) (they don\'t know how)
+ (they can\'t afford (thing) s)))
+
+(defvar reason-loop (nconc reason reason))
+
+(defmacro define-element (name)
+ (let ((loop-to-use (intern (concat name "-loop"))))
+ (` (defun (, (intern name)) nil
+ (let ((step-forward (% (random) 10)))
+ (if (< step-forward 0) (setq step-forward (- step-forward)))
+ (prog1
+ (nth step-forward (, loop-to-use))
+ (setq (, loop-to-use) (nthcdr (1+ step-forward) (, loop-to-use)))))))))
+
+(define-element "sentence")
+(define-element "quality")
+(define-element "adjective")
+(define-element "der-term")
+(define-element "group-adj")
+(define-element "statement")
+(define-element "thing")
+(define-element "paper")
+(define-element "person")
+(define-element "reason")
+
+(defun *flame nil
+ (flame-expand '(sentence)))
+
+(defun flame-expand (object)
+ (cond ((atom object)
+ object)
+ (t (mapcar 'flame-expand (funcall (car object))))))
+
+(defun flatten (list)
+ (cond ((atom list)
+ (list list))
+ (t (apply 'append (mapcar 'flatten list)))))
+
+(defun flame (arg)
+ "Generate ARG (default 1) sentences of half-crazed gibberish."
+ (interactive "p")
+ (let ((w (selected-window)))
+ (pop-to-buffer (get-buffer-create "*Flame*"))
+ (goto-char (point-max))
+ (insert ?\n)
+ (flame2 arg)
+ (select-window w)))
+
+(defun flame2 (arg)
+ (let ((start (point)))
+ (flame1 arg)
+ (fill-region-as-paragraph start (point) t)))
+
+(defun flame1 (arg)
+ (cond ((zerop arg) t)
+ (t (insert (concat (sentence-ify (string-ify (append-suffixes-hack (flatten (*flame)))))))
+ (flame1 (1- arg)))))
+
+(defun sentence-ify (string)
+ (concat (upcase (substring string 0 1))
+ (substring string 1 (length string))
+ " "))
+
+(defun string-ify (list)
+ (mapconcat
+ '(lambda (x)
+ (format "%s" x))
+ list
+ " "))
+
+(defun append-suffixes-hack (list)
+ (cond ((null list)
+ nil)
+ ((memq (nth 1 list)
+ '(\? \. \, s\! \! s \'s \-loving))
+ (cons (intern (format "%s%s" (nth 0 list) (nth 1 list)))
+ (append-suffixes-hack (nthcdr 2 list))))
+ (t (cons (nth 0 list)
+ (append-suffixes-hack (nthcdr 1 list))))))
+
+(defun psychoanalyze-flamer ()
+ "Mr. Angry goes to the analyst."
+ (interactive)
+ (doctor) ; start the psychotherapy
+ (message "")
+ (switch-to-buffer "*doctor*")
+ (sit-for 0)
+ (while (not (input-pending-p))
+ (flame2 (if (= (% (random) 2) 0) 2 1))
+ (sit-for 0)
+ (doctor-ret-or-read 1)))
diff --git a/lisp/flame.elc b/lisp/flame.elc
new file mode 100644
index 00000000000..3b620a0df54
--- /dev/null
+++ b/lisp/flame.elc
Binary files differ
diff --git a/lisp/float-sup.el b/lisp/float-sup.el
deleted file mode 100644
index d7b756238d3..00000000000
--- a/lisp/float-sup.el
+++ /dev/null
@@ -1,52 +0,0 @@
-;; Basic editing commands for Emacs
-;; Copyright (C) 1985, 1986, 1987 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;; Provide a meaningful error message if we are running on
-;; bare (non-float) emacs.
-;; Can't test for 'floatp since that may be defined by float-imitation
-;; packages like float.el in this very directory.
-
-(if (fboundp 'atan)
- nil
- (error "Floating point was disabled at compile time"))
-
-;; provide an easy hook to tell if we are running with floats or not.
-(provide 'lisp-float-type)
-
-;; define pi and e via math-lib calls. (much less prone to killer typos.)
-(defconst pi (* 4 (atan 1)) "The value of Pi (3.1415926...)")
-(defconst e (exp 1) "The value of e (2.7182818...)")
-
-;; Careful when editing this file ... typos here will be hard to spot.
-;; (defconst pi 3.14159265358979323846264338327
-;; "The value of Pi (3.14159265358979323846264338327...)")
-
-(defconst degrees-to-radians (/ pi 180.0)
- "Degrees to radian conversion constant")
-(defconst radians-to-degrees (/ 180.0 pi)
- "Radian to degree conversion constant")
-
-;; these expand to a single multiply by a float when byte compiled
-
-(defmacro degrees-to-radians (x)
- "Convert ARG from degrees to radians."
- (list '* (/ pi 180.0) x))
-(defmacro radians-to-degrees (x)
- "Convert ARG from radians to degrees."
- (list '* (/ 180.0 pi) x))
diff --git a/lisp/emacs-lisp/float.el b/lisp/float.el
index 68b88f41ecc..9e986eed129 100644
--- a/lisp/emacs-lisp/float.el
+++ b/lisp/float.el
@@ -68,9 +68,16 @@
(defconst mantissa-maxval (1- (ash 1 maxbit))
"Maximum permissable value of mantissa")
-(defconst mantissa-minval (ash 1 maxbit)
+;;; Note that this value can't be plain (ash 1 maxbit), since
+;;; (- (ash 1 maxbit)) = (ash 1 maxbit) - it overflows.
+(defconst mantissa-minval (1- (ash 1 maxbit))
"Minimum permissable value of mantissa")
+;;; This is used when normalizing negative numbers; if the number is
+;;; less than this, multiplying it by 2 will overflow past
+;;; mantissa-minval.
+(defconst mantissa-half-minval (ash (ash 1 maxbit) -1))
+
(defconst floating-point-regexp
"^[ \t]*\\(-?\\)\\([0-9]*\\)\
\\(\\.\\([0-9]*\\)\\|\\)\
@@ -120,14 +127,15 @@
(if (> (car fnum) 0) ; make sure next-to-highest bit is set
(while (zerop (logand (car fnum) second-bit-mask))
(setq fnum (fashl fnum)))
- (if (< (car fnum) 0) ; make sure highest bit is set
- (while (zerop (logand (car fnum) high-bit-mask))
+ (if (< (car fnum) 0) ; make sure next-to-highest bit is
+ ; zero, but fnum /= mantissa-minval.
+ (while (> (car fnum) mantissa-half-minval)
(setq fnum (fashl fnum)))
(setq fnum _f0))) ; "standard 0"
fnum)
(defun abs (n) ; integer absolute value
- (if (>= n 0) n (- n)))
+ (if (natnump n) n (- n)))
(defun fabs (fnum) ; re-normalize after taking abs value
(normalize (cons (abs (car fnum)) (cdr fnum))))
@@ -160,8 +168,8 @@
;; Arithmetic functions
(defun f+ (a1 a2)
"Returns the sum of two floating point numbers."
- (let ((f1 (fmax a1 a2))
- (f2 (fmin a1 a2)))
+ (let ((f1 (if (> (cdr a1) (cdr a2)) a1 a2))
+ (f2 (if (> (cdr a1) (cdr a2)) a2 a1)))
(if (same-sign a1 a2)
(setq f1 (fashr f1) ; shift right to avoid overflow
f2 (fashr f2)))
@@ -386,10 +394,11 @@ Optional second argument non-nil means use scientific notation."
;; digits of the exponent.
(defun string-to-float (str)
"Convert the string to a floating point number.
-Accepts a decimal string in scientific notation, with exponent preceded
-by either E or e. Only the six most significant digits of the integer
-and fractional parts are used; only the first two digits of the exponent
-are used. Negative signs preceding both the decimal number and the exponent
+Accepts a decimal string in scientific notation,
+with exponent preceded by either E or e.
+Only the 6 most significant digits of the integer and fractional parts
+are used; only the first two digits of the exponent are used.
+Negative signs preceding both the decimal number and the exponent
are recognized."
(if (string-match floating-point-regexp str 0)
@@ -446,3 +455,5 @@ are recognized."
(funcall func exponent (aref powers-of-10 tens)))))
_f0)) ; if invalid, return 0
+
+
diff --git a/lisp/float.elc b/lisp/float.elc
new file mode 100644
index 00000000000..8f2e82dd36b
--- /dev/null
+++ b/lisp/float.elc
Binary files differ
diff --git a/lisp/fortran.el b/lisp/fortran.el
new file mode 100644
index 00000000000..065cad638a0
--- /dev/null
+++ b/lisp/fortran.el
@@ -0,0 +1,654 @@
+;;; Fortran mode for GNU Emacs (beta test version 1.21, Oct. 1, 1985)
+;;; Copyright (c) 1986 Free Software Foundation, Inc.
+;;; Written by Michael D. Prange (prange@erl.mit.edu)
+
+;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Author acknowledges help from Stephen Gildea <gildea@erl.mit.edu>
+
+;;; Bugs to bug-fortran-mode@erl.mit.edu.
+
+(defvar fortran-do-indent 3
+ "*Extra indentation applied to `do' blocks.")
+
+(defvar fortran-if-indent 3
+ "*Extra indentation applied to `if' blocks.")
+
+(defvar fortran-continuation-indent 5
+ "*Extra indentation applied to `continuation' lines.")
+
+(defvar fortran-comment-indent-style 'fixed
+ "*nil forces comment lines not to be touched,
+'fixed produces fixed comment indentation to comment-column,
+and 'relative indents to current fortran indentation plus comment-column.")
+
+(defvar fortran-comment-line-column 6
+ "*Indentation for text in comment lines.")
+
+(defvar comment-line-start nil
+ "*Delimiter inserted to start new full-line comment.")
+
+(defvar comment-line-start-skip nil
+ "*Regexp to match the start of a full-line comment.")
+
+(defvar fortran-minimum-statement-indent 6
+ "*Minimum indentation for fortran statements.")
+
+;; Note that this is documented in the v18 manuals as being a string
+;; of length one rather than a single character.
+;; The code in this file accepts either format for compatibility.
+(defvar fortran-comment-indent-char ?
+ "*Character to be inserted for Fortran comment indentation.
+Normally a space.")
+
+(defvar fortran-line-number-indent 1
+ "*Maximum indentation for Fortran line numbers.
+5 means right-justify them within their five-column field.")
+
+(defvar fortran-check-all-num-for-matching-do nil
+ "*Non-nil causes all numbered lines to be treated as possible do-loop ends.")
+
+(defvar fortran-continuation-char ?$
+ "*Character which is inserted in column 5 by \\[fortran-split-line]
+to begin a continuation line. Normally $.")
+
+(defvar fortran-comment-region "c$$$"
+ "*String inserted by \\[fortran-comment-region] at start of each line in region.")
+
+(defvar fortran-electric-line-number t
+ "*Non-nil causes line number digits to be moved to the correct column as typed.")
+
+(defvar fortran-startup-message t
+ "*Non-nil displays a startup message when fortran-mode is first called.")
+
+(defvar fortran-column-ruler
+ (concat "0 4 6 10 20 30 40 50 60 70\n"
+ "[ ]|{ | | | | | | | | | | | | |}\n")
+ "*String displayed above current line by \\[fortran-column-ruler].")
+
+(defconst fortran-mode-version "1.21")
+
+(defvar fortran-mode-syntax-table nil
+ "Syntax table in use in fortran-mode buffers.")
+
+(if fortran-mode-syntax-table
+ ()
+ (setq fortran-mode-syntax-table (make-syntax-table))
+ (modify-syntax-entry ?\; "w" fortran-mode-syntax-table)
+ (modify-syntax-entry ?+ "." fortran-mode-syntax-table)
+ (modify-syntax-entry ?- "." fortran-mode-syntax-table)
+ (modify-syntax-entry ?* "." fortran-mode-syntax-table)
+ (modify-syntax-entry ?/ "." fortran-mode-syntax-table)
+ (modify-syntax-entry ?\' "\"" fortran-mode-syntax-table)
+ (modify-syntax-entry ?\" "\"" fortran-mode-syntax-table)
+ (modify-syntax-entry ?\\ "/" fortran-mode-syntax-table)
+ (modify-syntax-entry ?. "w" fortran-mode-syntax-table)
+ (modify-syntax-entry ?\n ">" fortran-mode-syntax-table))
+
+(defvar fortran-mode-map ()
+ "Keymap used in fortran mode.")
+
+(if fortran-mode-map
+ ()
+ (setq fortran-mode-map (make-sparse-keymap))
+ (define-key fortran-mode-map ";" 'fortran-abbrev-start)
+ (define-key fortran-mode-map "\C-c;" 'fortran-comment-region)
+ (define-key fortran-mode-map "\e\C-a" 'beginning-of-fortran-subprogram)
+ (define-key fortran-mode-map "\e\C-e" 'end-of-fortran-subprogram)
+ (define-key fortran-mode-map "\e;" 'fortran-indent-comment)
+ (define-key fortran-mode-map "\e\C-h" 'mark-fortran-subprogram)
+ (define-key fortran-mode-map "\e\n" 'fortran-split-line)
+ (define-key fortran-mode-map "\e\C-q" 'fortran-indent-subprogram)
+ (define-key fortran-mode-map "\C-c\C-w" 'fortran-window-create)
+ (define-key fortran-mode-map "\C-c\C-r" 'fortran-column-ruler)
+ (define-key fortran-mode-map "\C-c\C-p" 'fortran-previous-statement)
+ (define-key fortran-mode-map "\C-c\C-n" 'fortran-next-statement)
+ (define-key fortran-mode-map "\t" 'fortran-indent-line)
+ (define-key fortran-mode-map "0" 'fortran-electric-line-number)
+ (define-key fortran-mode-map "1" 'fortran-electric-line-number)
+ (define-key fortran-mode-map "2" 'fortran-electric-line-number)
+ (define-key fortran-mode-map "3" 'fortran-electric-line-number)
+ (define-key fortran-mode-map "4" 'fortran-electric-line-number)
+ (define-key fortran-mode-map "5" 'fortran-electric-line-number)
+ (define-key fortran-mode-map "6" 'fortran-electric-line-number)
+ (define-key fortran-mode-map "7" 'fortran-electric-line-number)
+ (define-key fortran-mode-map "8" 'fortran-electric-line-number)
+ (define-key fortran-mode-map "9" 'fortran-electric-line-number))
+
+(defvar fortran-mode-abbrev-table nil)
+(if fortran-mode-abbrev-table
+ ()
+ (define-abbrev-table 'fortran-mode-abbrev-table ())
+ (let ((abbrevs-changed nil))
+ (define-abbrev fortran-mode-abbrev-table ";b" "byte" nil)
+ (define-abbrev fortran-mode-abbrev-table ";ch" "character" nil)
+ (define-abbrev fortran-mode-abbrev-table ";cl" "close" nil)
+ (define-abbrev fortran-mode-abbrev-table ";c" "continue" nil)
+ (define-abbrev fortran-mode-abbrev-table ";cm" "common" nil)
+ (define-abbrev fortran-mode-abbrev-table ";cx" "complex" nil)
+ (define-abbrev fortran-mode-abbrev-table ";di" "dimension" nil)
+ (define-abbrev fortran-mode-abbrev-table ";do" "double" nil)
+ (define-abbrev fortran-mode-abbrev-table ";dc" "double complex" nil)
+ (define-abbrev fortran-mode-abbrev-table ";dp" "double precision" nil)
+ (define-abbrev fortran-mode-abbrev-table ";dw" "do while" nil)
+ (define-abbrev fortran-mode-abbrev-table ";e" "else" nil)
+ (define-abbrev fortran-mode-abbrev-table ";ed" "enddo" nil)
+ (define-abbrev fortran-mode-abbrev-table ";el" "elseif" nil)
+ (define-abbrev fortran-mode-abbrev-table ";en" "endif" nil)
+ (define-abbrev fortran-mode-abbrev-table ";eq" "equivalence" nil)
+ (define-abbrev fortran-mode-abbrev-table ";ex" "external" nil)
+ (define-abbrev fortran-mode-abbrev-table ";ey" "entry" nil)
+ (define-abbrev fortran-mode-abbrev-table ";f" "format" nil)
+ (define-abbrev fortran-mode-abbrev-table ";fu" "function" nil)
+ (define-abbrev fortran-mode-abbrev-table ";g" "goto" nil)
+ (define-abbrev fortran-mode-abbrev-table ";im" "implicit" nil)
+ (define-abbrev fortran-mode-abbrev-table ";ib" "implicit byte" nil)
+ (define-abbrev fortran-mode-abbrev-table ";ic" "implicit complex" nil)
+ (define-abbrev fortran-mode-abbrev-table ";ich" "implicit character" nil)
+ (define-abbrev fortran-mode-abbrev-table ";ii" "implicit integer" nil)
+ (define-abbrev fortran-mode-abbrev-table ";il" "implicit logical" nil)
+ (define-abbrev fortran-mode-abbrev-table ";ir" "implicit real" nil)
+ (define-abbrev fortran-mode-abbrev-table ";inc" "include" nil)
+ (define-abbrev fortran-mode-abbrev-table ";in" "integer" nil)
+ (define-abbrev fortran-mode-abbrev-table ";intr" "intrinsic" nil)
+ (define-abbrev fortran-mode-abbrev-table ";l" "logical" nil)
+ (define-abbrev fortran-mode-abbrev-table ";op" "open" nil)
+ (define-abbrev fortran-mode-abbrev-table ";pa" "parameter" nil)
+ (define-abbrev fortran-mode-abbrev-table ";pr" "program" nil)
+ (define-abbrev fortran-mode-abbrev-table ";p" "print" nil)
+ (define-abbrev fortran-mode-abbrev-table ";re" "real" nil)
+ (define-abbrev fortran-mode-abbrev-table ";r" "read" nil)
+ (define-abbrev fortran-mode-abbrev-table ";rt" "return" nil)
+ (define-abbrev fortran-mode-abbrev-table ";rw" "rewind" nil)
+ (define-abbrev fortran-mode-abbrev-table ";s" "stop" nil)
+ (define-abbrev fortran-mode-abbrev-table ";su" "subroutine" nil)
+ (define-abbrev fortran-mode-abbrev-table ";ty" "type" nil)
+ (define-abbrev fortran-mode-abbrev-table ";w" "write" nil)))
+
+(defun fortran-mode ()
+ "Major mode for editing fortran code.
+Tab indents the current fortran line correctly.
+`do' statements must not share a common `continue'.
+
+Type `;?' or `;\\[help-command]' to display a list of built-in abbrevs for Fortran keywords.
+
+Variables controlling indentation style and extra features:
+
+ comment-start
+ Normally nil in Fortran mode. If you want to use comments
+ starting with `!', set this to the string \"!\".
+ fortran-do-indent
+ Extra indentation within do blocks. (default 3)
+ fortran-if-indent
+ Extra indentation within if blocks. (default 3)
+ fortran-continuation-indent
+ Extra indentation appled to continuation statements. (default 5)
+ fortran-comment-line-column
+ Amount of indentation for text within full-line comments. (default 6)
+ fortran-comment-indent-style
+ nil means don't change indentation of text in full-line comments,
+ fixed means indent that text at column fortran-comment-line-column
+ relative means indent at fortran-comment-line-column beyond the
+ indentation for a line of code.
+ Default value is fixed.
+ fortran-comment-indent-char
+ Character to be inserted instead of space for full-line comment
+ indentation. (default is a space)
+ fortran-minimum-statement-indent
+ Minimum indentation for fortran statements. (default 6)
+ fortran-line-number-indent
+ Maximum indentation for line numbers. A line number will get
+ less than this much indentation if necessary to avoid reaching
+ column 5. (default 1)
+ fortran-check-all-num-for-matching-do
+ Non-nil causes all numbered lines to be treated as possible 'continue'
+ statements. (default nil)
+ fortran-continuation-char
+ character to be inserted in column 5 of a continuation line.
+ (default $)
+ fortran-comment-region
+ String inserted by \\[fortran-comment-region] at start of each line in
+ region. (default \"c$$$\")
+ fortran-electric-line-number
+ Non-nil causes line number digits to be moved to the correct column
+ as typed. (default t)
+ fortran-startup-message
+ Set to nil to inhibit message first time fortran-mode is used.
+
+Turning on Fortran mode calls the value of the variable fortran-mode-hook
+with no args, if that value is non-nil.
+\\{fortran-mode-map}"
+ (interactive)
+ (kill-all-local-variables)
+ (if fortran-startup-message
+ (message "Emacs Fortran mode version %s. Bugs to bug-fortran-mode@erl.mit.edu" fortran-mode-version))
+ (setq fortran-startup-message nil)
+ (setq local-abbrev-table fortran-mode-abbrev-table)
+ (set-syntax-table fortran-mode-syntax-table)
+ (make-local-variable 'indent-line-function)
+ (setq indent-line-function 'fortran-indent-line)
+ (make-local-variable 'comment-indent-hook)
+ (setq comment-indent-hook 'fortran-comment-hook)
+ (make-local-variable 'comment-line-start-skip)
+ (setq comment-line-start-skip "^[Cc*][^ \t\n]*[ \t]*") ;[^ \t\n]* handles comment strings such as c$$$
+ (make-local-variable 'comment-line-start)
+ (setq comment-line-start "c")
+ (make-local-variable 'comment-start-skip)
+ (setq comment-start-skip "![ \t]*")
+ (make-local-variable 'comment-start)
+ (setq comment-start nil)
+ (make-local-variable 'require-final-newline)
+ (setq require-final-newline t)
+ (make-local-variable 'abbrev-all-caps)
+ (setq abbrev-all-caps t)
+ (make-local-variable 'indent-tabs-mode)
+ (setq indent-tabs-mode nil)
+ (use-local-map fortran-mode-map)
+ (setq mode-name "Fortran")
+ (setq major-mode 'fortran-mode)
+ (run-hooks 'fortran-mode-hook))
+
+(defun fortran-comment-hook ()
+ (save-excursion
+ (skip-chars-backward " \t")
+ (max (+ 1 (current-column))
+ comment-column)))
+
+(defun fortran-indent-comment ()
+ "Align or create comment on current line.
+Existing comments of all types are recognized and aligned.
+If the line has no comment, a side-by-side comment is inserted and aligned
+if the value of comment-start is not nil.
+Otherwise, a separate-line comment is inserted, on this line
+or on a new line inserted before this line if this line is not blank."
+ (interactive)
+ (beginning-of-line)
+ ;; Recognize existing comments of either kind.
+ (cond ((looking-at comment-line-start-skip)
+ (fortran-indent-line))
+ ((re-search-forward comment-start-skip
+ (save-excursion (end-of-line) (point)) t)
+ (indent-for-comment))
+ ;; No existing comment.
+ ;; If side-by-side comments are defined, insert one,
+ ;; unless line is now blank.
+ ((and comment-start (not (looking-at "^[ \t]*$")))
+ (end-of-line)
+ (delete-horizontal-space)
+ (indent-to (fortran-comment-hook))
+ (insert comment-start))
+ ;; Else insert separate-line comment, making a new line if nec.
+ (t
+ (if (looking-at "^[ \t]*$")
+ (delete-horizontal-space)
+ (beginning-of-line)
+ (insert "\n")
+ (forward-char -1))
+ (insert comment-line-start)
+ (insert-char (if (stringp fortran-comment-indent-char)
+ (aref fortran-comment-indent-char 0)
+ fortran-comment-indent-char)
+ (- (calculate-fortran-indent) (current-column))))))
+
+(defun fortran-comment-region (beg-region end-region arg)
+ "Comments every line in the region.
+Puts fortran-comment-region at the beginning of every line in the region.
+BEG-REGION and END-REGION are args which specify the region boundaries.
+With non-nil ARG, uncomments the region."
+ (interactive "*r\nP")
+ (let ((end-region-mark (make-marker)) (save-point (point-marker)))
+ (set-marker end-region-mark end-region)
+ (goto-char beg-region)
+ (beginning-of-line)
+ (if (not arg) ;comment the region
+ (progn (insert fortran-comment-region)
+ (while (and (= (forward-line 1) 0)
+ (< (point) end-region-mark))
+ (insert fortran-comment-region)))
+ (let ((com (regexp-quote fortran-comment-region))) ;uncomment the region
+ (if (looking-at com)
+ (delete-region (point) (match-end 0)))
+ (while (and (= (forward-line 1) 0)
+ (< (point) end-region-mark))
+ (if (looking-at com)
+ (delete-region (point) (match-end 0))))))
+ (goto-char save-point)
+ (set-marker end-region-mark nil)
+ (set-marker save-point nil)))
+
+(defun fortran-abbrev-start ()
+ "Typing \";\\[help-command]\" or \";?\" lists all the fortran abbrevs.
+Any other key combination is executed normally." ;\\[help-command] is just a way to print the value of the variable help-char.
+ (interactive)
+ (let (c)
+ (insert last-command-char)
+ (if (or (= (setq c (read-char)) ??) ;insert char if not equal to `?'
+ (= c help-char))
+ (fortran-abbrev-help)
+ (setq unread-command-char c))))
+
+(defun fortran-abbrev-help ()
+ "List the currently defined abbrevs in Fortran mode."
+ (interactive)
+ (message "Listing abbrev table...")
+ (require 'abbrevlist)
+ (list-one-abbrev-table fortran-mode-abbrev-table "*Help*")
+ (message "Listing abbrev table...done"))
+
+(defun fortran-column-ruler ()
+ "Inserts a column ruler momentarily above current line, till next keystroke.
+The ruler is defined by the value of fortran-column-ruler.
+The key typed is executed unless it is SPC."
+ (interactive)
+ (momentary-string-display
+ fortran-column-ruler (save-excursion (beginning-of-line) (point))
+ nil "Type SPC or any command to erase ruler."))
+
+(defun fortran-window-create ()
+ "Makes the window 72 columns wide."
+ (interactive)
+ (let ((window-min-width 2))
+ (split-window-horizontally 73))
+ (other-window 1)
+ (switch-to-buffer " fortran-window-extra" t)
+ (select-window (previous-window)))
+
+(defun fortran-split-line ()
+ "Break line at point and insert continuation marker and alignment."
+ (interactive)
+ (delete-horizontal-space)
+ (if (save-excursion (beginning-of-line) (looking-at comment-line-start-skip))
+ (insert "\n" comment-line-start " ")
+ (insert "\n " fortran-continuation-char))
+ (fortran-indent-line))
+
+(defun delete-horizontal-regexp (chars)
+ "Delete all characters in CHARS around point.
+CHARS is like the inside of a [...] in a regular expression
+except that ] is never special and \ quotes ^, - or \."
+ (interactive "*s")
+ (skip-chars-backward chars)
+ (delete-region (point) (progn (skip-chars-forward chars) (point))))
+
+(defun fortran-electric-line-number (arg)
+ "Self insert, but if part of a Fortran line number indent it automatically.
+Auto-indent does not happen if a numeric arg is used."
+ (interactive "P")
+ (if (or arg (not fortran-electric-line-number))
+ (self-insert-command arg)
+ (if (or (save-excursion (re-search-backward "[^ \t0-9]"
+ (save-excursion
+ (beginning-of-line)
+ (point))
+ t)) ;not a line number
+ (looking-at "[0-9]")) ;within a line number
+ (insert last-command-char)
+ (skip-chars-backward " \t")
+ (insert last-command-char)
+ (fortran-indent-line))))
+
+(defun beginning-of-fortran-subprogram ()
+ "Moves point to the beginning of the current fortran subprogram."
+ (interactive)
+ (let ((case-fold-search t))
+ (beginning-of-line -1)
+ (re-search-backward "^[ \t0-9]*end\\b[ \t]*[^ \t=(a-z]" nil 'move)
+ (if (looking-at "^[ \t0-9]*end\\b[ \t]*[^ \t=(a-z]")
+ (forward-line 1))))
+
+(defun end-of-fortran-subprogram ()
+ "Moves point to the end of the current fortran subprogram."
+ (interactive)
+ (let ((case-fold-search t))
+ (beginning-of-line 2)
+ (re-search-forward "^[ \t0-9]*end\\b[ \t]*[^ \t=(a-z]" nil 'move)
+ (goto-char (match-beginning 0))
+ (forward-line 1)))
+
+(defun mark-fortran-subprogram ()
+ "Put mark at end of fortran subprogram, point at beginning.
+The marks are pushed."
+ (interactive)
+ (end-of-fortran-subprogram)
+ (push-mark (point))
+ (beginning-of-fortran-subprogram))
+
+(defun fortran-previous-statement ()
+ "Moves point to beginning of the previous fortran statement.
+Returns 'first-statement if that statement is the first
+non-comment Fortran statement in the file, and nil otherwise."
+ (interactive)
+ (let (not-first-statement continue-test)
+ (beginning-of-line)
+ (setq continue-test
+ (or (looking-at
+ (concat "[ \t]*" (regexp-quote (char-to-string
+ fortran-continuation-char))))
+ (looking-at " [^ 0\n]")))
+ (while (and (setq not-first-statement (= (forward-line -1) 0))
+ (or (looking-at comment-line-start-skip)
+ (looking-at "[ \t]*$")
+ (looking-at " [^ 0\n]")
+ (looking-at (concat "[ \t]*" comment-start-skip)))))
+ (cond ((and continue-test
+ (not not-first-statement))
+ (message "Incomplete continuation statement."))
+ (continue-test
+ (fortran-previous-statement))
+ ((not not-first-statement)
+ 'first-statement))))
+
+(defun fortran-next-statement ()
+ "Moves point to beginning of the next fortran statement.
+ Returns 'last-statement if that statement is the last
+ non-comment Fortran statement in the file, and nil otherwise."
+ (interactive)
+ (let (not-last-statement)
+ (beginning-of-line)
+ (while (and (setq not-last-statement (= (forward-line 1) 0))
+ (or (looking-at comment-line-start-skip)
+ (looking-at "[ \t]*$")
+ (looking-at " [^ 0\n]")
+ (looking-at (concat "[ \t]*" comment-start-skip)))))
+ (if (not not-last-statement)
+ 'last-statement)))
+
+(defun fortran-indent-line ()
+ "Indents current fortran line based on its contents and on previous lines."
+ (interactive)
+ (let ((cfi (calculate-fortran-indent)))
+ (save-excursion
+ (beginning-of-line)
+ (if (or (not (= cfi (fortran-current-line-indentation)))
+ (and (re-search-forward "^[ \t]*[0-9]+" (+ (point) 4) t)
+ (not (fortran-line-number-indented-correctly-p))))
+ (fortran-indent-to-column cfi)
+ (beginning-of-line)
+ (if (re-search-forward comment-start-skip
+ (save-excursion (end-of-line) (point)) 'move)
+ (fortran-indent-comment))))
+ ;; Never leave point in left margin.
+ (if (< (current-column) cfi)
+ (move-to-column cfi))))
+
+(defun fortran-indent-subprogram ()
+ "Properly indents the Fortran subprogram which contains point."
+ (interactive)
+ (save-excursion
+ (mark-fortran-subprogram)
+ (message "Indenting subprogram...")
+ (indent-region (point) (mark) nil))
+ (message "Indenting subprogram...done."))
+
+(defun calculate-fortran-indent ()
+ "Calculates the fortran indent column based on previous lines."
+ (let (icol first-statement (case-fold-search t))
+ (save-excursion
+ (setq first-statement (fortran-previous-statement))
+ (if first-statement
+ (setq icol fortran-minimum-statement-indent)
+ (progn
+ (if (= (point) (point-min))
+ (setq icol fortran-minimum-statement-indent)
+ (setq icol (fortran-current-line-indentation)))
+ (skip-chars-forward " \t0-9")
+ (cond ((looking-at "if[ \t]*(")
+ (if (or (looking-at ".*)[ \t]*then\\b[ \t]*[^ \t(=a-z0-9]")
+ (let (then-test) ;multi-line if-then
+ (while (and (= (forward-line 1) 0) ;search forward for then
+ (looking-at " [^ 0]")
+ (not (setq then-test (looking-at ".*then\\b[ \t]*[^ \t(=a-z0-9]")))))
+ then-test))
+ (setq icol (+ icol fortran-if-indent))))
+ ((looking-at "\\(else\\|elseif\\)\\b")
+ (setq icol (+ icol fortran-if-indent)))
+ ((looking-at "do\\b")
+ (setq icol (+ icol fortran-do-indent)))))))
+ (save-excursion
+ (beginning-of-line)
+ (cond ((looking-at "[ \t]*$"))
+ ((looking-at comment-line-start-skip)
+ (cond ((eq fortran-comment-indent-style 'relative)
+ (setq icol (+ icol fortran-comment-line-column)))
+ ((eq fortran-comment-indent-style 'fixed)
+ (setq icol fortran-comment-line-column))))
+ ((or (looking-at (concat "[ \t]*"
+ (regexp-quote (char-to-string fortran-continuation-char))))
+ (looking-at " [^ 0\n]"))
+ (setq icol (+ icol fortran-continuation-indent)))
+ (first-statement)
+ ((and fortran-check-all-num-for-matching-do
+ (looking-at "[ \t]*[0-9]+")
+ (fortran-check-for-matching-do))
+ (setq icol (- icol fortran-do-indent)))
+ (t
+ (skip-chars-forward " \t0-9")
+ (cond ((looking-at "end[ \t]*if\\b")
+ (setq icol (- icol fortran-if-indent)))
+ ((looking-at "\\(else\\|elseif\\)\\b")
+ (setq icol (- icol fortran-if-indent)))
+ ((and (looking-at "continue\\b")
+ (fortran-check-for-matching-do))
+ (setq icol (- icol fortran-do-indent)))
+ ((looking-at "end[ \t]*do\\b")
+ (setq icol (- icol fortran-do-indent)))
+ ((and (looking-at "end\\b[ \t]*[^ \t=(a-z]")
+ (not (= icol fortran-minimum-statement-indent)))
+ (message "Warning: `end' not in column %d. Probably an unclosed block." fortran-minimum-statement-indent))))))
+ (max fortran-minimum-statement-indent icol)))
+
+(defun fortran-current-line-indentation ()
+ "Indentation of current line, ignoring Fortran line number or continuation.
+This is the column position of the first non-whitespace character
+aside from the line number and/or column 5 line-continuation character.
+For comment lines, returns indentation of the first
+non-indentation text within the comment."
+ (save-excursion
+ (beginning-of-line)
+ (cond ((looking-at comment-line-start-skip)
+ (goto-char (match-end 0))
+ (skip-chars-forward
+ (if (stringp fortran-comment-indent-char)
+ fortran-comment-indent-char
+ (char-to-string fortran-comment-indent-char))))
+ ((looking-at " [^ 0\n]")
+ (goto-char (match-end 0)))
+ (t
+ ;; Move past line number.
+ (move-to-column 5)))
+ ;; Move past whitespace.
+ (skip-chars-forward " \t")
+ (current-column)))
+
+(defun fortran-indent-to-column (col)
+ "Indents current line with spaces to column COL.
+notes: 1) A non-zero/non-blank character in column 5 indicates a continuation
+ line, and this continuation character is retained on indentation;
+ 2) If fortran-continuation-char is the first non-whitespace character,
+ this is a continuation line;
+ 3) A non-continuation line which has a number as the first
+ non-whitespace character is a numbered line."
+ (save-excursion
+ (beginning-of-line)
+ (if (looking-at comment-line-start-skip)
+ (if fortran-comment-indent-style
+ (let ((char (if (stringp fortran-comment-indent-char)
+ (aref fortran-comment-indent-char 0)
+ fortran-comment-indent-char)))
+ (goto-char (match-end 0))
+ (delete-horizontal-regexp (concat " \t" (char-to-string char)))
+ (insert-char char (- col (current-column)))))
+ (if (looking-at " [^ 0\n]")
+ (forward-char 6)
+ (delete-horizontal-space)
+ ;; Put line number in columns 0-4
+ ;; or put continuation character in column 5.
+ (cond ((eobp))
+ ((= (following-char) fortran-continuation-char)
+ (indent-to 5)
+ (forward-char 1))
+ ((looking-at "[0-9]+")
+ (let ((extra-space (- 5 (- (match-end 0) (point)))))
+ (if (< extra-space 0)
+ (message "Warning: line number exceeds 5-digit limit.")
+ (indent-to (min fortran-line-number-indent extra-space))))
+ (skip-chars-forward "0-9"))))
+ ;; Point is now after any continuation character or line number.
+ ;; Put body of statement where specified.
+ (delete-horizontal-space)
+ (indent-to col)
+ ;; Indent any comment following code on the same line.
+ (if (re-search-forward comment-start-skip
+ (save-excursion (end-of-line) (point)) t)
+ (progn (goto-char (match-beginning 0))
+ (if (not (= (current-column) (fortran-comment-hook)))
+ (progn (delete-horizontal-space)
+ (indent-to (fortran-comment-hook)))))))))
+
+(defun fortran-line-number-indented-correctly-p ()
+ "Return t if current line's line number is correctly indente.
+Do not call if there is no line number."
+ (save-excursion
+ (beginning-of-line)
+ (skip-chars-forward " \t")
+ (and (<= (current-column) fortran-line-number-indent)
+ (or (= (current-column) fortran-line-number-indent)
+ (progn (skip-chars-forward "0-9")
+ (= (current-column) 5))))))
+
+(defun fortran-check-for-matching-do ()
+ "When called from a numbered statement, returns t
+ if matching 'do' is found, and nil otherwise."
+ (let (charnum
+ (case-fold-search t))
+ (save-excursion
+ (beginning-of-line)
+ (if (looking-at "[ \t]*[0-9]+")
+ (progn
+ (skip-chars-forward " \t")
+ (skip-chars-forward "0") ;skip past leading zeros
+ (setq charnum (buffer-substring (point)
+ (progn (skip-chars-forward "0-9")
+ (point))))
+ (beginning-of-line)
+ (and (re-search-backward
+ (concat "\\(^[ \t0-9]*end\\b[ \t]*[^ \t=(a-z]\\)\\|\\(^[ \t0-9]*do[ \t]*0*"
+ charnum "\\b\\)\\|\\(^[ \t]*0*" charnum "\\b\\)")
+ nil t)
+ (looking-at (concat "^[ \t0-9]*do[ \t]*0*" charnum))))))))
+
+
diff --git a/lisp/fortran.elc b/lisp/fortran.elc
new file mode 100644
index 00000000000..8759a793f28
--- /dev/null
+++ b/lisp/fortran.elc
@@ -0,0 +1,242 @@
+
+(defvar fortran-do-indent 3 "\
+*Extra indentation applied to `do' blocks.")
+
+(defvar fortran-if-indent 3 "\
+*Extra indentation applied to `if' blocks.")
+
+(defvar fortran-continuation-indent 5 "\
+*Extra indentation applied to `continuation' lines.")
+
+(defvar fortran-comment-indent-style (quote fixed) "\
+*nil forces comment lines not to be touched,
+'fixed produces fixed comment indentation to comment-column,
+and 'relative indents to current fortran indentation plus comment-column.")
+
+(defvar fortran-comment-line-column 6 "\
+*Indentation for text in comment lines.")
+
+(defvar comment-line-start nil "\
+*Delimiter inserted to start new full-line comment.")
+
+(defvar comment-line-start-skip nil "\
+*Regexp to match the start of a full-line comment.")
+
+(defvar fortran-minimum-statement-indent 6 "\
+*Minimum indentation for fortran statements.")
+
+(defvar fortran-comment-indent-char 32 "\
+*Character to be inserted for Fortran comment indentation.
+Normally a space.")
+
+(defvar fortran-line-number-indent 1 "\
+*Maximum indentation for Fortran line numbers.
+5 means right-justify them within their five-column field.")
+
+(defvar fortran-check-all-num-for-matching-do nil "\
+*Non-nil causes all numbered lines to be treated as possible do-loop ends.")
+
+(defvar fortran-continuation-char 36 "\
+*Character which is inserted in column 5 by \\[fortran-split-line]
+to begin a continuation line. Normally $.")
+
+(defvar fortran-comment-region "c$$$" "\
+*String inserted by \\[fortran-comment-region] at start of each line in region.")
+
+(defvar fortran-electric-line-number t "\
+*Non-nil causes line number digits to be moved to the correct column as typed.")
+
+(defvar fortran-startup-message t "\
+*Non-nil displays a startup message when fortran-mode is first called.")
+
+(defvar fortran-column-ruler (concat "0 4 6 10 20 30 40 50 60 70
+" "[ ]|{ | | | | | | | | | | | | |}
+") "*String displayed above current line by \\[fortran-column-ruler].")
+
+(defconst fortran-mode-version "1.21")
+
+(defvar fortran-mode-syntax-table nil "\
+Syntax table in use in fortran-mode buffers.")
+
+(if fortran-mode-syntax-table nil (setq fortran-mode-syntax-table (make-syntax-table)) (modify-syntax-entry 59 "w" fortran-mode-syntax-table) (modify-syntax-entry 43 "." fortran-mode-syntax-table) (modify-syntax-entry 45 "." fortran-mode-syntax-table) (modify-syntax-entry 42 "." fortran-mode-syntax-table) (modify-syntax-entry 47 "." fortran-mode-syntax-table) (modify-syntax-entry 39 "\"" fortran-mode-syntax-table) (modify-syntax-entry 34 "\"" fortran-mode-syntax-table) (modify-syntax-entry 92 "/" fortran-mode-syntax-table) (modify-syntax-entry 46 "w" fortran-mode-syntax-table) (modify-syntax-entry 10 ">" fortran-mode-syntax-table))
+
+(defvar fortran-mode-map nil "\
+Keymap used in fortran mode.")
+
+(if fortran-mode-map nil (setq fortran-mode-map (make-sparse-keymap)) (define-key fortran-mode-map ";" (quote fortran-abbrev-start)) (define-key fortran-mode-map ";" (quote fortran-comment-region)) (define-key fortran-mode-map "" (quote beginning-of-fortran-subprogram)) (define-key fortran-mode-map "" (quote end-of-fortran-subprogram)) (define-key fortran-mode-map ";" (quote fortran-indent-comment)) (define-key fortran-mode-map "" (quote mark-fortran-subprogram)) (define-key fortran-mode-map "
+" (quote fortran-split-line)) (define-key fortran-mode-map "" (quote fortran-indent-subprogram)) (define-key fortran-mode-map "" (quote fortran-window-create)) (define-key fortran-mode-map "" (quote fortran-column-ruler)) (define-key fortran-mode-map "" (quote fortran-previous-statement)) (define-key fortran-mode-map "" (quote fortran-next-statement)) (define-key fortran-mode-map " " (quote fortran-indent-line)) (define-key fortran-mode-map "0" (quote fortran-electric-line-number)) (define-key fortran-mode-map "1" (quote fortran-electric-line-number)) (define-key fortran-mode-map "2" (quote fortran-electric-line-number)) (define-key fortran-mode-map "3" (quote fortran-electric-line-number)) (define-key fortran-mode-map "4" (quote fortran-electric-line-number)) (define-key fortran-mode-map "5" (quote fortran-electric-line-number)) (define-key fortran-mode-map "6" (quote fortran-electric-line-number)) (define-key fortran-mode-map "7" (quote fortran-electric-line-number)) (define-key fortran-mode-map "8" (quote fortran-electric-line-number)) (define-key fortran-mode-map "9" (quote fortran-electric-line-number)))
+
+(defvar fortran-mode-abbrev-table nil)
+
+(if fortran-mode-abbrev-table nil (define-abbrev-table (quote fortran-mode-abbrev-table) nil) (let ((abbrevs-changed nil)) (define-abbrev fortran-mode-abbrev-table ";b" "byte" nil) (define-abbrev fortran-mode-abbrev-table ";ch" "character" nil) (define-abbrev fortran-mode-abbrev-table ";cl" "close" nil) (define-abbrev fortran-mode-abbrev-table ";c" "continue" nil) (define-abbrev fortran-mode-abbrev-table ";cm" "common" nil) (define-abbrev fortran-mode-abbrev-table ";cx" "complex" nil) (define-abbrev fortran-mode-abbrev-table ";di" "dimension" nil) (define-abbrev fortran-mode-abbrev-table ";do" "double" nil) (define-abbrev fortran-mode-abbrev-table ";dc" "double complex" nil) (define-abbrev fortran-mode-abbrev-table ";dp" "double precision" nil) (define-abbrev fortran-mode-abbrev-table ";dw" "do while" nil) (define-abbrev fortran-mode-abbrev-table ";e" "else" nil) (define-abbrev fortran-mode-abbrev-table ";ed" "enddo" nil) (define-abbrev fortran-mode-abbrev-table ";el" "elseif" nil) (define-abbrev fortran-mode-abbrev-table ";en" "endif" nil) (define-abbrev fortran-mode-abbrev-table ";eq" "equivalence" nil) (define-abbrev fortran-mode-abbrev-table ";ex" "external" nil) (define-abbrev fortran-mode-abbrev-table ";ey" "entry" nil) (define-abbrev fortran-mode-abbrev-table ";f" "format" nil) (define-abbrev fortran-mode-abbrev-table ";fu" "function" nil) (define-abbrev fortran-mode-abbrev-table ";g" "goto" nil) (define-abbrev fortran-mode-abbrev-table ";im" "implicit" nil) (define-abbrev fortran-mode-abbrev-table ";ib" "implicit byte" nil) (define-abbrev fortran-mode-abbrev-table ";ic" "implicit complex" nil) (define-abbrev fortran-mode-abbrev-table ";ich" "implicit character" nil) (define-abbrev fortran-mode-abbrev-table ";ii" "implicit integer" nil) (define-abbrev fortran-mode-abbrev-table ";il" "implicit logical" nil) (define-abbrev fortran-mode-abbrev-table ";ir" "implicit real" nil) (define-abbrev fortran-mode-abbrev-table ";inc" "include" nil) (define-abbrev fortran-mode-abbrev-table ";in" "integer" nil) (define-abbrev fortran-mode-abbrev-table ";intr" "intrinsic" nil) (define-abbrev fortran-mode-abbrev-table ";l" "logical" nil) (define-abbrev fortran-mode-abbrev-table ";op" "open" nil) (define-abbrev fortran-mode-abbrev-table ";pa" "parameter" nil) (define-abbrev fortran-mode-abbrev-table ";pr" "program" nil) (define-abbrev fortran-mode-abbrev-table ";p" "print" nil) (define-abbrev fortran-mode-abbrev-table ";re" "real" nil) (define-abbrev fortran-mode-abbrev-table ";r" "read" nil) (define-abbrev fortran-mode-abbrev-table ";rt" "return" nil) (define-abbrev fortran-mode-abbrev-table ";rw" "rewind" nil) (define-abbrev fortran-mode-abbrev-table ";s" "stop" nil) (define-abbrev fortran-mode-abbrev-table ";su" "subroutine" nil) (define-abbrev fortran-mode-abbrev-table ";ty" "type" nil) (define-abbrev fortran-mode-abbrev-table ";w" "write" nil)))
+
+(defun fortran-mode nil "\
+Major mode for editing fortran code.
+Tab indents the current fortran line correctly.
+`do' statements must not share a common `continue'.
+
+Type `;?' or `;\\[help-command]' to display a list of built-in abbrevs for Fortran keywords.
+
+Variables controlling indentation style and extra features:
+
+ comment-start
+ Normally nil in Fortran mode. If you want to use comments
+ starting with `!', set this to the string \"!\".
+ fortran-do-indent
+ Extra indentation within do blocks. (default 3)
+ fortran-if-indent
+ Extra indentation within if blocks. (default 3)
+ fortran-continuation-indent
+ Extra indentation appled to continuation statements. (default 5)
+ fortran-comment-line-column
+ Amount of indentation for text within full-line comments. (default 6)
+ fortran-comment-indent-style
+ nil means don't change indentation of text in full-line comments,
+ fixed means indent that text at column fortran-comment-line-column
+ relative means indent at fortran-comment-line-column beyond the
+ indentation for a line of code.
+ Default value is fixed.
+ fortran-comment-indent-char
+ Character to be inserted instead of space for full-line comment
+ indentation. (default is a space)
+ fortran-minimum-statement-indent
+ Minimum indentation for fortran statements. (default 6)
+ fortran-line-number-indent
+ Maximum indentation for line numbers. A line number will get
+ less than this much indentation if necessary to avoid reaching
+ column 5. (default 1)
+ fortran-check-all-num-for-matching-do
+ Non-nil causes all numbered lines to be treated as possible 'continue'
+ statements. (default nil)
+ fortran-continuation-char
+ character to be inserted in column 5 of a continuation line.
+ (default $)
+ fortran-comment-region
+ String inserted by \\[fortran-comment-region] at start of each line in
+ region. (default \"c$$$\")
+ fortran-electric-line-number
+ Non-nil causes line number digits to be moved to the correct column
+ as typed. (default t)
+ fortran-startup-message
+ Set to nil to inhibit message first time fortran-mode is used.
+
+Turning on Fortran mode calls the value of the variable fortran-mode-hook
+with no args, if that value is non-nil.
+\\{fortran-mode-map}" (interactive) (byte-code "ÂˆÓ ˆ…
+ˆ×Ë!ˆÂ‰ ˆ×Ì!ˆÍ‰ ˆ×Î!ˆÍ‰ˆ×Ï!ˆÂ‰ˆÝ!ˆÞ‰ˆß‰ˆàá!‡" [fortran-startup-message fortran-mode-version nil local-abbrev-table fortran-mode-abbrev-table fortran-mode-syntax-table indent-line-function comment-indent-hook comment-line-start-skip comment-line-start comment-start-skip comment-start require-final-newline t abbrev-all-caps indent-tabs-mode fortran-mode-map mode-name major-mode kill-all-local-variables message "Emacs Fortran mode version %s. Bugs to bug-fortran-mode@erl.mit.edu" set-syntax-table make-local-variable fortran-indent-line fortran-comment-hook "^[Cc*][^
+]*[ ]*" "c" "![ ]*" use-local-map "Fortran" fortran-mode run-hooks fortran-mode-hook] 15))
+
+(defun fortran-comment-hook nil (byte-code "ŠÁÂ!ˆÃi\\])‡" [comment-column skip-chars-backward " " 1] 3))
+
+(defun fortran-indent-comment nil "\
+Align or create comment on current line.
+Existing comments of all types are recognized and aligned.
+If the line has no comment, a side-by-side comment is inserted and aligned
+if the value of comment-start is not nil.
+Otherwise, a separate-line comment is inserted, on this line
+or on a new line inserted before this line if this line is not blank." (interactive) (byte-code "ÆˆÇ ˆÈ!ƒ
+" forward-char -1 insert-char 0 calculate-fortran-indent] 19))
+
+(defun fortran-comment-region (beg-region end-region arg) "\
+Comments every line in the region.
+Puts fortran-comment-region at the beginning of every line in the region.
+BEG-REGION and END-REGION are args which specify the region boundaries.
+With non-nil ARG, uncomments the region." (interactive "*r
+P") (byte-code "ÇˆÈ É Ê
+\"ˆ bˆË ˆ ?ƒ2
+
+(defun fortran-abbrev-start nil "\
+Typing \";\\[help-command]\" or \";?\" lists all the fortran abbrevs.
+Any other key combination is executed normally." (interactive) (byte-code "ĈÄ cˆr‰ÅU†
+Uƒ
+
+(defun fortran-abbrev-help nil "\
+List the currently defined abbrevs in Fortran mode." (interactive) (byte-code "ÁˆÂÃ!ˆÄÅ!ˆÆÇ\"ˆÂÈ!‡" [fortran-mode-abbrev-table nil message "Listing abbrev table..." require abbrevlist list-one-abbrev-table "*Help*" "Listing abbrev table...done"] 5))
+
+(defun fortran-column-ruler nil "\
+Inserts a column ruler momentarily above current line, till next keystroke.
+The ruler is defined by the value of fortran-column-ruler.
+The key typed is executed unless it is SPC." (interactive) (byte-code "ÁˆÂŠÃ ˆ`)ÁÄ$‡" [fortran-column-ruler nil momentary-string-display beginning-of-line "Type SPC or any command to erase ruler."] 6))
+
+(defun fortran-window-create nil "\
+Makes the window 72 columns wide." (interactive) (byte-code "ˆÃÄÅ!)ˆÆÇ!ˆÈÉÁ\"ˆÊË !‡" [window-min-width t nil 2 split-window-horizontally 73 other-window 1 switch-to-buffer " fortran-window-extra" select-window previous-window] 6))
+
+(defun fortran-split-line nil "\
+Break line at point and insert continuation marker and alignment." (interactive) (byte-code "ÃˆÄ ˆŠÅ ˆÆ!)ƒ
+\"ˆË ‡" [comment-line-start-skip comment-line-start fortran-continuation-char nil delete-horizontal-space beginning-of-line looking-at insert "
+" " " "
+ " fortran-indent-line] 7))
+
+(defun delete-horizontal-regexp (chars) "\
+Delete all characters in CHARS around point.
+CHARS is like the inside of a [...] in a regular expression
+except that ] is never special and quotes ^, - or ." (interactive "*s") (byte-code "ÁˆÂ!ˆÃ`Ä!ˆ`\"‡" [chars nil skip-chars-backward delete-region skip-chars-forward] 5))
+
+(defun fortran-electric-line-number (arg) "\
+Self insert, but if part of a Fortran line number indent it automatically.
+Auto-indent does not happen if a numeric arg is used." (interactive "P") (byte-code "Ĉ†
+
+(defun beginning-of-fortran-subprogram nil "\
+Moves point to the beginning of the current fortran subprogram." (interactive) (byte-code "ˆÁÃÄ!ˆÅÆÂÇ#ˆÈÆ!…
+
+(defun end-of-fortran-subprogram nil "\
+Moves point to the end of the current fortran subprogram." (interactive) (byte-code "ˆÁÃÄ!ˆÅÆÂÇ#ˆÈÉ!bˆÊË!)‡" [case-fold-search t nil beginning-of-line 2 re-search-forward "^[ 0-9]*end\\b[ ]*[^ =(a-z]" move match-beginning 0 forward-line 1] 5))
+
+(defun mark-fortran-subprogram nil "\
+Put mark at end of fortran subprogram, point at beginning.
+The marks are pushed." (interactive) (byte-code "ÀˆÁ ˆÂ`!ˆÃ ‡" [nil end-of-fortran-subprogram push-mark beginning-of-fortran-subprogram] 4))
+
+(defun fortran-previous-statement nil "\
+Moves point to beginning of the previous fortran statement.
+Returns 'first-statement if that statement is the first
+non-comment Fortran statement in the file, and nil otherwise." (interactive) (byte-code "ňÅÅÆ ˆÇÈÉÊ
+!!P!†
+]" forward-line -1 0 "[ ]*$" message "Incomplete continuation statement." fortran-previous-statement first-statement] 13))
+
+(defun fortran-next-statement nil "\
+Moves point to beginning of the next fortran statement.
+ Returns 'last-statement if that statement is the last
+ non-comment Fortran statement in the file, and nil otherwise." (interactive) (byte-code "ÈÃÄ ˆÅÆ!ÇU‰…(
+P!…0
+]" "[ ]*" last-statement] 8))
+
+(defun fortran-indent-line nil "\
+Indents current fortran line based on its contents and on previous lines." (interactive) (byte-code "ÃˆÄ ŠÅ ˆÆ U?†
+ŠÌ ˆ`)Í#…9
+
+(defun fortran-indent-subprogram nil "\
+Properly indents the Fortran subprogram which contains point." (interactive) (byte-code "ÀˆŠÁ ˆÂÃ!ˆÄ`Å À#)ˆÂÆ!‡" [nil mark-fortran-subprogram message "Indenting subprogram..." indent-region mark "Indenting subprogram...done."] 7))
+
+(defun calculate-fortran-indent nil "\
+Calculates the fortran indent column based on previous lines." (byte-code "ÎÎÃŠÏ ‰ˆ ƒ
+\\‰‚­
+‰‚?Óáâã !!P!†À
+]" "[ ]*[0-9]+" fortran-check-for-matching-do "end[ ]*if\\b" "continue\\b" "end[ ]*do\\b" "end\\b[ ]*[^ =(a-z]" message "Warning: `end' not in column %d. Probably an unclosed block."] 29))
+
+(defun fortran-current-line-indentation nil "\
+Indentation of current line, ignoring Fortran line number or continuation.
+This is the column position of the first non-whitespace character
+aside from the line number and/or column 5 line-continuation character.
+For comment lines, returns indentation of the first
+non-indentation text within the comment." (byte-code "ŠÃ ˆÄ!ƒ
+]" move-to-column 5 " "] 10))
+
+(defun fortran-indent-to-column (col) "\
+Indents current line with spaces to column COL.
+notes: 1) A non-zero/non-blank character in column 5 indicates a continuation
+ line, and this continuation character is retained on indentation;
+ 2) If fortran-continuation-char is the first non-whitespace character,
+ this is a continuation line;
+ 3) A non-continuation line which has a number as the first
+ non-whitespace character is a numbered line." (byte-code "ŠÊ ˆË!ƒ2
+!P!ˆÑ
+ iZ\")‚£
+]" forward-char 6 delete-horizontal-space 5 1 "[0-9]+" message "Warning: line number exceeds 5-digit limit." skip-chars-forward "0-9" re-search-forward end-of-line match-beginning fortran-comment-hook] 22))
+
+(defun fortran-line-number-indented-correctly-p nil "\
+Return t if current line's line number is correctly indente.
+Do not call if there is no line number." (byte-code "ŠÁ ˆÂÃ!ˆiX…
+
+(defun fortran-check-for-matching-do nil "\
+When called from a numbered statement, returns t
+ if matching 'do' is found, and nil otherwise." (byte-code "ÃÂŠÄ ˆÅÆ!…7
diff --git a/lisp/ftp.el b/lisp/ftp.el
index c7d7b7e59df..917661d9836 100644
--- a/lisp/ftp.el
+++ b/lisp/ftp.el
@@ -18,10 +18,6 @@
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-;; Prevent changes in major modes from altering these variables.
-(put 'ftp-temp-file-name 'permanent-local t)
-(put 'ftp-file 'permanent-local t)
-(put 'ftp-host 'permanent-local t)
;; you can turn this off by doing
;; (setq ftp-password-alist 'compulsory-urinalysis)
@@ -112,16 +108,14 @@ we prompt for the user name and password."
(if filep "" "-directory")
host file))))
(set-buffer buffer)
- (let ((process nil)
+ (let ((process (ftp-setup-buffer host file))
(case-fold-search nil))
(let ((win nil))
(unwind-protect
- (progn
- (setq process (ftp-setup-buffer host file))
- (if (setq win (ftp-login process host user password))
- (message "Logged in")
- (error "Ftp login failed")))
- (or win (and process (delete-process process)))))
+ (if (setq win (ftp-login process host user password))
+ (message "Logged in")
+ (error "Ftp login lost"))
+ (or win (delete-process process))))
(message "Opening %s %s:%s..." (if filep "file" "directory")
host file)
(if (ftp-command process
@@ -161,37 +155,34 @@ USER and PASSWORD are defaulted from the values used when
(let ((buffer (get-buffer-create (format "*ftp %s:%s*" host file)))
(tmp (make-temp-name "/tmp/emacsftp")))
(write-region (point-min) (point-max) tmp)
- (save-excursion
- (set-buffer buffer)
- (make-local-variable 'ftp-temp-file-name)
- (setq ftp-temp-file-name tmp)
- (let ((process (ftp-setup-buffer host file))
- (case-fold-search nil))
- (let ((win nil))
- (unwind-protect
- (if (setq win (ftp-login process host user password))
- (message "Logged in")
+ (set-buffer buffer)
+ (make-local-variable 'ftp-temp-file-name)
+ (setq ftp-temp-file-name tmp)
+ (let ((process (ftp-setup-buffer host file))
+ (case-fold-search nil))
+ (let ((win nil))
+ (unwind-protect
+ (if (setq win (ftp-login process host user password))
+ (message "Logged in")
(error "Ftp login lost"))
- (or win (delete-process process))))
- (message "Opening file %s:%s..." host file)
- (if (ftp-command process
- (format "send \"%s\" \"%s\"\nquit\n" tmp file)
- "150.*\n"
- "200.*\n")
- (progn (forward-line 1)
- (setq foo1 (current-buffer))
- (let ((buffer-read-only nil))
- (delete-region (point-min) (point)))
- (message "Saving %s:%s in background. Bye!" host file)
- (set-process-sentinel process
- 'ftp-asynchronous-output-sentinel)
- process)
- (switch-to-buffer buffer)
- (setq foo2 (current-buffer))
- (let ((buffer-read-only nil))
- (insert-before-markers "<<<Ftp lost>>>"))
- (delete-process process)
- (error "Ftp write %s:%s lost" host file))))))
+ (or win (delete-process process))))
+ (message "Opening file %s:%s..." host file)
+ (if (ftp-command process
+ (format "send \"%s\" \"%s\"\nquit\n" tmp file)
+ "\\(150\\|125\\).*\n"
+ "200.*\n")
+ (progn (forward-line 1)
+ (let ((buffer-read-only nil))
+ (delete-region (point-min) (point)))
+ (message "Saving %s:%s in background. Bye!" host file)
+ (set-process-sentinel process
+ 'ftp-asynchronous-output-sentinel)
+ process)
+ (switch-to-buffer buffer)
+ (let ((buffer-read-only nil))
+ (insert-before-markers "<<<Ftp lost>>>"))
+ (delete-process process)
+ (error "Ftp write %s:%s lost" host file)))))
(defun ftp-setup-buffer (host file)
@@ -205,14 +196,13 @@ USER and PASSWORD are defaulted from the values used when
(while (get-buffer-process (current-buffer))
(kill-process (get-buffer-process (current-buffer))))
(error "Foo"))))
- ;(buffer-disable-undo (current-buffer))
+ ;(buffer-flush-undo (current-buffer))
(setq buffer-read-only nil)
(erase-buffer)
(make-local-variable 'ftp-host)
(setq ftp-host host)
(make-local-variable 'ftp-file)
(setq ftp-file file)
- (setq foo3 (current-buffer))
(setq buffer-read-only t)
(start-process "ftp" (current-buffer) "ftp" "-i" "-n" "-g"))
@@ -222,7 +212,7 @@ USER and PASSWORD are defaulted from the values used when
(if (ftp-command process
(format "open %s\nuser %s %s\n" host user password)
"230.*\n"
- "\\(Connected to \\|220\\|331\\|Remote system type\\|Using.*mode\\|Remember to set\\).*\n")
+ "\\(Connected to \\|220\\|331\\).*\n")
t
(switch-to-buffer (process-buffer process))
(delete-process process)
@@ -233,7 +223,8 @@ USER and PASSWORD are defaulted from the values used when
(defun ftp-command (process command win ignore)
(process-send-string process command)
- (let ((p 1))
+ (let ((p 1)
+ (case-fold-search t))
(while (numberp p)
(cond ;((not (bolp)))
((looking-at win)
@@ -242,9 +233,13 @@ USER and PASSWORD are defaulted from the values used when
((looking-at "^ftp> \\|^\n")
(goto-char (match-end 0)))
((looking-at ignore)
+ ;; Ignore status messages whose codes indicate no problem.
+ (forward-line 1))
+ ((looking-at "^[^0-9]")
+ ;; Ignore any lines that don't have status codes.
(forward-line 1))
((not (search-forward "\n" nil t))
- ;; the way asynchronous process-output works with (point)
+ ;; the way asynchronous process-output fucks with (point)
;; is really really disgusting.
(setq p (point))
(condition-case ()
@@ -275,27 +270,26 @@ USER and PASSWORD are defaulted from the values used when
(set-buffer (process-buffer process))
(let (msg
(r (if input "[0-9]+ bytes received in [0-9]+\\.[0-9]+ seconds.*$" "[0-9]+ bytes sent in [0-9]+\\.[0-9]+ seconds.*$")))
- (let ((buffer-read-only nil))
- (goto-char (point-max))
- (search-backward "226 ")
- (if (looking-at r)
- (search-backward "226 "))
- (let ((p (point)))
- (setq msg (concat (format "ftp %s %s:%s done"
- (if input "read" "write")
- ftp-host ftp-file)
- (if (re-search-forward r nil t)
- (concat ": " (buffer-substring
- (match-beginning 0)
- (match-end 0)))
- "")))
- (delete-region p (point-max))
- (save-excursion
- (set-buffer (get-buffer-create "*ftp log*"))
- (let ((buffer-read-only nil))
- (insert msg ?\n)))))
- ;; Note the preceding let must end here
- ;; so it doesn't cross the (kill-buffer (current-buffer)).
+ (goto-char (point-max))
+ (search-backward "226 ")
+ (if (looking-at r)
+ (search-backward "226 "))
+ (let ((p (point)))
+ (setq msg (concat (format "ftp %s %s:%s done"
+ (if input "read" "write")
+ ftp-host ftp-file)
+ (if (re-search-forward r nil t)
+ (concat ": " (buffer-substring
+ (match-beginning 0)
+ (match-end 0)))
+ "")))
+ (let ((buffer-read-only nil))
+ (delete-region p (point-max)))
+ (save-excursion
+ (set-buffer (get-buffer-create "*ftp log*"))
+ (let ((buffer-read-only nil))
+ (insert msg ?\n)))
+ (set-buffer-modified-p nil))
(if (not input)
(progn
(condition-case ()
@@ -303,8 +297,6 @@ USER and PASSWORD are defaulted from the values used when
ftp-temp-file-name
(delete-file ftp-temp-file-name))
(error nil))
- ;; Kill the temporary buffer which the ftp process
- ;; puts its output in.
(kill-buffer (current-buffer)))
;; You don't want to look at this.
(let ((kludge (generate-new-buffer (format "%s:%s (ftp)"
@@ -312,7 +304,6 @@ USER and PASSWORD are defaulted from the values used when
(setq kludge (prog1 (buffer-name kludge) (kill-buffer kludge)))
(rename-buffer kludge)
;; ok, you can look again now.
- (set-buffer-modified-p nil)
(ftp-setup-write-file-hooks)))
(if (and asynchronous
;(waiting-for-user-input-p)
@@ -350,15 +341,20 @@ USER and PASSWORD are defaulted from the values used when
(setq buffer-read-only nil))
(defun ftp-write-file-hook ()
- (let ((process (ftp-write-file ftp-host ftp-file)))
+ (let ((buffer (current-buffer))
+ (process (ftp-write-file ftp-host ftp-file)))
(set-process-sentinel process 'ftp-synchronous-output-sentinel)
(message "FTP writing %s:%s..." ftp-host ftp-file)
(while (eq (process-status process) 'run)
(condition-case ()
(accept-process-output process)
(error nil)))
- (set-buffer-modified-p nil)
- (message "FTP writing %s:%s...done" ftp-host ftp-file))
+ (and (eq (process-status process) 'exit)
+ (= (process-exit-status process) 0)
+ (save-excursion
+ (set-buffer buffer)
+ (set-buffer-modified-p nil))))
+ (message "Written")
t)
(defun ftp-revert-buffer (&rest ignore)
diff --git a/lisp/ftp.elc b/lisp/ftp.elc
new file mode 100644
index 00000000000..d3d5da49fb1
--- /dev/null
+++ b/lisp/ftp.elc
Binary files differ
diff --git a/lisp/gdb.el b/lisp/gdb.el
new file mode 100644
index 00000000000..c7e80b99691
--- /dev/null
+++ b/lisp/gdb.el
@@ -0,0 +1,397 @@
+;; Run gdb under Emacs
+;; Copyright (C) 1988 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;; Author: W. Schelter, University of Texas
+;; wfs@rascal.ics.utexas.edu
+;; Rewritten by rms.
+
+;; Some ideas are due to Masanobu.
+
+;; Description of GDB interface:
+
+;; A facility is provided for the simultaneous display of the source code
+;; in one window, while using gdb to step through a function in the
+;; other. A small arrow in the source window, indicates the current
+;; line.
+
+;; Starting up:
+
+;; In order to use this facility, invoke the command GDB to obtain a
+;; shell window with the appropriate command bindings. You will be asked
+;; for the name of a file to run. Gdb will be invoked on this file, in a
+;; window named *gdb-foo* if the file is foo.
+
+;; M-s steps by one line, and redisplays the source file and line.
+
+;; You may easily create additional commands and bindings to interact
+;; with the display. For example to put the gdb command next on \M-n
+;; (def-gdb next "\M-n")
+
+;; This causes the emacs command gdb-next to be defined, and runs
+;; gdb-display-frame after the command.
+
+;; gdb-display-frame is the basic display function. It tries to display
+;; in the other window, the file and line corresponding to the current
+;; position in the gdb window. For example after a gdb-step, it would
+;; display the line corresponding to the position for the last step. Or
+;; if you have done a backtrace in the gdb buffer, and move the cursor
+;; into one of the frames, it would display the position corresponding to
+;; that frame.
+
+;; gdb-display-frame is invoked automatically when a filename-and-line-number
+;; appears in the output.
+
+
+(require 'shell)
+
+(defvar gdb-prompt-pattern "^(.*gdb[+]?) *"
+ "A regexp to recognize the prompt for gdb or gdb+.")
+
+(defvar gdb-mode-map nil
+ "Keymap for gdb-mode.")
+
+(if gdb-mode-map
+ nil
+ (setq gdb-mode-map (copy-keymap shell-mode-map))
+ (define-key gdb-mode-map "\C-l" 'gdb-refresh))
+
+(define-key ctl-x-map " " 'gdb-break)
+(define-key ctl-x-map "&" 'send-gdb-command)
+
+;;Of course you may use `def-gdb' with any other gdb command, including
+;;user defined ones.
+
+(defmacro def-gdb (name key &optional doc)
+ (let* ((fun (intern (format "gdb-%s" name)))
+ (cstr (list 'if '(not (= 1 arg))
+ (list 'format "%s %s" name 'arg)
+ name)))
+ (list 'progn
+ (list 'defun fun '(arg)
+ (or doc "")
+ '(interactive "p")
+ (list 'gdb-call cstr))
+ (list 'define-key 'gdb-mode-map key (list 'quote fun)))))
+
+(def-gdb "step" "\M-s" "Step one source line with display")
+(def-gdb "stepi" "\M-i" "Step one instruction with display")
+(def-gdb "next" "\M-n" "Step one source line (skip functions)")
+(def-gdb "cont" "\M-c" "Continue with display")
+
+(def-gdb "finish" "\C-c\C-f" "Finish executing current function")
+(def-gdb "up" "\M-u" "Go up N stack frames (numeric arg) with display")
+(def-gdb "down" "\M-d" "Go down N stack frames (numeric arg) with display")
+
+(defun gdb-mode ()
+ "Major mode for interacting with an inferior Gdb process.
+The following commands are available:
+
+\\{gdb-mode-map}
+
+\\[gdb-display-frame] displays in the other window
+the last line referred to in the gdb buffer.
+
+\\[gdb-step],\\[gdb-next], and \\[gdb-nexti] in the gdb window,
+call gdb to step,next or nexti and then update the other window
+with the current file and position.
+
+If you are in a source file, you may select a point to break
+at, by doing \\[gdb-break].
+
+Commands:
+Many commands are inherited from shell mode.
+Additionally we have:
+
+\\[gdb-display-frame] display frames file in other window
+\\[gdb-step] advance one line in program
+\\[gdb-next] advance one line in program (skip over calls).
+\\[send-gdb-command] used for special printing of an arg at the current point.
+C-x SPACE sets break point at current line."
+ (interactive)
+ (kill-all-local-variables)
+ (setq major-mode 'gdb-mode)
+ (setq mode-name "Inferior Gdb")
+ (setq mode-line-process '(": %s"))
+ (use-local-map gdb-mode-map)
+ (make-local-variable 'last-input-start)
+ (setq last-input-start (make-marker))
+ (make-local-variable 'last-input-end)
+ (setq last-input-end (make-marker))
+ (make-local-variable 'gdb-last-frame)
+ (setq gdb-last-frame nil)
+ (make-local-variable 'gdb-last-frame-displayed-p)
+ (setq gdb-last-frame-displayed-p t)
+ (make-local-variable 'gdb-delete-prompt-marker)
+ (setq gdb-delete-prompt-marker nil)
+ (make-local-variable 'gdb-filter-accumulator)
+ (setq gdb-filter-accumulator nil)
+ (make-local-variable 'shell-prompt-pattern)
+ (setq shell-prompt-pattern gdb-prompt-pattern)
+ (run-hooks 'shell-mode-hook 'gdb-mode-hook))
+
+(defvar current-gdb-buffer nil)
+
+(defvar gdb-command-name "gdb"
+ "Pathname for executing gdb.")
+
+(defun gdb (path)
+ "Run gdb on program FILE in buffer *gdb-FILE*.
+The directory containing FILE becomes the initial working directory
+and source-file directory for GDB. If you wish to change this, use
+the GDB commands `cd DIR' and `directory'."
+ (interactive "FRun gdb on file: ")
+ (setq path (expand-file-name path))
+ (let ((file (file-name-nondirectory path)))
+ (switch-to-buffer (concat "*gdb-" file "*"))
+ (setq default-directory (file-name-directory path))
+ (or (bolp) (newline))
+ (insert "Current directory is " default-directory "\n")
+ (make-shell (concat "gdb-" file) gdb-command-name nil "-fullname"
+ "-cd" default-directory file)
+ (gdb-mode)
+ (set-process-filter (get-buffer-process (current-buffer)) 'gdb-filter)
+ (set-process-sentinel (get-buffer-process (current-buffer)) 'gdb-sentinel)
+ (gdb-set-buffer)))
+
+(defun gdb-set-buffer ()
+ (cond ((eq major-mode 'gdb-mode)
+ (setq current-gdb-buffer (current-buffer)))))
+
+;; This function is responsible for inserting output from GDB
+;; into the buffer.
+;; Aside from inserting the text, it notices and deletes
+;; each filename-and-line-number;
+;; that GDB prints to identify the selected frame.
+;; It records the filename and line number, and maybe displays that file.
+(defun gdb-filter (proc string)
+ (let ((inhibit-quit t))
+ (if gdb-filter-accumulator
+ (gdb-filter-accumulate-marker proc
+ (concat gdb-filter-accumulator string))
+ (gdb-filter-scan-input proc string))))
+
+(defun gdb-filter-accumulate-marker (proc string)
+ (setq gdb-filter-accumulator nil)
+ (if (> (length string) 1)
+ (if (= (aref string 1) ?\032)
+ (let ((end (string-match "\n" string)))
+ (if end
+ (progn
+ (let* ((first-colon (string-match ":" string 2))
+ (second-colon
+ (string-match ":" string (1+ first-colon))))
+ (setq gdb-last-frame
+ (cons (substring string 2 first-colon)
+ (string-to-int
+ (substring string (1+ first-colon)
+ second-colon)))))
+ (setq gdb-last-frame-displayed-p nil)
+ (gdb-filter-scan-input proc
+ (substring string (1+ end))))
+ (setq gdb-filter-accumulator string)))
+ (gdb-filter-insert proc "\032")
+ (gdb-filter-scan-input proc (substring string 1)))
+ (setq gdb-filter-accumulator string)))
+
+(defun gdb-filter-scan-input (proc string)
+ (if (equal string "")
+ (setq gdb-filter-accumulator nil)
+ (let ((start (string-match "\032" string)))
+ (if start
+ (progn (gdb-filter-insert proc (substring string 0 start))
+ (gdb-filter-accumulate-marker proc
+ (substring string start)))
+ (gdb-filter-insert proc string)))))
+
+(defun gdb-filter-insert (proc string)
+ (let ((moving (= (point) (process-mark proc)))
+ (output-after-point (< (point) (process-mark proc)))
+ (old-buffer (current-buffer))
+ start)
+ (set-buffer (process-buffer proc))
+ (unwind-protect
+ (save-excursion
+ ;; Insert the text, moving the process-marker.
+ (goto-char (process-mark proc))
+ (setq start (point))
+ (insert string)
+ (set-marker (process-mark proc) (point))
+ (gdb-maybe-delete-prompt)
+ ;; Check for a filename-and-line number.
+ (gdb-display-frame
+ ;; Don't display the specified file
+ ;; unless (1) point is at or after the position where output appears
+ ;; and (2) this buffer is on the screen.
+ (or output-after-point
+ (not (get-buffer-window (current-buffer))))
+ ;; Display a file only when a new filename-and-line-number appears.
+ t))
+ (set-buffer old-buffer))
+ (if moving (goto-char (process-mark proc)))))
+
+(defun gdb-sentinel (proc msg)
+ (cond ((null (buffer-name (process-buffer proc)))
+ ;; buffer killed
+ ;; Stop displaying an arrow in a source file.
+ (setq overlay-arrow-position nil)
+ (set-process-buffer proc nil))
+ ((memq (process-status proc) '(signal exit))
+ ;; Stop displaying an arrow in a source file.
+ (setq overlay-arrow-position nil)
+ ;; Fix the mode line.
+ (setq mode-line-process
+ (concat ": "
+ (symbol-name (process-status proc))))
+ (let* ((obuf (current-buffer)))
+ ;; save-excursion isn't the right thing if
+ ;; process-buffer is current-buffer
+ (unwind-protect
+ (progn
+ ;; Write something in *compilation* and hack its mode line,
+ (set-buffer (process-buffer proc))
+ ;; Force mode line redisplay soon
+ (set-buffer-modified-p (buffer-modified-p))
+ (if (eobp)
+ (insert ?\n mode-name " " msg)
+ (save-excursion
+ (goto-char (point-max))
+ (insert ?\n mode-name " " msg)))
+ ;; If buffer and mode line will show that the process
+ ;; is dead, we can delete it now. Otherwise it
+ ;; will stay around until M-x list-processes.
+ (delete-process proc))
+ ;; Restore old buffer, but don't restore old point
+ ;; if obuf is the gdb buffer.
+ (set-buffer obuf))))))
+
+
+(defun gdb-refresh ()
+ "Fix up a possibly garbled display, and redraw the arrow."
+ (interactive)
+ (redraw-display)
+ (gdb-display-frame))
+
+(defun gdb-display-frame (&optional nodisplay noauto)
+ "Find, obey and delete the last filename-and-line marker from GDB.
+The marker looks like \\032\\032FILENAME:LINE:CHARPOS\\n.
+Obeying it means displaying in another window the specified file and line."
+ (interactive)
+ (gdb-set-buffer)
+ (and gdb-last-frame (not nodisplay)
+ (or (not gdb-last-frame-displayed-p) (not noauto))
+ (progn (gdb-display-line (car gdb-last-frame) (cdr gdb-last-frame))
+ (setq gdb-last-frame-displayed-p t))))
+
+;; Make sure the file named TRUE-FILE is in a buffer that appears on the screen
+;; and that its line LINE is visible.
+;; Put the overlay-arrow on the line LINE in that buffer.
+
+(defun gdb-display-line (true-file line)
+ (let* ((buffer (find-file-noselect true-file))
+ (window (display-buffer buffer t))
+ (pos))
+ (save-excursion
+ (set-buffer buffer)
+ (save-restriction
+ (widen)
+ (goto-line line)
+ (setq pos (point))
+ (setq overlay-arrow-string "=>")
+ (or overlay-arrow-position
+ (setq overlay-arrow-position (make-marker)))
+ (set-marker overlay-arrow-position (point) (current-buffer)))
+ (cond ((or (< pos (point-min)) (> pos (point-max)))
+ (widen)
+ (goto-char pos))))
+ (set-window-point window overlay-arrow-position)))
+
+(defun gdb-call (command)
+ "Invoke gdb COMMAND displaying source in other window."
+ (interactive)
+ (goto-char (point-max))
+ (setq gdb-delete-prompt-marker (point-marker))
+ (gdb-set-buffer)
+ (send-string (get-buffer-process current-gdb-buffer)
+ (concat command "\n")))
+
+(defun gdb-maybe-delete-prompt ()
+ (if (and gdb-delete-prompt-marker
+ (> (point-max) (marker-position gdb-delete-prompt-marker)))
+ (let (start)
+ (goto-char gdb-delete-prompt-marker)
+ (setq start (point))
+ (beginning-of-line)
+ (delete-region (point) start)
+ (setq gdb-delete-prompt-marker nil))))
+
+(defun gdb-break ()
+ "Set GDB breakpoint at this source line."
+ (interactive)
+ (let ((file-name (file-name-nondirectory buffer-file-name))
+ (line (save-restriction
+ (widen)
+ (1+ (count-lines 1 (point))))))
+ (send-string (get-buffer-process current-gdb-buffer)
+ (concat "break " file-name ":" line "\n"))))
+
+(defun gdb-read-address()
+ "Return a string containing the core-address found in the buffer at point."
+ (save-excursion
+ (let ((pt (dot)) found begin)
+ (setq found (if (search-backward "0x" (- pt 7) t)(dot)))
+ (cond (found (forward-char 2)(setq result
+ (buffer-substring found
+ (progn (re-search-forward "[^0-9a-f]")
+ (forward-char -1)
+ (dot)))))
+ (t (setq begin (progn (re-search-backward "[^0-9]") (forward-char 1)
+ (dot)))
+ (forward-char 1)
+ (re-search-forward "[^0-9]")
+ (forward-char -1)
+ (buffer-substring begin (dot)))))))
+
+
+(defvar gdb-commands nil
+ "List of strings or functions used by send-gdb-command.
+It is for customization by you.")
+
+(defun send-gdb-command (arg)
+
+ "This command reads the number where the cursor is positioned. It
+ then inserts this ADDR at the end of the gdb buffer. A numeric arg
+ selects the ARG'th member COMMAND of the list gdb-print-command. If
+ COMMAND is a string, (format COMMAND ADDR) is inserted, otherwise
+ (funcall COMMAND ADDR) is inserted. eg. \"p (rtx)%s->fld[0].rtint\"
+ is a possible string to be a member of gdb-commands. "
+
+
+ (interactive "P")
+ (let (comm addr)
+ (if arg (setq comm (nth arg gdb-commands)))
+ (setq addr (gdb-read-address))
+ (if (eq (current-buffer) current-gdb-buffer)
+ (set-mark (point)))
+ (cond (comm
+ (setq comm
+ (if (stringp comm) (format comm addr) (funcall comm addr))))
+ (t (setq comm addr)))
+ (switch-to-buffer current-gdb-buffer)
+ (goto-char (dot-max))
+ (insert-string comm)))
diff --git a/lisp/gdb.elc b/lisp/gdb.elc
new file mode 100644
index 00000000000..b5191c30490
--- /dev/null
+++ b/lisp/gdb.elc
Binary files differ
diff --git a/lisp/gnusmail.el b/lisp/gnusmail.el
deleted file mode 100644
index 9bfedc89173..00000000000
--- a/lisp/gnusmail.el
+++ /dev/null
@@ -1,148 +0,0 @@
-;;; Mail reply commands for GNUS newsreader
-;; Copyright (C) 1990 Masanobu UMEDA
-;; $Header: gnusmail.el,v 1.1 90/03/23 13:24:39 umerin Locked $
-
-;; This file is part of GNU Emacs.
-
-;; 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.
-
-(provide 'gnusmail)
-(require 'gnus)
-
-;; Provides mail reply and mail other window command using usual mail
-;; interface and mh-e interface.
-;;
-;; To use MAIL: set the variables gnus-mail-reply-method and
-;; gnus-mail-other-window-method to gnus-mail-reply-using-mail and
-;; gnus-mail-other-window-using-mail, respectively.
-;;
-;; To use MH-E: set the variables gnus-mail-reply-method and
-;; gnus-mail-other-window-method to gnus-mail-reply-using-mhe and
-;; gnus-mail-other-window-using-mhe, respectively.
-
-(autoload 'news-mail-reply "rnewspost")
-(autoload 'news-mail-other-window "rnewspost")
-
-(autoload 'mh-send "mh-e")
-(autoload 'mh-send-other-window "mh-e")
-(autoload 'mh-find-path "mh-e")
-(autoload 'mh-yank-cur-msg "mh-e")
-
-;;; Mail reply commands of GNUS Subject Mode
-
-(defun gnus-Subject-mail-reply (yank)
- "Reply mail to news author.
-If prefix arg YANK is non-nil, original article is yanked automatically.
-Customize the variable `gnus-mail-reply-method' to use another mailer."
- (interactive "P")
- (gnus-Subject-select-article)
- (switch-to-buffer gnus-Article-buffer)
- (widen)
- (delete-other-windows)
- (bury-buffer gnus-Article-buffer)
- (funcall gnus-mail-reply-method yank))
-
-(defun gnus-Subject-mail-reply-with-original ()
- "Reply mail to news author with original article."
- (interactive)
- (gnus-Subject-mail-reply t))
-
-(defun gnus-Subject-mail-other-window ()
- "Compose mail in other window.
-Customize the variable `gnus-mail-other-window-method' to use another mailer."
- (interactive)
- (gnus-Subject-select-article)
- (switch-to-buffer gnus-Article-buffer)
- (widen)
- (delete-other-windows)
- (bury-buffer gnus-Article-buffer)
- (funcall gnus-mail-other-window-method))
-
-
-;;; Send mail using sendmail mail mode.
-
-(defun gnus-mail-reply-using-mail (&optional yank)
- "Compose reply mail using mail.
-Optional argument YANK means yank original article."
- (news-mail-reply)
- (gnus-overload-functions)
- (if yank
- (let ((last (point)))
- (goto-char (point-max))
- (mail-yank-original nil)
- (goto-char last)
- )))
-
-(defun gnus-mail-other-window-using-mail ()
- "Compose mail other window using mail."
- (news-mail-other-window)
- (gnus-overload-functions))
-
-
-;;; Send mail using mh-e.
-
-;; The following mh-e interface is all cooperative works of
-;; tanaka@flab.fujitsu.CO.JP (TANAKA Hiroshi), kawabe@sra.CO.JP
-;; (Yoshikatsu Kawabe), and shingu@casund.cpr.canon.co.jp (Toshiaki
-;; SHINGU).
-
-(defun gnus-mail-reply-using-mhe (&optional yank)
- "Compose reply mail using mh-e.
-Optional argument YANK means yank original article.
-The command \\[mh-yank-cur-msg] yanks the original message into current buffer."
- ;; First of all, prepare mhe mail buffer.
- (let (from cc subject date to reply-to (buffer (current-buffer)))
- (save-restriction
- (gnus-Article-show-all-headers) ;I don't think this is really needed.
- (setq from (gnus-fetch-field "from")
- subject (let ((subject (gnus-fetch-field "subject")))
- (if (and subject
- (not (string-match "^[Rr][Ee]:.+$" subject)))
- (concat "Re: " subject) subject))
- reply-to (gnus-fetch-field "reply-to")
- cc (gnus-fetch-field "cc")
- date (gnus-fetch-field "date"))
- (setq mh-show-buffer buffer)
- (setq to (or reply-to from))
- (mh-find-path)
- (mh-send to (or cc "") subject)
- (save-excursion
- (mh-insert-fields
- "In-reply-to:"
- (concat
- (substring from 0 (string-match " *at \\| *@ \\| *(\\| *<" from))
- "'s message of " date)))
- (setq mh-sent-from-folder buffer)
- (setq mh-sent-from-msg 1)
- ))
- ;; Then, yank original article if requested.
- (if yank
- (let ((last (point)))
- (mh-yank-cur-msg)
- (goto-char last)
- )))
-
-(defun gnus-mail-other-window-using-mhe ()
- "Compose mail other window using MH-E Mail."
- (let ((to (read-string "To: "))
- (cc (read-string "Cc: "))
- (subject (read-string "Subject: " (gnus-fetch-field "subject"))))
- (gnus-Article-show-all-headers) ;I don't think this is really needed.
- (setq mh-show-buffer (current-buffer))
- (mh-find-path)
- (mh-send-other-window to cc subject)
- (setq mh-sent-from-folder (current-buffer))
- (setq mh-sent-from-msg 1)))
diff --git a/lisp/gnusmisc.el b/lisp/gnusmisc.el
deleted file mode 100644
index d133b63a30c..00000000000
--- a/lisp/gnusmisc.el
+++ /dev/null
@@ -1,214 +0,0 @@
-;;; Miscellaneous commands for GNUS newsreader
-;; Copyright (C) 1989 Fujitsu Laboratories LTD.
-;; Copyright (C) 1989, 1990 Masanobu UMEDA
-;; $Header: gnusmisc.el,v 1.2 90/03/23 13:25:04 umerin Locked $
-
-;; This file is part of GNU Emacs.
-
-;; 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.
-
-(provide 'gnusmisc)
-(require 'gnus)
-
-;;;
-;;; GNUS Browse-Killed Mode
-;;;
-
-;; Some ideas are due to roland@wheaties.ai.mit.edu (Roland McGrath).
-;; I'd like to thank him very much.
-
-(defvar gnus-Browse-killed-mode-hook nil
- "*A hook for GNUS Browse-Killed Mode.")
-
-(defvar gnus-Browse-killed-buffer "*Killed Newsgroup*")
-(defvar gnus-Browse-killed-mode-map nil)
-(defvar gnus-winconf-browse-killed nil)
-
-(put 'gnus-Browse-killed-mode 'mode-class 'special)
-
-;; Make the buffer to be managed by GNUS.
-
-(or (memq gnus-Browse-killed-buffer gnus-buffer-list)
- (setq gnus-buffer-list
- (cons gnus-Browse-killed-buffer gnus-buffer-list)))
-
-(if gnus-Browse-killed-mode-map
- nil
- (setq gnus-Browse-killed-mode-map (make-keymap))
- (suppress-keymap gnus-Browse-killed-mode-map t)
- (define-key gnus-Browse-killed-mode-map " " 'gnus-Group-next-group)
- (define-key gnus-Browse-killed-mode-map "\177" 'gnus-Group-prev-group)
- (define-key gnus-Browse-killed-mode-map "\C-n" 'gnus-Group-next-group)
- (define-key gnus-Browse-killed-mode-map "\C-p" 'gnus-Group-prev-group)
- (define-key gnus-Browse-killed-mode-map "n" 'gnus-Group-next-group)
- (define-key gnus-Browse-killed-mode-map "p" 'gnus-Group-prev-group)
- (define-key gnus-Browse-killed-mode-map "y" 'gnus-Browse-killed-yank)
- (define-key gnus-Browse-killed-mode-map "\C-y" 'gnus-Browse-killed-yank)
- (define-key gnus-Browse-killed-mode-map "l" 'gnus-Browse-killed-groups)
- (define-key gnus-Browse-killed-mode-map "q" 'gnus-Browse-killed-exit)
- (define-key gnus-Browse-killed-mode-map "\C-c\C-c" 'gnus-Browse-killed-exit)
- (define-key gnus-Browse-killed-mode-map "\C-c\C-i" 'gnus-Info-find-node))
-
-(defun gnus-Browse-killed-mode ()
- "Major mode for browsing the killed newsgroups.
-All normal editing commands are turned off.
-Instead, these commands are available:
-\\{gnus-Browse-killed-mode-map}
-
-The killed newsgroups are saved in the quick startup file \".newsrc.el\"
-unless disabled inthe options line of the startup file \".newsrc\".
-
-Entry to this mode calls `gnus-Browse-killed-mode-hook' with no arguments
-if that value is non-nil."
- (interactive)
- (kill-all-local-variables)
- ;; Gee. Why don't you upgrade?
- (cond ((boundp 'mode-line-modified)
- (setq mode-line-modified "--- "))
- ((listp (default-value 'mode-line-format))
- (setq mode-line-format
- (cons "--- " (cdr (default-value 'mode-line-format)))))
- (t
- (setq mode-line-format
- "--- GNUS: Killed Newsgroups %[(%m)%]----%3p-%-")))
- (setq major-mode 'gnus-Browse-killed-mode)
- (setq mode-name "Browse-Killed")
- (setq mode-line-buffer-identification "GNUS: Killed Newsgroups")
- (use-local-map gnus-Browse-killed-mode-map)
- (buffer-flush-undo (current-buffer))
- (setq buffer-read-only t) ;Disable modification
- (run-hooks 'gnus-Browse-killed-mode-hook))
-
-(defun gnus-Browse-killed-groups ()
- "Browse the killed newsgroups.
-\\<gnus-Browse-killed-mode-map>\\[gnus-Browse-killed-yank] yanks the newsgroup on the current line into the Newsgroups buffer."
- (interactive)
- (or gnus-killed-assoc
- (error "No killed newsgroups"))
- ;; Save current window configuration if this is first invocation..
- (or (get-buffer-window gnus-Browse-killed-buffer)
- (setq gnus-winconf-browse-killed
- (current-window-configuration)))
- ;; Prepare browsing buffer.
- (pop-to-buffer (get-buffer-create gnus-Browse-killed-buffer))
- (gnus-Browse-killed-mode)
- (let ((buffer-read-only nil)
- (killed-assoc gnus-killed-assoc))
- (erase-buffer)
- (while killed-assoc
- (insert (gnus-Group-prepare-line (car killed-assoc)))
- (setq killed-assoc (cdr killed-assoc)))
- (goto-char (point-min))
- ))
-
-(defun gnus-Browse-killed-yank ()
- "Yank current newsgroup to Newsgroup buffer."
- (interactive)
- (let ((group (gnus-Group-group-name)))
- (if group
- (let* ((buffer-read-only nil)
- (killed (assoc group gnus-killed-assoc)))
- (pop-to-buffer gnus-Group-buffer) ;Needed to adjust point.
- (if killed
- (gnus-Group-insert-group killed))
- (pop-to-buffer gnus-Browse-killed-buffer)
- (beginning-of-line)
- (delete-region (point)
- (progn (forward-line 1) (point)))
- )))
- (gnus-Browse-killed-check-buffer))
-
-(defun gnus-Browse-killed-check-buffer ()
- "Exit if the buffer is empty by deleting the window and killing the buffer."
- (and (null gnus-killed-assoc)
- (get-buffer gnus-Browse-killed-buffer)
- (gnus-Browse-killed-exit)))
-
-(defun gnus-Browse-killed-exit ()
- "Exit this mode by deleting the window and killing the buffer."
- (interactive)
- (and (get-buffer-window gnus-Browse-killed-buffer)
- (delete-window (get-buffer-window gnus-Browse-killed-buffer)))
- (kill-buffer gnus-Browse-killed-buffer)
- ;; Restore previous window configuration if available.
- (and gnus-winconf-browse-killed
- (set-window-configuration gnus-winconf-browse-killed))
- (setq gnus-winconf-browse-killed nil))
-
-
-;;;
-;;; kill/yank newsgroup commands of GNUS Group Mode
-;;;
-
-(defun gnus-Group-kill-group (n)
- "Kill newsgroup on current line, repeated prefix argument N times.
-The killed newsgroups can be yanked by using \\[gnus-Group-yank-group]."
- (interactive "p")
- (let ((buffer-read-only nil)
- (group nil))
- (while (> n 0)
- (setq group (gnus-Group-group-name))
- (or group
- (signal 'end-of-buffer nil))
- (beginning-of-line)
- (delete-region (point)
- (progn (forward-line 1) (point)))
- (gnus-kill-newsgroup group)
- (setq n (1- n))
- ;; Add to killed newsgroups in the buffer if exists.
- (if (get-buffer gnus-Browse-killed-buffer)
- (save-excursion
- (set-buffer gnus-Browse-killed-buffer)
- (let ((buffer-read-only nil))
- (goto-char (point-min))
- (insert (gnus-Group-prepare-line (car gnus-killed-assoc)))
- )))
- )
- (search-forward ":" nil t)
- ))
-
-(defun gnus-Group-yank-group ()
- "Yank the last newsgroup killed with \\[gnus-Group-kill-group],
-inserting it before the newsgroup on the line containging point."
- (interactive)
- (gnus-Group-insert-group (car gnus-killed-assoc))
- ;; Remove killed newsgroups from the buffer if exists.
- (if (get-buffer gnus-Browse-killed-buffer)
- (save-excursion
- (set-buffer gnus-Browse-killed-buffer)
- (let ((buffer-read-only nil))
- (goto-char (point-min))
- (delete-region (point-min)
- (progn (forward-line 1) (point)))
- )))
- (gnus-Browse-killed-check-buffer))
-
-(defun gnus-Group-insert-group (info)
- "Insert newsgroup at current line using `gnus-newsrc-assoc' INFO."
- (if (null gnus-killed-assoc)
- (error "No killed newsgroups"))
- (if (not gnus-have-all-newsgroups)
- (error
- (substitute-command-keys
- "Not all newsgroups are displayed. Type \\[gnus-Group-list-all-groups] to display all newsgroups.")))
- (let ((buffer-read-only nil)
- (group (gnus-Group-group-name)))
- (gnus-insert-newsgroup info group)
- (beginning-of-line)
- (insert (gnus-Group-prepare-line info))
- (forward-line -1)
- (search-forward ":" nil t)
- ))
diff --git a/lisp/gosmacs.el b/lisp/gosmacs.el
index 98f6368f0a8..5ea2697eeb1 100644
--- a/lisp/gosmacs.el
+++ b/lisp/gosmacs.el
@@ -56,8 +56,8 @@ Use \\[set-gnu-bindings] to restore previous global bindings."
(defun rebind-and-record (bindings)
"Establish many new global bindings and record the bindings replaced.
-Arg BINDINGS is an alist whose elements are (KEY DEFINITION).
-Returns a similar alist whose elements describe the same KEYs
+Arg is an alist whose elements are (KEY DEFINITION).
+Value is a similar alist whose elements describe the same KEYs
but each with the old definition that was replaced,"
(let (old)
(while bindings
diff --git a/lisp/play/hanoi.el b/lisp/hanoi.el
index 8884f6cb37b..21871be7b91 100644
--- a/lisp/play/hanoi.el
+++ b/lisp/hanoi.el
@@ -63,7 +63,7 @@
;;
(switch-to-buffer "*Hanoi*")
(setq buffer-read-only nil)
- (buffer-disable-undo (current-buffer))
+ (buffer-flush-undo (current-buffer))
(erase-buffer)
(let ((i 0))
(while (< i floor-row)
diff --git a/lisp/hanoi.elc b/lisp/hanoi.elc
new file mode 100644
index 00000000000..62e69f90bdd
--- /dev/null
+++ b/lisp/hanoi.elc
Binary files differ
diff --git a/lisp/help.el b/lisp/help.el
new file mode 100644
index 00000000000..09086811e8a
--- /dev/null
+++ b/lisp/help.el
@@ -0,0 +1,295 @@
+;; Help commands for Emacs
+;; Copyright (C) 1985, 1986 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+(defvar help-map (make-sparse-keymap)
+ "Keymap for characters following the Help key.")
+
+(define-key global-map "\C-h" 'help-command)
+(fset 'help-command help-map)
+
+(define-key help-map "\C-h" 'help-for-help)
+(define-key help-map "?" 'help-for-help)
+
+(define-key help-map "\C-c" 'describe-copying)
+(define-key help-map "\C-d" 'describe-distribution)
+(define-key help-map "\C-w" 'describe-no-warranty)
+(define-key help-map "a" 'command-apropos)
+
+(define-key help-map "b" 'describe-bindings)
+
+(define-key help-map "c" 'describe-key-briefly)
+(define-key help-map "k" 'describe-key)
+
+(define-key help-map "d" 'describe-function)
+(define-key help-map "f" 'describe-function)
+
+(define-key help-map "i" 'info)
+
+(define-key help-map "l" 'view-lossage)
+
+(define-key help-map "m" 'describe-mode)
+
+(define-key help-map "\C-n" 'view-emacs-news)
+(define-key help-map "n" 'view-emacs-news)
+
+(define-key help-map "s" 'describe-syntax)
+
+(define-key help-map "t" 'help-with-tutorial)
+
+(define-key help-map "w" 'where-is)
+
+(define-key help-map "v" 'describe-variable)
+
+(defun help-with-tutorial ()
+ "Select the Emacs learn-by-doing tutorial."
+ (interactive)
+ (let ((file (expand-file-name "~/TUTORIAL")))
+ (delete-other-windows)
+ (if (get-file-buffer file)
+ (switch-to-buffer (get-file-buffer file))
+ (switch-to-buffer (create-file-buffer file))
+ (setq buffer-file-name file)
+ (setq default-directory (expand-file-name "~/"))
+ (setq auto-save-file-name nil)
+ (insert-file-contents (expand-file-name "TUTORIAL" exec-directory))
+ (goto-char (point-min))
+ (search-forward "\n<<")
+ (beginning-of-line)
+ (delete-region (point) (progn (end-of-line) (point)))
+ (newline (- (window-height (selected-window))
+ (count-lines (point-min) (point))
+ 6))
+ (goto-char (point-min))
+ (set-buffer-modified-p nil))))
+
+(defun describe-key-briefly (key)
+ "Print the name of the function KEY invokes. KEY is a string."
+ (interactive "kDescribe key briefly: ")
+ (let ((defn (key-binding key)))
+ (if (or (null defn) (integerp defn))
+ (message "%s is undefined" (key-description key))
+ (message "%s runs the command %s"
+ (key-description key)
+ (if (symbolp defn) defn (prin1-to-string defn))))))
+
+(defun print-help-return-message (&optional function)
+ "Display or return message saying how to restore windows after help command.
+Computes a message and applies the argument FUNCTION to it.
+If FUNCTION is nil, applies `message' to it, thus printing it."
+ (and (not (get-buffer-window standard-output))
+ (funcall (or function 'message)
+ (substitute-command-keys
+ (if (one-window-p t)
+ (if pop-up-windows
+ "Type \\[delete-other-windows] to remove help window."
+ "Type \\[switch-to-buffer] RET to remove help window.")
+ "Type \\[switch-to-buffer-other-window] RET to restore old contents of help window.")))))
+
+(defun describe-key (key)
+ "Display documentation of the function KEY invokes. KEY is a string."
+ (interactive "kDescribe key: ")
+ (let ((defn (key-binding key)))
+ (if (or (null defn) (integerp defn))
+ (message "%s is undefined" (key-description key))
+ (with-output-to-temp-buffer "*Help*"
+ (prin1 defn)
+ (princ ":\n")
+ (if (documentation defn)
+ (princ (documentation defn))
+ (princ "not documented"))
+ (print-help-return-message)))))
+
+(defun describe-mode ()
+ "Display documentation of current major mode."
+ (interactive)
+ (with-output-to-temp-buffer "*Help*"
+ (princ mode-name)
+ (princ " Mode:\n")
+ (princ (documentation major-mode))
+ (print-help-return-message)))
+
+(defun describe-distribution ()
+ "Display info on how to obtain the latest version of GNU Emacs."
+ (interactive)
+ (find-file-read-only
+ (expand-file-name "DISTRIB" exec-directory)))
+
+(defun describe-copying ()
+ "Display info on how you may redistribute copies of GNU Emacs."
+ (interactive)
+ (find-file-read-only
+ (expand-file-name "COPYING" exec-directory))
+ (goto-char (point-min)))
+
+(defun describe-no-warranty ()
+ "Display info on all the kinds of warranty Emacs does NOT have."
+ (interactive)
+ (describe-copying)
+ (let (case-fold-search)
+ (search-forward "NO WARRANTY")
+ (recenter 0)))
+
+(defun view-emacs-news ()
+ "Display info on recent changes to Emacs."
+ (interactive)
+ (find-file-read-only (expand-file-name "NEWS" exec-directory)))
+
+(defun view-lossage ()
+ "Display last 100 input keystrokes."
+ (interactive)
+ (with-output-to-temp-buffer "*Help*"
+ (princ (key-description (recent-keys)))
+ (save-excursion
+ (set-buffer standard-output)
+ (goto-char (point-min))
+ (while (progn (move-to-column 50) (not (eobp)))
+ (search-forward " " nil t)
+ (insert "\n")))
+ (print-help-return-message)))
+
+(defun help-for-help ()
+ "You have typed C-h, the help character. Type a Help option:
+
+A command-apropos. Give a substring, and see a list of commands
+ (functions interactively callable) that contain
+ that substring. See also the apropos command.
+B describe-bindings. Display table of all key bindings.
+C describe-key-briefly. Type a command key sequence;
+ it prints the function name that sequence runs.
+F describe-function. Type a function name and get documentation of it.
+I info. The info documentation reader.
+K describe-key. Type a command key sequence;
+ it displays the full documentation.
+L view-lossage. Shows last 100 characters you typed.
+M describe-mode. Print documentation of current major mode,
+ which describes the commands peculiar to it.
+N view-emacs-news. Shows emacs news file.
+S describe-syntax. Display contents of syntax table, plus explanations
+T help-with-tutorial. Select the Emacs learn-by-doing tutorial.
+V describe-variable. Type name of a variable;
+ it displays the variable's documentation and value.
+W where-is. Type command name; it prints which keystrokes
+ invoke that command.
+C-c print Emacs copying permission (General Public License).
+C-d print Emacs ordering information.
+C-n print news of recent Emacs changes.
+C-w print information on absence of warranty for GNU Emacs."
+ (interactive)
+ (message
+ "A B C F I K L M N S T V W C-c C-d C-n C-w. Type C-h again for more help: ")
+ (let ((char (read-char)))
+ (if (or (= char ?\C-h) (= char ??))
+ (save-window-excursion
+ (switch-to-buffer "*Help*")
+ (erase-buffer)
+ (insert (documentation 'help-for-help))
+ (goto-char (point-min))
+ (while (memq char '(?\C-h ?? ?\C-v ?\ ?\177 ?\M-v))
+ (if (memq char '(?\C-v ?\ ))
+ (scroll-up))
+ (if (memq char '(?\177 ?\M-v))
+ (scroll-down))
+ (message "A B C F I K L M N S T V W C-c C-d C-n C-w%s: "
+ (if (pos-visible-in-window-p (point-max))
+ "" " or Space to scroll"))
+ (let ((cursor-in-echo-area t))
+ (setq char (read-char))))))
+ (let ((defn (cdr (assq (downcase char) (cdr help-map)))))
+ (if defn (call-interactively defn) (ding)))))
+
+
+(defun function-called-at-point ()
+ (condition-case ()
+ (save-excursion
+ (save-restriction
+ (narrow-to-region (max (point-min) (- (point) 1000)) (point-max))
+ (backward-up-list 1)
+ (forward-char 1)
+ (let (obj)
+ (setq obj (read (current-buffer)))
+ (and (symbolp obj) (fboundp obj) obj))))
+ (error nil)))
+
+(defun describe-function (function)
+ "Display the full documentation of FUNCTION (a symbol)."
+ (interactive
+ (let ((fn (function-called-at-point))
+ (enable-recursive-minibuffers t)
+ val)
+ (setq val (completing-read (if fn
+ (format "Describe function (default %s): " fn)
+ "Describe function: ")
+ obarray 'fboundp t))
+ (list (if (equal val "")
+ fn (intern val)))))
+ (with-output-to-temp-buffer "*Help*"
+ (prin1 function)
+ (princ ":
+")
+ (if (documentation function)
+ (princ (documentation function))
+ (princ "not documented"))
+ (print-help-return-message)))
+
+(defun variable-at-point ()
+ (condition-case ()
+ (save-excursion
+ (forward-sexp -1)
+ (skip-chars-forward "'")
+ (let ((obj (read (current-buffer))))
+ (and (symbolp obj) (boundp obj) obj)))
+ (error nil)))
+
+(defun describe-variable (variable)
+ "Display the full documentation of VARIABLE (a symbol)."
+ (interactive
+ (let ((v (variable-at-point))
+ (enable-recursive-minibuffers t)
+ val)
+ (setq val (completing-read (if v
+ (format "Describe variable (default %s): " v)
+ "Describe variable: ")
+ obarray 'boundp t))
+ (list (if (equal val "")
+ v (intern val)))))
+ (with-output-to-temp-buffer "*Help*"
+ (prin1 variable)
+ (princ "'s value is ")
+ (if (not (boundp variable))
+ (princ "void.")
+ (prin1 (symbol-value variable)))
+ (terpri) (terpri)
+ (princ "Documentation:")
+ (terpri)
+ (let ((doc (documentation-property variable 'variable-documentation)))
+ (if doc
+ (princ (substitute-command-keys doc))
+ (princ "not documented as a variable.")))
+ (print-help-return-message)))
+
+(defun command-apropos (string)
+ "Like apropos but lists only symbols that are names of commands
+\(interactively callable functions)."
+ (interactive "sCommand apropos (regexp): ")
+ (let ((message
+ (let ((standard-output (get-buffer-create "*Help*")))
+ (print-help-return-message 'identity))))
+ (apropos string 'commandp)
+ (and message (message message))))
diff --git a/lisp/help.elc b/lisp/help.elc
new file mode 100644
index 00000000000..7969b2ecf8a
--- /dev/null
+++ b/lisp/help.elc
Binary files differ
diff --git a/lisp/emacs-lisp/helper.el b/lisp/helper.el
index 233196b5973..aa7253eab6c 100644
--- a/lisp/emacs-lisp/helper.el
+++ b/lisp/helper.el
@@ -87,13 +87,13 @@
(sit-for 4))
(defun Helper-describe-key-briefly (key)
- "Briefly describe binding of KEY."
+ "Briefly describe binding of KEYS."
(interactive "kDescribe key briefly: ")
(describe-key-briefly key)
(sit-for 4))
(defun Helper-describe-key (key)
- "Describe binding of KEY."
+ "Describe binding of KEYS."
(interactive "kDescribe key: ")
(save-window-excursion (describe-key key))
(Helper-help-scroller))
diff --git a/lisp/helper.elc b/lisp/helper.elc
new file mode 100644
index 00000000000..36bc188410a
--- /dev/null
+++ b/lisp/helper.elc
Binary files differ
diff --git a/lisp/hexl.el b/lisp/hexl.el
deleted file mode 100644
index 8671413e81a..00000000000
--- a/lisp/hexl.el
+++ /dev/null
@@ -1,659 +0,0 @@
-;; -*-Emacs-Lisp-*-
-;; hexl-mode -- Edit a file in a hex dump format.
-;; Copyright (C) 1989 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;;
-;; By: Keith Gabryelski (ag@wheaties.ai.mit.edu)
-;;
-;; This may be useful in your .emacs:
-;;
-;; (autoload 'hexl-find-file "hexl"
-;; "Edit file FILENAME in hexl-mode." t)
-;;
-;; (define-key global-map "\C-c\C-h" 'hexl-find-file)
-;;
-;; NOTE: Remember to change HEXL-PROGRAM or HEXL-OPTIONS if needed.
-;;
-;; Currently hexl only supports big endian hex output with 16 bit
-;; grouping.
-;;
-;; -iso in `hexl-options' will allow iso characters to display in the
-;; ASCII region of the screen (if your emacs supports this) instead of
-;; changing them to dots.
-
-;;
-;; vars here
-;;
-
-(defvar hexl-program "hexl"
- "The program that will hexlify and de-hexlify its stdin.
-`hexl-program' will always be concated with `hexl-options'
-and \"-de\" when dehexlfying a buffer.")
-
-(defvar hexl-iso ""
- "If your emacs can handle ISO characters, this should be set to
-\"-iso\" otherwise it should be \"\".")
-
-(defvar hexl-options (format "-hex %s" hexl-iso)
- "Options to hexl-program that suit your needs.")
-
-(defvar hexlify-command (format "%s %s" hexl-program hexl-options)
- "The command to use to hexlify a buffer. It is the concatination of
-`hexl-program' and `hexl-options'.")
-
-(defvar dehexlify-command (format "%s -de %s" hexl-program hexl-options)
- "The command to use to unhexlify a buffer. It is the concatination of
-`hexl-program', the option \"-de\", and `hexl-options'.")
-
-(defvar hexl-max-address 0
- "Maximum offset into hexl buffer.")
-
-(defvar hexl-mode-map nil)
-
-;; routines
-
-(defun hexl-mode (&optional arg)
- "\\<hexl-mode-map>
-A major mode for editting binary files in hex dump format.
-
-This function automatically converts a buffer into the hexl format
-using the function `hexlify-buffer'.
-
-Each line in the buffer has an \"address\" (displayed in hexadecimal)
-representing the offset into the file that the characters on this line
-are at and 16 characters from the file (displayed as hexadecimal
-values grouped every 16 bits) and as their ASCII values.
-
-If any of the characters (displayed as ASCII characters) are
-unprintable (control or meta characters) they will be replaced as
-periods.
-
-If `hexl-mode' is invoked with an argument the buffer is assumed to be
-in hexl format.
-
-A sample format:
-
- HEX ADDR: 0001 0203 0405 0607 0809 0a0b 0c0d 0e0f ASCII-TEXT
- -------- ---- ---- ---- ---- ---- ---- ---- ---- ----------------
- 00000000: 5468 6973 2069 7320 6865 786c 2d6d 6f64 This is hexl-mod
- 00000010: 652e 2020 4561 6368 206c 696e 6520 7265 e. Each line re
- 00000020: 7072 6573 656e 7473 2031 3620 6279 7465 presents 16 byte
- 00000030: 7320 6173 2068 6578 6164 6563 696d 616c s as hexadecimal
- 00000040: 2041 5343 4949 0a61 6e64 2070 7269 6e74 ASCII.and print
- 00000050: 6162 6c65 2041 5343 4949 2063 6861 7261 able ASCII chara
- 00000060: 6374 6572 732e 2020 416e 7920 636f 6e74 cters. Any cont
- 00000070: 726f 6c20 6f72 206e 6f6e 2d41 5343 4949 rol or non-ASCII
- 00000080: 2063 6861 7261 6374 6572 730a 6172 6520 characters.are
- 00000090: 6469 7370 6c61 7965 6420 6173 2070 6572 displayed as per
- 000000a0: 696f 6473 2069 6e20 7468 6520 7072 696e iods in the prin
- 000000b0: 7461 626c 6520 6368 6172 6163 7465 7220 table character
- 000000c0: 7265 6769 6f6e 2e0a region..
-
-Movement is as simple as movement in a normal emacs text buffer. Most
-cursor movement bindings are the same (ie. Use \\[hexl-backward-char], \\[hexl-forward-char], \\[hexl-next-line], and \\[hexl-previous-line]
-to move the cursor left, right, down, and up).
-
-Advanced cursor movement commands (ala \\[hexl-beginning-of-line], \\[hexl-end-of-line], \\[hexl-beginning-of-buffer], and \\[hexl-end-of-buffer]) are
-also supported.
-
-There are several ways to change text in hexl mode:
-
-ASCII characters (character between space (0x20) and tilde (0x7E)) are
-bound to self-insert so you can simply type the character and it will
-insert itself (actually overstrike) into the buffer.
-
-\\[hexl-quoted-insert] followed by another keystroke allows you to insert the key even if
-it isn't bound to self-insert. An octal number can be supplied in place
-of another key to insert the octal number's ASCII representation.
-
-\\[hexl-insert-hex-char] will insert a given hexadecimal value (if it is between 0 and 0xFF)
-into the buffer at the current point.
-
-\\[hexl-insert-octal-char] will insert a given octal value (if it is between 0 and 0377)
-into the buffer at the current point.
-
-\\[hexl-insert-decimal-char] will insert a given decimal value (if it is between 0 and 255)
-into the buffer at the current point.
-
-\\[hexl-save-buffer] will save the buffer in is binary format.
-
-\\[hexl-mode-exit] will exit hexl-mode.
-
-Note: \\[write-file] will write the file out in HEXL FORMAT.
-
-You can use \\[hexl-find-file] to visit a file in hexl-mode.
-
-\\[describe-bindings] for advanced commands."
- (interactive "p")
- (if (eq major-mode 'hexl-mode)
- (error "You are already in hexl mode.")
- (kill-all-local-variables)
- (make-local-variable 'hexl-mode-old-local-map)
- (setq hexl-mode-old-local-map (current-local-map))
- (use-local-map hexl-mode-map)
-
- (make-local-variable 'hexl-mode-old-mode-name)
- (setq hexl-mode-old-mode-name mode-name)
- (setq mode-name "Hexl")
-
- (make-local-variable 'hexl-mode-old-major-mode)
- (setq hexl-mode-old-major-mode major-mode)
- (setq major-mode 'hexl-mode)
-
- (let ((modified (buffer-modified-p))
- (read-only buffer-read-only)
- (original-point (1- (point))))
- (if (not (or (eq arg 1) (not arg)))
-;; if no argument then we guess at hexl-max-address
- (setq hexl-max-address (+ (* (/ (1- (buffer-size)) 68) 16) 15))
- (setq buffer-read-only nil)
- (setq hexl-max-address (1- (buffer-size)))
- (hexlify-buffer)
- (set-buffer-modified-p modified)
- (setq buffer-read-only read-only)
- (hexl-goto-address original-point)))))
-
-(defun hexl-save-buffer ()
- "Save a hexl format buffer as binary in visited file if modified."
- (interactive)
- (set-buffer-modified-p (if (buffer-modified-p)
- (save-excursion
- (let ((buf (generate-new-buffer " hexl"))
- (name (buffer-name))
- (file-name (buffer-file-name))
- (start (point-min))
- (end (point-max))
- modified)
- (set-buffer buf)
- (insert-buffer-substring name start end)
- (set-buffer name)
- (dehexlify-buffer)
- (save-buffer)
- (setq modified (buffer-modified-p))
- (delete-region (point-min) (point-max))
- (insert-buffer-substring buf start end)
- (kill-buffer buf)
- modified))
- (message "(No changes need to be saved)")
- nil)))
-
-(defun hexl-find-file (filename)
- "Edit file FILENAME in hexl-mode.
-Switch to a buffer visiting file FILENAME, creating one in none exists."
- (interactive "fFilename: ")
- (find-file filename)
- (if (not (eq major-mode 'hexl-mode))
- (hexl-mode)))
-
-(defun hexl-mode-exit (&optional arg)
- "Exit hexl-mode returning to previous mode.
-With arg, don't unhexlify buffer."
- (interactive "p")
- (if (or (eq arg 1) (not arg))
- (let ((modified (buffer-modified-p))
- (read-only buffer-read-only)
- (original-point (1+ (hexl-current-address))))
- (setq buffer-read-only nil)
- (dehexlify-buffer)
- (set-buffer-modified-p modified)
- (setq buffer-read-only read-only)
- (goto-char original-point)))
- (setq mode-name hexl-mode-old-mode-name)
- (use-local-map hexl-mode-old-local-map)
- (setq major-mode hexl-mode-old-major-mode)
-;; Kludge to update mode-line
- (switch-to-buffer (current-buffer))
-)
-
-(defun hexl-current-address ()
- "Return current hexl-address."
- (interactive)
- (let ((current-column (- (% (point) 68) 11))
- (hexl-address 0))
- (setq hexl-address (+ (* (/ (point) 68) 16)
- (/ (- current-column (/ current-column 5)) 2)))
- hexl-address))
-
-(defun hexl-address-to-marker (address)
- "Return marker for ADDRESS."
- (interactive "nAddress: ")
- (+ (* (/ address 16) 68) 11 (/ (* (% address 16) 5) 2)))
-
-(defun hexl-goto-address (address)
- "Goto hexl-mode (decimal) address ADDRESS.
-
-Signal error if ADDRESS out of range."
- (interactive "nAddress: ")
- (if (or (< address 0) (> address hexl-max-address))
- (error "Out of hexl region."))
- (goto-char (hexl-address-to-marker address)))
-
-(defun hexl-goto-hex-address (hex-address)
- "Go to hexl-mode address (hex string) HEX-ADDRESS.
-
-Signal error if HEX-ADDRESS is out of range."
- (interactive "sHex Address: ")
- (hexl-goto-address (hexl-hex-string-to-integer hex-address)))
-
-(defun hexl-hex-string-to-integer (hex-string)
- "Return decimal integer for HEX-STRING."
- (interactive "sHex number: ")
- (let ((hex-num 0))
- (while (not (equal hex-string ""))
- (setq hex-num (+ (* hex-num 16)
- (hexl-hex-char-to-integer (string-to-char hex-string))))
- (setq hex-string (substring hex-string 1)))
- hex-num))
-
-(defun hexl-octal-string-to-integer (octal-string)
- "Return decimal integer for OCTAL-STRING."
- (interactive "sOctal number: ")
- (let ((oct-num 0))
- (while (not (equal octal-string ""))
- (setq oct-num (+ (* oct-num 8)
- (hexl-oct-char-to-integer
- (string-to-char octal-string))))
- (setq octal-string (substring octal-string 1)))
- oct-num))
-
-;; move point functions
-
-(defun hexl-backward-char (arg)
- "Move to left ARG bytes (right if ARG negative) in hexl-mode."
- (interactive "p")
- (hexl-goto-address (- (hexl-current-address) arg)))
-
-(defun hexl-forward-char (arg)
- "Move right ARG bytes (left if ARG negative) in hexl-mode."
- (interactive "p")
- (hexl-goto-address (+ (hexl-current-address) arg)))
-
-(defun hexl-backward-short (arg)
- "Move to left ARG shorts (right if ARG negative) in hexl-mode."
- (interactive "p")
- (hexl-goto-address (let ((address (hexl-current-address)))
- (if (< arg 0)
- (progn
- (setq arg (- arg))
- (while (> arg 0)
- (if (not (equal address (logior address 3)))
- (if (> address hexl-max-address)
- (progn
- (message "End of buffer.")
- (setq address hexl-max-address))
- (setq address (logior address 3)))
- (if (> address hexl-max-address)
- (progn
- (message "End of buffer.")
- (setq address hexl-max-address))
- (setq address (+ address 4))))
- (setq arg (1- arg)))
- (if (> address hexl-max-address)
- (progn
- (message "End of buffer.")
- (setq address hexl-max-address))
- (setq address (logior address 3))))
- (while (> arg 0)
- (if (not (equal address (logand address -4)))
- (setq address (logand address -4))
- (if (not (equal address 0))
- (setq address (- address 4))
- (message "Beginning of buffer.")))
- (setq arg (1- arg))))
- address)))
-
-(defun hexl-forward-short (arg)
- "Move right ARG shorts (left if ARG negative) in hexl-mode."
- (interactive "p")
- (hexl-backward-short (- arg)))
-
-(defun hexl-backward-word (arg)
- "Move to left ARG words (right if ARG negative) in hexl-mode."
- (interactive "p")
- (hexl-goto-address (let ((address (hexl-current-address)))
- (if (< arg 0)
- (progn
- (setq arg (- arg))
- (while (> arg 0)
- (if (not (equal address (logior address 7)))
- (if (> address hexl-max-address)
- (progn
- (message "End of buffer.")
- (setq address hexl-max-address))
- (setq address (logior address 7)))
- (if (> address hexl-max-address)
- (progn
- (message "End of buffer.")
- (setq address hexl-max-address))
- (setq address (+ address 8))))
- (setq arg (1- arg)))
- (if (> address hexl-max-address)
- (progn
- (message "End of buffer.")
- (setq address hexl-max-address))
- (setq address (logior address 7))))
- (while (> arg 0)
- (if (not (equal address (logand address -8)))
- (setq address (logand address -8))
- (if (not (equal address 0))
- (setq address (- address 8))
- (message "Beginning of buffer.")))
- (setq arg (1- arg))))
- address)))
-
-(defun hexl-forward-word (arg)
- "Move right ARG words (left if ARG negative) in hexl-mode."
- (interactive "p")
- (hexl-backward-word (- arg)))
-
-(defun hexl-previous-line (arg)
- "Move vertically up ARG lines [16 bytes] (down if ARG negative) in hexl-mode.
-If there is byte at the target address move to the last byte in that line."
- (interactive "p")
- (hexl-next-line (- arg)))
-
-(defun hexl-next-line (arg)
- "Move vertically down ARG lines [16 bytes] (up if ARG negative) in hexl-mode.
-If there is no byte at the target address move to the last byte in that line."
- (interactive "p")
- (hexl-goto-address (let ((address (+ (hexl-current-address) (* arg 16)) t))
- (if (and (< arg 0) (< address 0))
- (progn (message "Out of hexl region.")
- (setq address
- (% (hexl-current-address) 16)))
- (if (and (> address hexl-max-address)
- (< (% hexl-max-address 16) (% address 16)))
- (setq address hexl-max-address)
- (if (> address hexl-max-address)
- (progn (message "Out of hexl region.")
- (setq
- address
- (+ (logand hexl-max-address -16)
- (% (hexl-current-address) 16)))))))
- address)))
-
-(defun hexl-beginning-of-buffer (arg)
- "Move to the beginning of the hexl buffer.
-Leaves `hexl-mark' at previous position.
-With prefix arg N, puts point N bytes of the way from the true beginning."
- (interactive "p")
- (push-mark (point))
- (hexl-goto-address (+ 0 (1- arg))))
-
-(defun hexl-end-of-buffer (arg)
- "Go to `hexl-max-address' minus ARG."
- (interactive "p")
- (push-mark (point))
- (hexl-goto-address (- hexl-max-address (1- arg))))
-
-(defun hexl-beginning-of-line ()
- "Goto beginning of line in hexl mode."
- (interactive)
- (goto-char (+ (* (/ (point) 68) 68) 11)))
-
-(defun hexl-end-of-line ()
- "Goto end of line in hexl mode."
- (interactive)
- (hexl-goto-address (let ((address (logior (hexl-current-address) 15)))
- (if (> address hexl-max-address)
- (setq address hexl-max-address))
- address)))
-
-(defun hexl-scroll-down (arg)
- "Scroll hexl buffer window upward ARG lines; or near full window if no ARG."
- (interactive "P")
- (if (null arg)
- (setq arg (1- (window-height)))
- (setq arg (prefix-numeric-value arg)))
- (hexl-scroll-up (- arg)))
-
-(defun hexl-scroll-up (arg)
- "Scroll hexl buffer window upward ARG lines; or near full window if no ARG."
- (interactive "P")
- (if (null arg)
- (setq arg (1- (window-height)))
- (setq arg (prefix-numeric-value arg)))
- (let ((movement (* arg 16))
- (address (hexl-current-address)))
- (if (or (> (+ address movement) hexl-max-address)
- (< (+ address movement) 0))
- (message "Out of hexl region.")
- (hexl-goto-address (+ address movement))
- (recenter 0))))
-
-(defun hexl-beginning-of-1k-page ()
- "Goto to beginning of 1k boundry."
- (interactive)
- (hexl-goto-address (logand (hexl-current-address) -1024)))
-
-(defun hexl-end-of-1k-page ()
- "Goto to end of 1k boundry."
- (interactive)
- (hexl-goto-address (let ((address (logior (hexl-current-address) 1023)))
- (if (> address hexl-max-address)
- (setq address hexl-max-address))
- address)))
-
-(defun hexl-beginning-of-512b-page ()
- "Goto to beginning of 512 byte boundry."
- (interactive)
- (hexl-goto-address (logand (hexl-current-address) -512)))
-
-(defun hexl-end-of-512b-page ()
- "Goto to end of 512 byte boundry."
- (interactive)
- (hexl-goto-address (let ((address (logior (hexl-current-address) 511)))
- (if (> address hexl-max-address)
- (setq address hexl-max-address))
- address)))
-
-(defun hexl-quoted-insert (arg)
- "Read next input character and insert it.
-Useful for inserting control characters.
-You may also type up to 3 octal digits, to insert a character with that code"
- (interactive "p")
- (hexl-insert-char (read-quoted-char) arg))
-
-;00000000: 0011 2233 4455 6677 8899 aabb ccdd eeff 0123456789ABCDEF
-
-(defun hexlify-buffer ()
- "Convert a binary buffer to hexl format"
- (interactive)
- (shell-command-on-region (point-min) (point-max) hexlify-command t))
-
-(defun dehexlify-buffer ()
- "Convert a hexl format buffer to binary."
- (interactive)
- (shell-command-on-region (point-min) (point-max) dehexlify-command t))
-
-(defun hexl-char-after-point ()
- "Return char for ASCII hex digits at point."
- (setq lh (char-after (point)))
- (setq rh (char-after (1+ (point))))
- (hexl-htoi lh rh))
-
-(defun hexl-htoi (lh rh)
- "Hex (char) LH (char) RH to integer."
- (+ (* (hexl-hex-char-to-integer lh) 16)
- (hexl-hex-char-to-integer rh)))
-
-(defun hexl-hex-char-to-integer (character)
- "Take a char and return its value as if it was a hex digit."
- (if (and (>= character ?0) (<= character ?9))
- (- character ?0)
- (let ((ch (logior character 32)))
- (if (and (>= ch ?a) (<= ch ?f))
- (- ch (- ?a 10))
- (error (format "Invalid hex digit `%c'." ch))))))
-
-(defun hexl-oct-char-to-integer (character)
- "Take a char and return its value as if it was a octal digit."
- (if (and (>= character ?0) (<= character ?7))
- (- character ?0)
- (error (format "Invalid octal digit `%c'." character))))
-
-(defun hexl-printable-character (ch)
- "Return a displayable string for character CH."
- (format "%c" (if hexl-iso
- (if (or (< ch 32) (and (>= ch 127) (< ch 160)))
- 46
- ch)
- (if (or (< ch 32) (>= ch 127))
- 46
- ch))))
-
-(defun hexl-self-insert-command (arg)
- "Insert this character."
- (interactive "p")
- (hexl-insert-char last-command-char arg))
-
-(defun hexl-insert-char (ch num)
- "Insert a character in a hexl buffer."
- (let ((address (hexl-current-address)))
- (while (> num 0)
- (delete-char 2)
- (insert (format "%02x" ch))
- (goto-char
- (+ (* (/ address 16) 68) 52 (% address 16)))
- (delete-char 1)
- (insert (hexl-printable-character ch))
- (if (eq address hexl-max-address)
- (hexl-goto-address address)
- (hexl-goto-address (1+ address)))
- (setq num (1- num)))))
-
-;; hex conversion
-
-(defun hexl-insert-hex-char (arg)
- "Insert a ASCII char ARG times at point for a given hexadecimal number."
- (interactive "p")
- (let ((num (hexl-hex-string-to-integer (read-string "Hex number: "))))
- (if (or (> num 255) (< num 0))
- (error "Hex number out of range.")
- (hexl-insert-char num arg))))
-
-(defun hexl-insert-decimal-char (arg)
- "Insert a ASCII char ARG times at point for a given decimal number."
- (interactive "p")
- (let ((num (string-to-int (read-string "Decimal Number: "))))
- (if (or (> num 255) (< num 0))
- (error "Decimal number out of range.")
- (hexl-insert-char num arg))))
-
-(defun hexl-insert-octal-char (arg)
- "Insert a ASCII char ARG times at point for a given octal number."
- (interactive "p")
- (let ((num (hexl-octal-string-to-integer (read-string "Octal Number: "))))
- (if (or (> num 255) (< num 0))
- (error "Decimal number out of range.")
- (hexl-insert-char num arg))))
-
-;; startup stuff.
-
-(if hexl-mode-map
- nil
- (setq hexl-mode-map (make-sparse-keymap))
-
- (define-key hexl-mode-map "\C-a" 'hexl-beginning-of-line)
- (define-key hexl-mode-map "\C-b" 'hexl-backward-char)
- (define-key hexl-mode-map "\C-d" 'undefined)
- (define-key hexl-mode-map "\C-e" 'hexl-end-of-line)
- (define-key hexl-mode-map "\C-f" 'hexl-forward-char)
-
- (if (not (eq (key-binding "\C-h") 'help-command))
- (define-key hexl-mode-map "\C-h" 'undefined))
-
- (define-key hexl-mode-map "\C-i" 'hexl-self-insert-command)
- (define-key hexl-mode-map "\C-j" 'hexl-self-insert-command)
- (define-key hexl-mode-map "\C-k" 'undefined)
- (define-key hexl-mode-map "\C-m" 'hexl-self-insert-command)
- (define-key hexl-mode-map "\C-n" 'hexl-next-line)
- (define-key hexl-mode-map "\C-o" 'undefined)
- (define-key hexl-mode-map "\C-p" 'hexl-previous-line)
- (define-key hexl-mode-map "\C-q" 'hexl-quoted-insert)
- (define-key hexl-mode-map "\C-t" 'undefined)
- (define-key hexl-mode-map "\C-v" 'hexl-scroll-up)
- (define-key hexl-mode-map "\C-w" 'undefined)
- (define-key hexl-mode-map "\C-y" 'undefined)
-
- (let ((ch 32))
- (while (< ch 127)
- (define-key hexl-mode-map (format "%c" ch) 'hexl-self-insert-command)
- (setq ch (1+ ch))))
-
- (define-key hexl-mode-map "\e\C-a" 'hexl-beginning-of-512b-page)
- (define-key hexl-mode-map "\e\C-b" 'hexl-backward-short)
- (define-key hexl-mode-map "\e\C-c" 'undefined)
- (define-key hexl-mode-map "\e\C-d" 'hexl-insert-decimal-char)
- (define-key hexl-mode-map "\e\C-e" 'hexl-end-of-512b-page)
- (define-key hexl-mode-map "\e\C-f" 'hexl-forward-short)
- (define-key hexl-mode-map "\e\C-g" 'undefined)
- (define-key hexl-mode-map "\e\C-h" 'undefined)
- (define-key hexl-mode-map "\e\C-i" 'undefined)
- (define-key hexl-mode-map "\e\C-j" 'undefined)
- (define-key hexl-mode-map "\e\C-k" 'undefined)
- (define-key hexl-mode-map "\e\C-l" 'undefined)
- (define-key hexl-mode-map "\e\C-m" 'undefined)
- (define-key hexl-mode-map "\e\C-n" 'undefined)
- (define-key hexl-mode-map "\e\C-o" 'hexl-insert-octal-char)
- (define-key hexl-mode-map "\e\C-p" 'undefined)
- (define-key hexl-mode-map "\e\C-q" 'undefined)
- (define-key hexl-mode-map "\e\C-r" 'undefined)
- (define-key hexl-mode-map "\e\C-s" 'undefined)
- (define-key hexl-mode-map "\e\C-t" 'undefined)
- (define-key hexl-mode-map "\e\C-u" 'undefined)
-
- (define-key hexl-mode-map "\e\C-w" 'undefined)
- (define-key hexl-mode-map "\e\C-x" 'hexl-insert-hex-char)
- (define-key hexl-mode-map "\e\C-y" 'undefined)
-
- (define-key hexl-mode-map "\ea" 'hexl-beginning-of-1k-page)
- (define-key hexl-mode-map "\eb" 'hexl-backward-word)
- (define-key hexl-mode-map "\ec" 'undefined)
- (define-key hexl-mode-map "\ed" 'undefined)
- (define-key hexl-mode-map "\ee" 'hexl-end-of-1k-page)
- (define-key hexl-mode-map "\ef" 'hexl-forward-word)
- (define-key hexl-mode-map "\eg" 'hexl-goto-hex-address)
- (define-key hexl-mode-map "\eh" 'undefined)
- (define-key hexl-mode-map "\ei" 'undefined)
- (define-key hexl-mode-map "\ej" 'hexl-goto-address)
- (define-key hexl-mode-map "\ek" 'undefined)
- (define-key hexl-mode-map "\el" 'undefined)
- (define-key hexl-mode-map "\em" 'undefined)
- (define-key hexl-mode-map "\en" 'undefined)
- (define-key hexl-mode-map "\eo" 'undefined)
- (define-key hexl-mode-map "\ep" 'undefined)
- (define-key hexl-mode-map "\eq" 'undefined)
- (define-key hexl-mode-map "\er" 'undefined)
- (define-key hexl-mode-map "\es" 'undefined)
- (define-key hexl-mode-map "\et" 'undefined)
- (define-key hexl-mode-map "\eu" 'undefined)
- (define-key hexl-mode-map "\ev" 'hexl-scroll-down)
- (define-key hexl-mode-map "\ey" 'undefined)
- (define-key hexl-mode-map "\ez" 'undefined)
- (define-key hexl-mode-map "\e<" 'hexl-beginning-of-buffer)
- (define-key hexl-mode-map "\e>" 'hexl-end-of-buffer)
-
- (define-key hexl-mode-map "\C-c\C-c" 'hexl-mode-exit)
-
- (define-key hexl-mode-map "\C-x\C-p" 'undefined)
- (define-key hexl-mode-map "\C-x\C-s" 'hexl-save-buffer)
- (define-key hexl-mode-map "\C-x\C-t" 'undefined))
-
-;; The End.
diff --git a/lisp/progmodes/hideif.el b/lisp/hideif.el
index 4a1b9897808..9c39980e9bd 100644
--- a/lisp/progmodes/hideif.el
+++ b/lisp/hideif.el
@@ -120,14 +120,14 @@
(defvar hide-ifdef-mode-map nil
- "Keymap used with Hide-Ifdef mode")
+ "Keymap used with hide-ifdef mode")
(defconst hide-ifdef-mode-prefix-key "\C-c"
- "Prefix key for all Hide-Ifdef mode commands.")
+ "Prefix key for all hide-ifdef-mode commands.")
(defvar hide-ifdef-mode-map-before nil
"Buffer-local variable to store a copy of the local keymap
-before `hide-ifdef-mode' modifies it.")
+ before hide-ifdef-mode modifies it.")
(defun define-hide-ifdef-mode-map ()
(if hide-ifdef-mode-map
@@ -151,7 +151,7 @@ before `hide-ifdef-mode' modifies it.")
(define-key hide-ifdef-mode-map "\C-p" 'previous-ifdef)
(define-key hide-ifdef-mode-map "\C-q" 'hide-ifdef-toggle-read-only)
(define-key hide-ifdef-mode-map
- (where-is-internal 'toggle-read-only nil nil t)
+ (where-is-internal 'toggle-read-only nil t)
'hide-ifdef-toggle-outside-read-only)
)
(fset 'hide-ifdef-mode-map hide-ifdef-mode-map) ; the function is the map
@@ -161,6 +161,7 @@ before `hide-ifdef-mode' modifies it.")
"Update mode-line by setting buffer-modified to itself."
(set-buffer-modified-p (buffer-modified-p)))
+
(defvar hide-ifdef-mode nil
"non-nil when hide-ifdef-mode is activated.")
@@ -177,35 +178,35 @@ before `hide-ifdef-mode' modifies it.")
(cons '(hide-ifdef-mode " Ifdef")
minor-mode-alist)))
+
(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 iff arg is positive.
-In Hide-Ifdef mode, code within #ifdef constructs that the C preprocessor
+ "Toggle hide-ifdef-mode. Thus this is a minor mode, albeit a large one.
+With arg, turn hide-ifdef-mode on iff arg is positive.
+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.
+ 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'.
+ 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
+ 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.
+ After show-ifdefs, read-only status is restored to previous value.
\\{hide-ifdef-mode-map}"
@@ -235,7 +236,7 @@ hide-ifdef-read-only
(make-local-variable 'hif-outside-read-only)
(setq hif-outside-read-only buffer-read-only)
- (make-local-variable 'hide-ifdef-mode-map-before)
+ (make-local-variable 'ide-ifdef-mode-map-before)
(setq hide-ifdef-mode-map-before (current-local-map))
(use-local-map (copy-keymap (current-local-map)))
(local-unset-key hide-ifdef-mode-prefix-key)
@@ -410,13 +411,15 @@ that form should be displayed.")
(prog1
(hif-expr)
(if token ; is there still a token?
- (error "Error: unexpected token: %s" 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)
+ token
+ )
(defun hif-expr ()
"Parse and expression of the form
@@ -425,7 +428,8 @@ that form should be displayed.")
(while (eq token 'or)
(hif-nexttoken)
(setq result (list 'or result (hif-term))))
- result))
+ result
+ ))
(defun hif-term ()
"Parse a term of the form
@@ -434,7 +438,8 @@ that form should be displayed.")
(while (eq token 'and)
(hif-nexttoken)
(setq result (list 'and result (hif-factor))))
- result))
+ result
+ ))
(defun hif-factor ()
"Parse a factor of the form
@@ -455,7 +460,7 @@ that form should be displayed.")
((eq token 'hif-defined)
(hif-nexttoken)
(if (not (eq token 'lparen))
- (error "Error: expected \"(\" after \"defined\""))
+ (error "Error: expected \"(\" after \"define\""))
(hif-nexttoken)
(let ((ident token))
(if (memq token '(or and not hif-defined lparen rparen))
@@ -474,6 +479,7 @@ that form should be displayed.")
(hif-nexttoken)
(` (hif-lookup (quote (, ident))))
))
+
))
;;;----------- end of parser -----------------------
@@ -511,7 +517,8 @@ NOT including one on this line."
(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)))
+ (beginning-of-line))
+ )
(defun hif-find-previous-relevant ()
"Position at beginning of previous #ifdef, #ifndef, #else, #endif,
@@ -520,7 +527,9 @@ NOT including one on this line."
(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)))
+ (beginning-of-line)
+ )
+ )
(defun hif-looking-at-ifX () ;; Should eventually see #if
@@ -544,7 +553,8 @@ NOT including one on this line."
((hif-looking-at-endif)
'done)
(t
- (error "Missmatched #ifdef #endif pair"))))
+ (error "Missmatched #ifdef #endif pair"))
+ ))
(defun hif-endif-to-ifdef ()
@@ -561,12 +571,13 @@ NOT including one on this line."
(hif-endif-to-ifdef))
((hif-looking-at-ifX)
'done)
- (t ; never gets here)))
+ (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."
+ With argument, do this that many times."
(interactive "p")
(or arg (setq arg 1))
(if (< arg 0)
@@ -585,7 +596,7 @@ With argument, do this that many times."
(defun backward-ifdef (&optional arg)
"Move point to beginning of the previous ifdef-endif.
-With argument, do this that many times."
+ With argument, do this that many times."
(interactive "p")
(or arg (setq arg 1))
(if (< arg 0)
@@ -599,7 +610,9 @@ With argument, do this that many times."
(if (hif-looking-at-endif)
(hif-endif-to-ifdef)
(goto-char start)
- (error "No previous #ifdef")))))
+ (error "No previous #ifdef")
+ ))))
+
(defun down-ifdef ()
@@ -610,7 +623,8 @@ With argument, do this that many times."
(if (or (hif-looking-at-ifX) (hif-looking-at-else))
()
(goto-char start)
- (error "No following #ifdef"))))
+ (error "No following #ifdef")
+ )))
(defun up-ifdef ()
@@ -623,11 +637,12 @@ With argument, do this that many times."
(if (hif-looking-at-endif)
(hif-endif-to-ifdef))
(if (= start (point))
- (error "No previous #ifdef"))))
+ (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."
+ With argument, do this that many times."
(interactive "p")
(or arg (setq arg 1))
(if (< arg 0)
@@ -638,11 +653,12 @@ With argument, do this that many times."
(if (eolp)
(progn
(beginning-of-line)
- (error "No following #ifdefs, #elses, or #endifs")))))
+ (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."
+ With argument, do this that many times."
(interactive "p")
(or arg (setq arg 1))
(if (< arg 0)
@@ -727,7 +743,8 @@ Point is left unchanged."
;;; 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."
+ "Hide the line containing point. Does nothing if
+hide-ifdef-lines is nil."
(if hide-ifdef-lines
(save-excursion
(goto-char point)
@@ -766,7 +783,8 @@ Point is left unchanged."
;;; possibly-hidden range.
(defun hif-recurse-on (start end)
- "Call `hide-ifdef-guts' after narrowing to end of START line and END line."
+ "Call hide-ifdef-guts after narrowing to end of START line and END
+line."
(save-excursion
(save-restriction
(goto-char start)
@@ -776,7 +794,7 @@ Point is left unchanged."
(defun hif-possibly-hide ()
"Called at #ifX expression, this hides those parts that should be
-hidden, according to judgement of `hide-ifdef-evaluator'."
+hidden, according to judgement of hide-ifdef-evaluator."
; (message "hif-possibly-hide") (sit-for 1)
(let ((test (hif-canonicalize))
(range (hif-find-range)))
@@ -811,7 +829,7 @@ hidden, according to judgement of `hide-ifdef-evaluator'."
(defun hide-ifdef-guts ()
- "Does the work of `hide-ifdefs', except for the work that's pointless
+ "Does the work of hide-ifdefs, except for the work that's pointless
to redo on a recursive entry."
; (message "hide-ifdef-guts")
(save-excursion
@@ -825,8 +843,8 @@ to redo on a recursive entry."
;===%%SF%% exports (Start) ===
(defvar hide-ifdef-initially nil
- "*Non-nil if `hide-ifdefs' should be called when Hide-Ifdef mode
-is first activated.")
+ "*Non-nil if hide-ifdefs should be called when hide-ifdef-mode
+ is first activated.")
(defvar hide-ifdef-hiding nil
"Non-nil if text might be hidden.")
@@ -835,7 +853,7 @@ is first activated.")
"*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.")
+ "Internal variable. Saves the value of buffer-read-only while hiding.")
(defvar hide-ifdef-lines nil
"*Set to t if you don't want to see the #ifX, #else, and #endif lines.")
@@ -848,10 +866,11 @@ is first activated.")
(if hide-ifdef-read-only "ON" "OFF"))
(if hide-ifdef-hiding
(setq buffer-read-only (or hide-ifdef-read-only hif-outside-read-only)))
- (hif-update-mode-line))
+ (hif-update-mode-line)
+ )
(defun hide-ifdef-toggle-outside-read-only ()
- "Replacement for `toggle-read-only' within Hide-Ifdef mode."
+ "Replacement for toggle-read-only within hide-ifdef-mode."
(interactive)
(setq hif-outside-read-only (not hif-outside-read-only))
(message "Read only %s"
@@ -860,7 +879,8 @@ is first activated.")
(or (and hide-ifdef-hiding hide-ifdef-read-only)
hif-outside-read-only)
)
- (hif-update-mode-line))
+ (hif-update-mode-line)
+ )
(defun hide-ifdef-define (var)
@@ -878,7 +898,7 @@ is first activated.")
(defun hide-ifdefs ()
"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
+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.
@@ -895,8 +915,10 @@ Turn off hiding by calling show-ifdef."
(setq hide-ifdef-hiding t)
(hide-ifdef-guts)
(if (or hide-ifdef-read-only hif-outside-read-only)
- (toggle-read-only)) ; make it read only
- (message "Hiding done"))
+ (toggle-read-only) ; make it read only
+ )
+ (message "Hiding done")
+ )
(defun show-ifdefs ()
@@ -907,7 +929,8 @@ Turn off hiding by calling show-ifdef."
(hif-show-all)
(if hif-outside-read-only
(toggle-read-only)) ; make it read only
- (setq hide-ifdef-hiding nil))
+ (setq hide-ifdef-hiding nil)
+ )
(defun hif-find-ifdef-block ()
@@ -919,15 +942,18 @@ Turn off hiding by calling show-ifdef."
(up-ifdef))
(setq top (point))
(hif-ifdef-to-endif)
- (setq max-bottom (1- (point))))
+ (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))))))
+ (hif-find-next-relevant)
+ )
+ (setq bottom (min max-bottom (1- (point))))
+ ))
)
@@ -945,9 +971,11 @@ Turn off hiding by calling show-ifdef."
(progn
(hif-hide-line top)
(hif-hide-line (1+ bottom))))
- (setq hide-ifdef-hiding t))
+ (setq hide-ifdef-hiding t)
+ )
(if (or hide-ifdef-read-only hif-outside-read-only)
- (toggle-read-only)))
+ (toggle-read-only))
+ )
(defun show-ifdef-block ()
@@ -966,7 +994,9 @@ Turn off hiding by calling show-ifdef."
)
; restore read only status since we dont know if all is shown.
- (if old-read-only (toggle-read-only))))
+ (if old-read-only (toggle-read-only))
+ ))
+
;;; defininition alist support
@@ -984,14 +1014,16 @@ Turn off hiding by calling show-ifdef."
(if (car defs)
(setq new-defs (cons (car defs) new-defs)))
(setq defs (cdr defs)))
- new-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)))
+ hide-ifdef-define-alist))
+ )
(defun hide-ifdef-use-define-alist (name)
"Set hide-ifdef-env to the define list specified by NAME."
@@ -1002,6 +1034,8 @@ Turn off hiding by calling show-ifdef."
(mapcar '(lambda (arg) (cons arg t))
(cdr define-list)))
(error "No define list for %s" name))
- (if hide-ifdef-hiding (hide-ifdefs))))
+ (if hide-ifdef-hiding (hide-ifdefs))
+ )
+ )
;===%%SF%% exports (End) ===
diff --git a/lisp/hideif.elc b/lisp/hideif.elc
new file mode 100644
index 00000000000..247a6bffed2
--- /dev/null
+++ b/lisp/hideif.elc
Binary files differ
diff --git a/lisp/progmodes/icon.el b/lisp/icon.el
index c381f812105..718f89d5f91 100644
--- a/lisp/progmodes/icon.el
+++ b/lisp/icon.el
@@ -4,8 +4,8 @@
;; if not permanently installed in your emacs
;; Icon code editing commands for Emacs
-;; Derived from c-mode.el 15-Feb-89 Chris Smith convex!csmith
-;; Copyright (C) 1989 Free Software Foundation, Inc.
+;; from c-mode.el 13-Apr-88 Chris Smith; bugs to convex!csmith
+;; Copyright (C) 1988 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
@@ -77,8 +77,8 @@
This is in addition to icon-continued-statement-offset.")
(defconst icon-auto-newline nil
- "*Non-nil means automatically newline before and after braces
-inserted in Icon code.")
+ "*Non-nil means automatically newline before and after braces,
+and after colons and semicolons, inserted in C code.")
(defconst icon-tab-always-indent t
"*Non-nil means TAB in Icon mode should always reindent the current line,
@@ -107,15 +107,15 @@ Variables controlling indentation style:
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'.
+ 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."
+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)
@@ -143,15 +143,16 @@ with no args, if that value is non-nil."
(setq comment-indent-hook '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.
+;; 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
+ 0 ;Existing comment at bol stays there.
(save-excursion
(skip-chars-backward " \t")
- (max (if (bolp) 0 (1+ (current-column)))
- comment-column))))
+ (max (1+ (current-column)) ;Else indent at comment column
+ comment-column)))) ; except leave at least one space.
(defun electric-icon-brace (arg)
"Insert character and correct line's indentation."
@@ -186,14 +187,14 @@ with no args, if that value is non-nil."
(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
+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."
+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.
@@ -286,18 +287,16 @@ Returns nil if line starts inside a string, t if in a comment."
(goto-char (1+ containing-sexp))
(current-column))
(t
+ ;; Statement level. Is it a continuation or a new statement?
+ ;; Find previous non-comment character.
(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)
@@ -333,40 +332,29 @@ Returns nil if line starts inside a string, t if in a comment."
;; 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.
+ ;; 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-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.
+ ;; here we are
(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)
+ (progn (forward-word -1) (point))
+ (progn (forward-word 1) (point)))
+ '(("do") ("dynamic") ("else") ("initial") ("link")
+ ("local") ("of") ("static") ("then")))
(not (memq ch '(0 ?\; ?\} ?\{ ?\) ?\] ?\" ?\' ?\n))))))
(defun icon-backward-to-noncomment (lim)
@@ -375,25 +363,20 @@ Returns nil if line starts inside a string, t if in a comment."
(skip-chars-backward " \t\n\f" lim)
(setq opoint (point))
(beginning-of-line)
- (if (and (nth 5 (parse-partial-sexp (point) opoint))
+ (if (and (search-forward "#" opoint 'move)
(< lim (point)))
- (search-backward "#")
+ (forward-char -1)
(setq stop t)))))
(defun icon-backward-to-start-of-continued-exp (lim)
(if (memq (preceding-char) '(?\) ?\]))
(forward-sexp -1))
+ (while (icon-is-continued-line)
+ (end-of-line 0))
(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))))
+ (if (<= (point) lim)
+ (goto-char (1+ lim)))
+ (skip-chars-forward " \t"))
(defun icon-is-continued-line ()
(save-excursion
@@ -401,7 +384,7 @@ Returns nil if line starts inside a string, t if in a comment."
(icon-is-continuation-line)))
(defun icon-backward-to-start-of-if (&optional limit)
- "Move to the start of the last \"unbalanced\" if."
+ "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))
@@ -546,4 +529,3 @@ Returns nil if line starts inside a string, t if in a comment."
(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))))))))))
-
diff --git a/lisp/icon.elc b/lisp/icon.elc
new file mode 100644
index 00000000000..cdcea84e8ad
--- /dev/null
+++ b/lisp/icon.elc
Binary files differ
diff --git a/lisp/inc-vers.el b/lisp/inc-vers.el
index 13a4fb17e80..bd23aa8a728 100644
--- a/lisp/inc-vers.el
+++ b/lisp/inc-vers.el
@@ -18,7 +18,18 @@
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-(insert-file-contents "../lisp/version.el")
+;; Find the file version.el in the path for lisp files,
+;; and set version-file.
+(setq version-file nil)
+(setq temp (mapcar '(lambda (dir)
+ (cons dir (file-exists-p (expand-file-name "version.el" dir))))
+ load-path))
+(while temp
+ (and (cdr (car temp)) (null version-file)
+ (setq version-file (expand-file-name "version.el" (car (car temp)))))
+ (setq temp (cdr temp)))
+
+(insert-file-contents version-file)
(re-search-forward "emacs-version \"[^\"]*[0-9]+\"")
(forward-char -1)
@@ -36,7 +47,7 @@
(progn (skip-chars-forward "^\"") (point))))
-(write-region (point-min) (point-max) "../lisp/version.el" nil 'nomsg)
+(write-region (point-min) (point-max) version-file nil 'nomsg)
(erase-buffer)
(set-buffer-modified-p nil)
diff --git a/lisp/indent.el b/lisp/indent.el
new file mode 100644
index 00000000000..903b8f70da7
--- /dev/null
+++ b/lisp/indent.el
@@ -0,0 +1,225 @@
+;; Indentation commands for Emacs
+;; Copyright (C) 1985 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+;Now in loaddefs.el
+;(defvar indent-line-function
+; 'indent-to-left-margin
+; "Function to indent current line.")
+
+(defun indent-according-to-mode ()
+ "Indent line in proper way for current major mode."
+ (interactive)
+ (funcall indent-line-function))
+
+(defun indent-for-tab-command ()
+ "Indent line in proper way for current major mode."
+ (interactive)
+ (if (eq indent-line-function 'indent-to-left-margin)
+ (insert-tab)
+ (funcall indent-line-function)))
+
+(defun insert-tab ()
+ (if abbrev-mode
+ (expand-abbrev))
+ (if indent-tabs-mode
+ (insert ?\t)
+ (indent-to (* tab-width (1+ (/ (current-column) tab-width))))))
+
+(defun indent-rigidly (start end arg)
+ "Indent all lines starting in the region sideways by ARG columns.
+Called from a program, takes three arguments, START, END and ARG."
+ (interactive "r\np")
+ (save-excursion
+ (goto-char end)
+ (setq end (point-marker))
+ (goto-char start)
+ (or (bolp) (forward-line 1))
+ (while (< (point) end)
+ (let ((indent (current-indentation)))
+ (delete-region (point) (progn (skip-chars-forward " \t") (point)))
+ (or (eolp)
+ (indent-to (max 0 (+ indent arg)) 0)))
+ (forward-line 1))
+ (move-marker end nil)))
+
+;; This is the default indent-line-function,
+;; used in Fundamental Mode, Text Mode, etc.
+(defun indent-to-left-margin ()
+ (or (= (current-indentation) left-margin)
+ (let (epos)
+ (save-excursion
+ (beginning-of-line)
+ (delete-region (point)
+ (progn (skip-chars-forward " \t")
+ (point)))
+ (indent-to left-margin)
+ (setq epos (point)))
+ (if (< (point) epos)
+ (goto-char epos)))))
+
+(defvar indent-region-function nil
+ "Function which is short cut to indent each line in region with Tab.
+nil means really call Tab on each line.")
+
+(defun indent-region (start end arg)
+ "Indent each nonblank line in the region.
+With no argument, indent each line with Tab.
+With argument COLUMN, indent each line to that column.
+Called from a program, takes three args: START, END and COLUMN."
+ (interactive "r\nP")
+ (if (null arg)
+ (if indent-region-function
+ (funcall indent-region-function start end)
+ (save-excursion
+ (goto-char end)
+ (setq end (point-marker))
+ (goto-char start)
+ (or (bolp) (forward-line 1))
+ (while (< (point) end)
+ (funcall indent-line-function)
+ (forward-line 1))
+ (move-marker end nil)))
+ (setq arg (prefix-numeric-value arg))
+ (save-excursion
+ (goto-char end)
+ (setq end (point-marker))
+ (goto-char start)
+ (or (bolp) (forward-line 1))
+ (while (< (point) end)
+ (delete-region (point) (progn (skip-chars-forward " \t") (point)))
+ (or (eolp)
+ (indent-to arg 0))
+ (forward-line 1))
+ (move-marker end nil))))
+
+(defun indent-relative-maybe ()
+ "Indent a new line like previous nonblank line."
+ (interactive)
+ (indent-relative t))
+
+(defun indent-relative (&optional unindented-ok)
+ "Space out to under next indent point in previous nonblank line.
+An indent point is a non-whitespace character following whitespace.
+If the previous nonblank line has no indent points beyond
+the column point starts at, tab-to-tab-stop is done instead."
+ (interactive "P")
+ (if abbrev-mode (expand-abbrev))
+ (let ((start-column (current-column))
+ indent)
+ (save-excursion
+ (beginning-of-line)
+ (if (re-search-backward "^[^\n]" nil t)
+ (let ((end (save-excursion (forward-line 1) (point))))
+ (move-to-column start-column)
+ ;; Is start-column inside a tab on this line?
+ (if (> (current-column) start-column)
+ (backward-char 1))
+ (or (looking-at "[ \t]")
+ unindented-ok
+ (skip-chars-forward "^ \t" end))
+ (skip-chars-forward " \t" end)
+ (or (= (point) end) (setq indent (current-column))))))
+ (if indent
+ (let ((opoint (point-marker)))
+ (delete-region (point) (progn (skip-chars-backward " \t") (point)))
+ (indent-to indent 0)
+ (if (> opoint (point))
+ (goto-char opoint))
+ (move-marker opoint nil))
+ (tab-to-tab-stop))))
+
+(defvar tab-stop-list
+ '(8 16 24 32 40 48 56 64 72 80 88 96 104 112 120)
+ "*List of tab stop positions used by tab-to-tab-stops.")
+
+(defvar edit-tab-stops-map nil "Keymap used in edit-tab-stops.")
+(if edit-tab-stops-map
+ nil
+ (setq edit-tab-stops-map (make-sparse-keymap))
+ (define-key edit-tab-stops-map "\C-x\C-s" 'edit-tab-stops-note-changes)
+ (define-key edit-tab-stops-map "\C-c\C-c" 'edit-tab-stops-note-changes))
+
+(defvar edit-tab-stops-buffer nil
+ "Buffer whose tab stops are being edited--in case
+the variable tab-stop-list is local in that buffer.")
+
+(defun edit-tab-stops ()
+ "Edit the tab stops used by tab-to-tab-stop.
+Creates a buffer *Tab Stops* containing text describing the tab stops.
+A colon indicates a column where there is a tab stop.
+You can add or remove colons and then do C-c C-c to make changes take effect."
+ (interactive)
+ (setq edit-tab-stops-buffer (current-buffer))
+ (switch-to-buffer (get-buffer-create "*Tab Stops*"))
+ (use-local-map edit-tab-stops-map)
+ (make-local-variable 'indent-tabs-mode)
+ (setq indent-tabs-mode nil)
+ (overwrite-mode 1)
+ (setq truncate-lines t)
+ (erase-buffer)
+ (let ((tabs tab-stop-list))
+ (while tabs
+ (indent-to (car tabs) 0)
+ (insert ?:)
+ (setq tabs (cdr tabs))))
+ (let ((count 0))
+ (insert ?\n)
+ (while (< count 8)
+ (insert (+ count ?0))
+ (insert " ")
+ (setq count (1+ count)))
+ (insert ?\n)
+ (while (> count 0)
+ (insert "0123456789")
+ (setq count (1- count))))
+ (insert "\nTo install changes, type C-c C-c")
+ (goto-char (point-min)))
+
+(defun edit-tab-stops-note-changes ()
+ "Put edited tab stops into effect."
+ (interactive)
+ (let (tabs)
+ (save-excursion
+ (goto-char 1)
+ (end-of-line)
+ (while (search-backward ":" nil t)
+ (setq tabs (cons (current-column) tabs))))
+ (bury-buffer (prog1 (current-buffer)
+ (switch-to-buffer edit-tab-stops-buffer)))
+ (setq tab-stop-list tabs))
+ (message "Tab stops installed"))
+
+(defun tab-to-tab-stop ()
+ "Insert spaces or tabs to next defined tab-stop column.
+The variable tab-stop-list is a list of columns at which there are tab stops.
+Use \\[edit-tab-stops] to edit them interactively."
+ (interactive)
+ (if abbrev-mode (expand-abbrev))
+ (let ((tabs tab-stop-list))
+ (while (and tabs (>= (current-column) (car tabs)))
+ (setq tabs (cdr tabs)))
+ (if tabs
+ (indent-to (car tabs))
+ (insert ? ))))
+
+(define-key global-map "\t" 'indent-for-tab-command)
+(define-key esc-map "\034" 'indent-region)
+(define-key ctl-x-map "\t" 'indent-rigidly)
+(define-key esc-map "i" 'tab-to-tab-stop)
diff --git a/lisp/indent.elc b/lisp/indent.elc
new file mode 100644
index 00000000000..5593bc2628d
--- /dev/null
+++ b/lisp/indent.elc
Binary files differ
diff --git a/lisp/info.el b/lisp/info.el
new file mode 100644
index 00000000000..45d2b45fe0b
--- /dev/null
+++ b/lisp/info.el
@@ -0,0 +1,708 @@
+;; Info package for Emacs -- could use a "create node" feature.
+;; Copyright (C) 1985, 1986 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+(provide 'info)
+
+(defvar Info-history nil
+ "List of info nodes user has visited.
+Each element of list is a list (FILENAME NODENAME BUFFERPOS).")
+
+(defvar Info-enable-edit nil
+ "Non-nil means the \\[Info-edit] command in Info can edit the current node.")
+
+(defvar 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.")
+
+(defvar Info-directory nil
+ "Default directory for Info documentation files.")
+
+(defvar Info-current-file nil
+ "Info file that Info is now looking at, or nil.")
+
+(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.")
+
+(defun info ()
+ "Enter Info, the documentation browser."
+ (interactive)
+ (if (get-buffer "*info*")
+ (switch-to-buffer "*info*")
+ (Info-directory)))
+
+;; Go to an info node specified as separate filename and nodename.
+;; no-going-back is non-nil if recovering from an error in this function;
+;; it says do not attempt further (recursive) error recovery.
+(defun Info-find-node (filename nodename &optional no-going-back)
+ ;; Convert filename to lower case if not found as specified.
+ ;; Expand it.
+ (if filename
+ (let (temp)
+ (setq filename (substitute-in-file-name filename))
+ (setq temp (expand-file-name filename
+ ;; Use Info's default dir
+ ;; unless the filename starts with `./'.
+ (if (not (string-match "^\\./" filename))
+ Info-directory)))
+ (if (file-exists-p temp)
+ (setq filename temp)
+ (if (file-exists-p (concat temp ".info"))
+ (setq filename (concat temp ".info"))
+ (setq temp (expand-file-name (downcase filename) Info-directory))
+ (if (file-exists-p temp)
+ (setq filename temp)
+ (if (file-exists-p (concat temp ".info"))
+ (setq filename (concat temp ".info"))
+ (error "Info file %s does not exist"
+ (expand-file-name filename Info-directory))))))))
+ ;; Record the node we are leaving.
+ (if (and Info-current-file (not no-going-back))
+ (setq Info-history
+ (cons (list Info-current-file Info-current-node (point))
+ Info-history)))
+ ;; Go into info buffer.
+ (switch-to-buffer "*info*")
+ (or (eq major-mode 'Info-mode)
+ (Info-mode))
+ (widen)
+ (setq Info-current-node 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)
+ (erase-buffer)
+ (insert-file-contents filename t)
+ (set-buffer-modified-p nil)
+ (setq default-directory (file-name-directory filename))
+ ;; 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*"))
+ (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))
+ ;; Search file for a suitable node.
+ ;; 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.
+ (let ((guesspos (point-min))
+ (regexp (concat "Node: *" (regexp-quote nodename) " *[,\t\n\177]")))
+ (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))))
+ (error "No such node: \"%s\"" nodename))))
+ (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))))
+ (error "No such node: %s" nodename)))
+ (Info-select-node)))
+ ;; 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)))
+ (setq Info-history (cdr Info-history))
+ (Info-find-node (nth 0 hist) (nth 1 hist) t)
+ (goto-char (nth 2 hist)))))
+ (goto-char (point-min)))
+
+(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)))
+ (if (> thisfilepos nodepos)
+ (throw 'foo t))
+ (setq lastfilename thisfilename)
+ (setq lastfilepos thisfilepos))
+ (forward-line 1))))
+ (set-buffer (get-buffer "*info*"))
+ (or (equal Info-current-subfile lastfilename)
+ (let ((buffer-read-only nil))
+ (setq buffer-file-name nil)
+ (widen)
+ (erase-buffer)
+ (insert-file-contents lastfilename)
+ (set-buffer-modified-p nil)
+ (setq Info-current-subfile lastfilename)))
+ (goto-char (point-min))
+ (search-forward "\n\^_")
+ (+ (- nodepos lastfilepos) (point))))
+
+;; Select the info node that point is in.
+(defun Info-select-node ()
+ (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)))
+ (if Info-enable-active-nodes (eval active-expression)))))
+
+(defun Info-set-mode-line ()
+ (setq mode-line-buffer-identification
+ (concat
+ "Info: ("
+ (if Info-current-file
+ (file-name-nondirectory Info-current-file)
+ "")
+ ")"
+ (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.
+
+(defun Info-goto-node (nodename)
+ "Go to info node named NAME. Give just NODENAME or (FILENAME)NODENAME."
+ (interactive "sGoto node: ")
+ (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))))
+
+(defvar Info-last-search nil
+ "Default regexp for Info S command to search for.")
+
+(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))
+ (let ((found ()) current
+ (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 err
+ (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)
+ current (car (car 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))
+ (setq Info-history (cons (list ofile onode opoint)
+ Info-history)))))
+
+(defun Info-extract-pointer (name &optional errorname)
+ (save-excursion
+ (goto-char (point-min))
+ (forward-line 1)
+ (if (re-search-backward (concat name ":") nil t)
+ nil
+ (error (concat "Node has no " (capitalize (or errorname name)))))
+ (goto-char (match-end 0))
+ (Info-following-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 ()
+ "Go to the next node of this node."
+ (interactive)
+ (Info-goto-node (Info-extract-pointer "next")))
+
+(defun Info-prev ()
+ "Go to the previous node of this node."
+ (interactive)
+ (Info-goto-node (Info-extract-pointer "prev[ious]*" "previous")))
+
+(defun Info-up ()
+ "Go to the superior node of this node."
+ (interactive)
+ (Info-goto-node (Info-extract-pointer "up")))
+
+(defun Info-last ()
+ "Go back to the last node visited."
+ (interactive)
+ (or Info-history
+ (error "This is the first Info node you looked at"))
+ (let (filename nodename opoint)
+ (setq filename (car (car Info-history)))
+ (setq nodename (car (cdr (car Info-history))))
+ (setq opoint (car (cdr (cdr (car Info-history)))))
+ (setq Info-history (cdr Info-history))
+ (Info-find-node filename nodename)
+ (setq Info-history (cdr Info-history))
+ (goto-char opoint)))
+
+(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 str i)
+ (save-excursion
+ (goto-char (point-min))
+ (while (re-search-forward "\\*note[ \n\t]*\\([^:]*\\):" nil t)
+ (setq str (buffer-substring
+ (match-beginning 1)
+ (1- (point))))
+ (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)))
+ (setq completions
+ (cons (cons str nil)
+ completions))))
+ (if completions
+ (list (completing-read "Follow reference named: " completions nil t))
+ (error "No cross-references in this node"))))
+ (let (target beg i (str (concat "\\*note " footnotename)))
+ (while (setq i (string-match " " str i))
+ (setq str (concat (substring str 0 i) "[ \t\n]+" (substring str (1+ i))))
+ (setq i (+ i 6)))
+ (save-excursion
+ (goto-char (point-min))
+ (or (re-search-forward str nil t)
+ (error "No cross-reference named %s" footnotename))
+ (goto-char (+ (match-beginning 0) 5))
+ (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)))
+
+(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-item-sequence (list)
+ (while list
+ (Info-menu-item (car list))
+ (setq list (cdr list))))
+
+(defun Info-menu (menu-item)
+ "Go to node for menu item named (or abbreviated) NAME."
+ (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))
+ (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)))
+ ;; we rely on the bug (which RMS won't change for his own reasons)
+ ;; 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))))
+ (Info-goto-node (Info-extract-menu-item menu-item)))
+
+(defun Info-extract-menu-item (menu-item)
+ (save-excursion
+ (goto-char (point-min))
+ (or (search-forward "\n* menu:" nil t)
+ (error "No menu in this node"))
+ (or (search-forward (concat "\n* " menu-item ":") nil t)
+ (search-forward (concat "\n* " menu-item) nil t)
+ (error "No such item in menu"))
+ (beginning-of-line)
+ (forward-char 2)
+ (Info-extract-menu-node-name)))
+
+(defun Info-extract-menu-counting (count)
+ (save-excursion
+ (goto-char (point-min))
+ (or (search-forward "\n* menu:" nil t)
+ (error "No menu in this node"))
+ (or (search-forward "\n* " nil t count)
+ (error "Too few items in menu"))
+ (Info-extract-menu-node-name)))
+
+(defun Info-first-menu-item ()
+ "Go to the node of the first menu item."
+ (interactive)
+ (Info-goto-node (Info-extract-menu-counting 1)))
+
+(defun Info-second-menu-item ()
+ "Go to the node of the second menu item."
+ (interactive)
+ (Info-goto-node (Info-extract-menu-counting 2)))
+
+(defun Info-third-menu-item ()
+ "Go to the node of the third menu item."
+ (interactive)
+ (Info-goto-node (Info-extract-menu-counting 3)))
+
+(defun Info-fourth-menu-item ()
+ "Go to the node of the fourth menu item."
+ (interactive)
+ (Info-goto-node (Info-extract-menu-counting 4)))
+
+(defun Info-fifth-menu-item ()
+ "Go to the node of the fifth menu item."
+ (interactive)
+ (Info-goto-node (Info-extract-menu-counting 5)))
+
+(defun Info-exit ()
+ "Exit Info by selecting some other buffer."
+ (interactive)
+ (switch-to-buffer (prog1 (other-buffer (current-buffer))
+ (bury-buffer (current-buffer)))))
+
+(defun Info-undefined ()
+ "Make command be undefined in Info."
+ (interactive)
+ (ding))
+
+(defun Info-help ()
+ "Enter the Info tutorial."
+ (interactive)
+ (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 (ch 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"))
+ (if (/= ?\ (setq ch (read-char)))
+ (progn (setq unread-command-char ch) nil)
+ flag))
+ (scroll-up)))))
+
+(defvar Info-mode-map nil
+ "Keymap containing Info commands.")
+(if Info-mode-map
+ nil
+ (setq Info-mode-map (make-keymap))
+ (suppress-keymap Info-mode-map)
+ (define-key Info-mode-map "." 'beginning-of-buffer)
+ (define-key Info-mode-map " " 'scroll-up)
+ (define-key Info-mode-map "1" 'Info-first-menu-item)
+ (define-key Info-mode-map "2" 'Info-second-menu-item)
+ (define-key Info-mode-map "3" 'Info-third-menu-item)
+ (define-key Info-mode-map "4" 'Info-fourth-menu-item)
+ (define-key Info-mode-map "5" 'Info-fifth-menu-item)
+ (define-key Info-mode-map "6" 'undefined)
+ (define-key Info-mode-map "7" 'undefined)
+ (define-key Info-mode-map "8" 'undefined)
+ (define-key Info-mode-map "9" 'undefined)
+ (define-key Info-mode-map "0" 'undefined)
+ (define-key Info-mode-map "?" 'Info-summary)
+ (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 "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 "s" 'Info-search)
+ (define-key Info-mode-map "u" 'Info-up)
+ (define-key Info-mode-map "\177" 'scroll-down))
+
+(put 'Info-mode 'mode-class 'special)
+(defun Info-mode ()
+ "Info mode provides commands 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.
+
+Selecting other nodes:
+n Move to the \"next\" node of this node.
+p Move to the \"previous\" node of this node.
+u Move \"up\" from this node.
+m Pick menu item specified by name (or abbreviation).
+ Picking a menu item causes another node to be selected.
+f Follow a cross reference. Reads name of reference.
+l Move to the last node you were at.
+
+Moving within a node:
+Space scroll forward a page. DEL scroll backward.
+b Go to beginning of node.
+
+Advanced commands:
+q Quit Info: reselect previously selected buffer.
+e Edit contents of selected node.
+1 Pick first item in node's menu.
+2, 3, 4, 5 Pick second ... fifth item in node's menu.
+g Move to node specified by name.
+ You may include a filename as well, as (FILENAME)NODENAME.
+s Search through this Info file for specified regexp,
+ and select the node in which the next occurrence is found."
+ (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)
+ (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-history)
+ (Info-set-mode-line))
+
+(defvar Info-edit-map nil
+ "Local keymap used within `e' command of Info.")
+(if Info-edit-map
+ nil
+ (setq Info-edit-map (copy-keymap text-mode-map))
+ (define-key Info-edit-map "\C-c\C-c" 'Info-cease-edit))
+
+(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 'mode-line-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 "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")))
diff --git a/lisp/info.elc b/lisp/info.elc
new file mode 100644
index 00000000000..86151dd1d43
--- /dev/null
+++ b/lisp/info.elc
Binary files differ
diff --git a/lisp/informat.el b/lisp/informat.el
new file mode 100644
index 00000000000..95d87441cbd
--- /dev/null
+++ b/lisp/informat.el
@@ -0,0 +1,411 @@
+;; Info support functions package for Emacs
+;; Copyright (C) 1986 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+(require 'info)
+
+(defun Info-tagify ()
+ "Create or update Info-file tag table in current buffer."
+ (interactive)
+ ;; Save and restore point and restrictions.
+ ;; save-restrictions would not work
+ ;; because it records the old max relative to the end.
+ ;; We record it relative to the beginning.
+ (let ((omin (point-min))
+ (omax (point-max))
+ (nomax (= (point-max) (1+ (buffer-size))))
+ (opoint (point)))
+ (unwind-protect
+ (progn
+ (widen)
+ (goto-char (point-min))
+ (if (search-forward "\^_\nIndirect:\n" nil t)
+ (message "Cannot tagify split info file")
+ (let ((regexp "Node:[ \t]*\\([^,\n\t]\\)*[,\t\n]")
+ (case-fold-search t)
+ list)
+ (while (search-forward "\n\^_" nil t)
+ (forward-line 1)
+ (let ((beg (point)))
+ (forward-line 1)
+ (if (re-search-backward regexp beg t)
+ (setq list
+ (cons (list (buffer-substring
+ (match-beginning 1)
+ (match-end 1))
+ beg)
+ list)))))
+ (goto-char (point-max))
+ (forward-line -8)
+ (let ((buffer-read-only nil))
+ (if (search-forward "\^_\nEnd tag table\n" nil t)
+ (let ((end (point)))
+ (search-backward "\nTag table:\n")
+ (beginning-of-line)
+ (delete-region (point) end)))
+ (goto-char (point-max))
+ (insert "\^_\f\nTag table:\n")
+ (move-marker Info-tag-table-marker (point))
+ (setq list (nreverse list))
+ (while list
+ (insert "Node: " (car (car list)) ?\177)
+ (princ (car (cdr (car list))) (current-buffer))
+ (insert ?\n)
+ (setq list (cdr list)))
+ (insert "\^_\nEnd tag table\n")))))
+ (goto-char opoint)
+ (narrow-to-region omin (if nomax (1+ (buffer-size))
+ (min omax (point-max)))))))
+
+(defun Info-split ()
+ "Split an info file into an indirect file plus bounded-size subfiles.
+Each subfile will be up to 50000 characters plus one node.
+
+To use this command, first visit a large Info file that has a tag table.
+The buffer is modified into a (small) indirect info file
+which should be saved in place of the original visited file.
+
+The subfiles are written in the same directory the original file is in,
+with names generated by appending `-' and a number to the original file name.
+
+The indirect file still functions as an Info file, but it contains
+just the tag table and a directory of subfiles."
+ (interactive)
+ (if (< (buffer-size) 70000)
+ (error "This is too small to be worth splitting"))
+ (goto-char (point-min))
+ (search-forward "\^_")
+ (forward-char -1)
+ (let ((start (point))
+ (chars-deleted 0)
+ subfiles
+ (subfile-number 1)
+ (case-fold-search t)
+ (filename (file-name-sans-versions buffer-file-name)))
+ (goto-char (point-max))
+ (forward-line -8)
+ (setq buffer-read-only nil)
+ (or (search-forward "\^_\nEnd tag table\n" nil t)
+ (error "Tag table required; use M-x Info-tagify"))
+ (search-backward "\nTag table:\n")
+ (if (looking-at "\nTag table:\n\^_")
+ (error "Tag table is just a skeleton; use M-x Info-tagify"))
+ (beginning-of-line)
+ (forward-char 1)
+ (save-restriction
+ (narrow-to-region (point-min) (point))
+ (goto-char (point-min))
+ (while (< (1+ (point)) (point-max))
+ (goto-char (min (+ (point) 50000) (point-max)))
+ (search-forward "\^_" nil 'move)
+ (setq subfiles
+ (cons (list (+ start chars-deleted)
+ (concat (file-name-nondirectory filename)
+ (format "-%d" subfile-number)))
+ subfiles))
+ ;; Put a newline at end of split file, to make Unix happier.
+ (insert "\n")
+ (write-region (point-min) (point)
+ (concat filename (format "-%d" subfile-number)))
+ (delete-region (1- (point)) (point))
+ ;; Back up over the final ^_.
+ (forward-char -1)
+ (setq chars-deleted (+ chars-deleted (- (point) start)))
+ (delete-region start (point))
+ (setq subfile-number (1+ subfile-number))))
+ (while subfiles
+ (goto-char start)
+ (insert (nth 1 (car subfiles))
+ (format ": %d" (car (car subfiles)))
+ "\n")
+ (setq subfiles (cdr subfiles)))
+ (goto-char start)
+ (insert "\^_\nIndirect:\n")
+ (search-forward "\nTag Table:\n")
+ (insert "(Indirect)\n")))
+
+(defun Info-validate ()
+ "Check current buffer for validity as an Info file.
+Check that every node pointer points to an existing node."
+ (interactive)
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (if (search-forward "\nTag table:\n(Indirect)\n" nil t)
+ (error "Don't yet know how to validate indirect info files: \"%s\""
+ (buffer-name (current-buffer))))
+ (goto-char (point-min))
+ (let ((allnodes '(("*")))
+ (regexp "Node:[ \t]*\\([^,\n\t]*\\)[,\t\n]")
+ (case-fold-search t)
+ (tags-losing nil)
+ (lossages ()))
+ (while (search-forward "\n\^_" nil t)
+ (forward-line 1)
+ (let ((beg (point)))
+ (forward-line 1)
+ (if (re-search-backward regexp beg t)
+ (let ((name (downcase
+ (buffer-substring
+ (match-beginning 1)
+ (progn
+ (goto-char (match-end 1))
+ (skip-chars-backward " \t")
+ (point))))))
+ (if (assoc name allnodes)
+ (setq lossages
+ (cons (list name "Duplicate node-name" nil)
+ lossages))
+ (setq allnodes
+ (cons (list name
+ (progn
+ (end-of-line)
+ (and (re-search-backward
+ "prev[ious]*:" beg t)
+ (progn
+ (goto-char (match-end 0))
+ (downcase
+ (Info-following-node-name)))))
+ beg)
+ allnodes)))))))
+ (goto-char (point-min))
+ (while (search-forward "\n\^_" nil t)
+ (forward-line 1)
+ (let ((beg (point))
+ thisnode next)
+ (forward-line 1)
+ (if (re-search-backward regexp beg t)
+ (save-restriction
+ (search-forward "\n\^_" nil 'move)
+ (narrow-to-region beg (point))
+ (setq thisnode (downcase
+ (buffer-substring
+ (match-beginning 1)
+ (progn
+ (goto-char (match-end 1))
+ (skip-chars-backward " \t")
+ (point)))))
+ (end-of-line)
+ (and (search-backward "next:" nil t)
+ (setq next (Info-validate-node-name "invalid Next"))
+ (assoc next allnodes)
+ (if (equal (car (cdr (assoc next allnodes)))
+ thisnode)
+ ;; allow multiple `next' pointers to one node
+ (let ((tem lossages))
+ (while tem
+ (if (and (equal (car (cdr (car tem)))
+ "should have Previous")
+ (equal (car (car tem))
+ next))
+ (setq lossages (delq (car tem) lossages)))
+ (setq tem (cdr tem))))
+ (setq lossages
+ (cons (list next
+ "should have Previous"
+ thisnode)
+ lossages))))
+ (end-of-line)
+ (if (re-search-backward "prev[ious]*:" nil t)
+ (Info-validate-node-name "invalid Previous"))
+ (end-of-line)
+ (if (search-backward "up:" nil t)
+ (Info-validate-node-name "invalid Up"))
+ (if (re-search-forward "\n* Menu:" nil t)
+ (while (re-search-forward "\n\\* " nil t)
+ (Info-validate-node-name
+ (concat "invalid menu item "
+ (buffer-substring (point)
+ (save-excursion
+ (skip-chars-forward "^:")
+ (point))))
+ (Info-extract-menu-node-name))))
+ (goto-char (point-min))
+ (while (re-search-forward "\\*note[ \n]*[^:\t]*:" nil t)
+ (goto-char (+ (match-beginning 0) 5))
+ (skip-chars-forward " \n")
+ (Info-validate-node-name
+ (concat "invalid reference "
+ (buffer-substring (point)
+ (save-excursion
+ (skip-chars-forward "^:")
+ (point))))
+ (Info-extract-menu-node-name "Bad format cross-reference")))))))
+ (setq tags-losing (not (Info-validate-tags-table)))
+ (if (or lossages tags-losing)
+ (with-output-to-temp-buffer " *problems in info file*"
+ (while lossages
+ (princ "In node \"")
+ (princ (car (car lossages)))
+ (princ "\", ")
+ (let ((tem (nth 1 (car lossages))))
+ (cond ((string-match "\n" tem)
+ (princ (substring tem 0 (match-beginning 0)))
+ (princ "..."))
+ (t
+ (princ tem))))
+ (if (nth 2 (car lossages))
+ (progn
+ (princ ": ")
+ (let ((tem (nth 2 (car lossages))))
+ (cond ((string-match "\n" tem)
+ (princ (substring tem 0 (match-beginning 0)))
+ (princ "..."))
+ (t
+ (princ tem))))))
+ (terpri)
+ (setq lossages (cdr lossages)))
+ (if tags-losing (princ "\nTags table must be recomputed\n")))
+ ;; Here if info file is valid.
+ ;; If we already made a list of problems, clear it out.
+ (save-excursion
+ (if (get-buffer " *problems in info file*")
+ (progn
+ (set-buffer " *problems in info file*")
+ (kill-buffer (current-buffer)))))
+ (message "File appears valid"))))))
+
+(defun Info-validate-node-name (kind &optional name)
+ (if name
+ nil
+ (goto-char (match-end 0))
+ (skip-chars-forward " \t")
+ (if (= (following-char) ?\()
+ nil
+ (setq name
+ (buffer-substring
+ (point)
+ (progn
+ (skip-chars-forward "^,\t\n")
+ (skip-chars-backward " ")
+ (point))))))
+ (if (null name)
+ nil
+ (setq name (downcase name))
+ (or (and (> (length name) 0) (= (aref name 0) ?\())
+ (assoc name allnodes)
+ (setq lossages
+ (cons (list thisnode kind name) lossages))))
+ name)
+
+(defun Info-validate-tags-table ()
+ (goto-char (point-min))
+ (if (not (search-forward "\^_\nEnd tag table\n" nil t))
+ t
+ (not (catch 'losing
+ (let* ((end (match-beginning 0))
+ (start (progn (search-backward "\nTag table:\n")
+ (1- (match-end 0))))
+ tem)
+ (setq tem allnodes)
+ (while tem
+ (goto-char start)
+ (or (equal (car (car tem)) "*")
+ (search-forward (concat "Node: "
+ (car (car tem))
+ "\177")
+ end t)
+ (throw 'losing 'x))
+ (setq tem (cdr tem)))
+ (goto-char (1+ start))
+ (while (looking-at ".*Node: \\(.*\\)\177\\([0-9]+\\)$")
+ (setq tem (downcase (buffer-substring
+ (match-beginning 1)
+ (match-end 1))))
+ (setq tem (assoc tem allnodes))
+ (if (or (not tem)
+ (< 1000 (progn
+ (goto-char (match-beginning 2))
+ (setq tem (- (car (cdr (cdr tem)))
+ (read (current-buffer))))
+ (if (> tem 0) tem (- tem)))))
+ (throw 'losing 'y)))
+ (forward-line 1))
+ (or (looking-at "End tag table\n")
+ (throw 'losing 'z))
+ nil))))
+
+(defun batch-info-validate ()
+ "Runs Info-validate on the files remaining on the command line.
+Must be used only with -batch, and kills emacs on completion.
+Each file will be processed even if an error occurred previously.
+For example, invoke \"emacs -batch -f batch-info-validate $info/ ~/*.info\""
+ (if (not noninteractive)
+ (error "batch-info-validate may only be used -batch."))
+ (let ((version-control t)
+ (auto-save-default nil)
+ (find-file-run-dired nil)
+ (kept-old-versions 259259)
+ (kept-new-versions 259259))
+ (let ((error 0)
+ file
+ (files ()))
+ (while command-line-args-left
+ (setq file (expand-file-name (car command-line-args-left)))
+ (cond ((not (file-exists-p file))
+ (message ">> %s does not exist!" file)
+ (setq error 1
+ command-line-args-left (cdr command-line-args-left)))
+ ((file-directory-p file)
+ (setq command-line-args-left (nconc (directory-files file)
+ (cdr command-line-args-left))))
+ (t
+ (setq files (cons file files)
+ command-line-args-left (cdr command-line-args-left)))))
+ (while files
+ (setq file (car files)
+ files (cdr files))
+ (let ((lose nil))
+ (condition-case err
+ (progn
+ (if buffer-file-name (kill-buffer (current-buffer)))
+ (find-file file)
+ (buffer-flush-undo (current-buffer))
+ (set-buffer-modified-p nil)
+ (fundamental-mode)
+ (let ((case-fold-search nil))
+ (goto-char (point-max))
+ (cond ((search-backward "\n\^_\^L\nTag table:\n" nil t)
+ (message "%s already tagified" file))
+ ((< (point-max) 30000)
+ (message "%s too small to bother tagifying" file))
+ (t
+ (message "Tagifying %s..." file)
+ (Info-tagify)
+ (message "Tagifying %s...done" file))))
+ (let ((loss-name " *problems in info file*"))
+ (message "Checking validity of info file %s..." file)
+ (if (get-buffer loss-name)
+ (kill-buffer loss-name))
+ (Info-validate)
+ (if (not (get-buffer loss-name))
+ nil ;(message "Checking validity of info file %s... OK" file)
+ (message "----------------------------------------------------------------------")
+ (message ">> PROBLEMS IN INFO FILE %s" file)
+ (save-excursion
+ (set-buffer loss-name)
+ (princ (buffer-substring (point-min) (point-max))))
+ (message "----------------------------------------------------------------------")
+ (setq error 1 lose t)))
+ (if (and (buffer-modified-p)
+ (not lose))
+ (progn (message "Saving modified %s" file)
+ (save-buffer))))
+ (error (message ">> Error: %s" (prin1-to-string err))))))
+ (kill-emacs error))))
diff --git a/lisp/informat.elc b/lisp/informat.elc
new file mode 100644
index 00000000000..e0e07adb4b0
--- /dev/null
+++ b/lisp/informat.elc
Binary files differ
diff --git a/lisp/isearch.el b/lisp/isearch.el
new file mode 100644
index 00000000000..b0ebccf05b2
--- /dev/null
+++ b/lisp/isearch.el
@@ -0,0 +1,385 @@
+;; Incremental search
+;; Copyright (C) 1985, 1986 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+; in loaddefs.el
+;(defvar search-last-string ""
+; "Last string search for by a search command.
+;This does not include direct calls to the primitive search functions,
+;and does not include searches that are aborted.")
+;(defvar search-last-regexp ""
+; "Last string searched for by a regexp search command.
+;This does not include direct calls to the primitive search functions,
+;and does not include searches that are aborted.")
+;
+;(defconst search-repeat-char ?\C-s
+; "Character to repeat incremental search forwards.")
+;(defconst search-reverse-char ?\C-r
+; "Character to repeat incremental search backwards.")
+;(defconst search-exit-char ?\e
+; "Character to exit incremental search.")
+;(defconst search-delete-char ?\177
+; "Character to delete from incremental search string.")
+;(defconst search-quote-char ?\C-q
+; "Character to quote special characters for incremental search.")
+;(defconst search-yank-word-char ?\C-w
+; "Character to pull next word from buffer into search string.")
+;(defconst search-yank-line-char ?\C-y
+; "Character to pull rest of line from buffer into search string.")
+;(defconst search-exit-option t
+; "Non-nil means random control characters terminate incremental search.")
+;
+;(defvar search-slow-window-lines 1
+; "*Number of lines in slow search display windows.")
+;(defconst search-slow-speed 1200
+; "*Highest terminal speed at which to use \"slow\" style incremental search.
+;This is the style where a one-line window is created to show the line
+;that the search has reached.")
+
+;; This function does all the work of incremental search.
+;; The functions attached to ^R and ^S are trivial,
+;; merely calling this one, but they are always loaded by default
+;; whereas this file can optionally be autoloadable.
+;; This is the only entry point in this file.
+
+(defun isearch (forward &optional regexp)
+ (let ((search-string "")
+ (search-message "")
+ (cmds nil)
+ (success t)
+ (wrapped nil)
+ (barrier (point))
+ adjusted
+ (invalid-regexp nil)
+ (slow-terminal-mode (and (<= (baud-rate) search-slow-speed)
+ (> (window-height)
+ (* 4 search-slow-window-lines))))
+ (other-end nil) ;Start of last match if fwd, end if backwd.
+ (small-window nil) ;if t, using a small window
+ (found-point nil) ;to restore point from a small window
+ ;; This is the window-start value found by the search.
+ (found-start nil)
+ (opoint (point))
+ (inhibit-quit t)) ;Prevent ^G from quitting immediately.
+ (isearch-push-state)
+ (save-window-excursion
+ (catch 'search-done
+ (while t
+ (or (>= unread-command-char 0)
+ (progn
+ (or (input-pending-p)
+ (isearch-message))
+ (if (and slow-terminal-mode
+ (not (or small-window (pos-visible-in-window-p))))
+ (progn
+ (setq small-window t)
+ (setq found-point (point))
+ (move-to-window-line 0)
+ (let ((window-min-height 1))
+ (split-window nil (if (< search-slow-window-lines 0)
+ (1+ (- search-slow-window-lines))
+ (- (window-height)
+ (1+ search-slow-window-lines)))))
+ (if (< search-slow-window-lines 0)
+ (progn (vertical-motion (- 1 search-slow-window-lines))
+ (set-window-start (next-window) (point))
+ (set-window-hscroll (next-window)
+ (window-hscroll))
+ (set-window-hscroll (selected-window) 0))
+ (other-window 1))
+ (goto-char found-point)))))
+ (let ((char (if quit-flag
+ ?\C-g
+ (read-char))))
+ (setq quit-flag nil adjusted nil)
+ ;; Meta character means exit search.
+ (cond ((and (>= char 128)
+ search-exit-option)
+ (setq unread-command-char char)
+ (throw 'search-done t))
+ ((eq char search-exit-char)
+ ;; Esc means exit search normally.
+ ;; Except, if first thing typed, it means do nonincremental
+ (if (= 0 (length search-string))
+ (nonincremental-search forward regexp))
+ (throw 'search-done t))
+ ((= char ?\C-g)
+ ;; ^G means the user tried to quit.
+ (ding)
+ (discard-input)
+ (if success
+ ;; If search is successful, move back to starting point
+ ;; and really do quit.
+ (progn (goto-char opoint)
+ (signal 'quit nil))
+ ;; If search is failing, rub out until it is once more
+ ;; successful.
+ (while (not success) (isearch-pop))))
+ ((or (eq char search-repeat-char)
+ (eq char search-reverse-char))
+ (if (eq forward (eq char search-repeat-char))
+ ;; C-s in forward or C-r in reverse.
+ (if (equal search-string "")
+ ;; If search string is empty, use last one.
+ (setq search-string
+ (if regexp
+ search-last-regexp search-last-string)
+ search-message
+ (mapconcat 'text-char-description
+ search-string ""))
+ ;; If already have what to search for, repeat it.
+ (or success
+ (progn (goto-char (if forward (point-min) (point-max)))
+ (setq wrapped t))))
+ ;; C-s in reverse or C-r in forward, change direction.
+ (setq forward (not forward)))
+ (setq barrier (point)) ; For subsequent \| if regexp.
+ (setq success t)
+ (or (equal search-string "")
+ (isearch-search))
+ (isearch-push-state))
+ ((= char search-delete-char)
+ ;; Rubout means discard last input item and move point
+ ;; back. If buffer is empty, just beep.
+ (if (null (cdr cmds))
+ (ding)
+ (isearch-pop)))
+ (t
+ (cond ((or (eq char search-yank-word-char)
+ (eq char search-yank-line-char))
+ ;; ^W means gobble next word from buffer.
+ ;; ^Y means gobble rest of line from buffer.
+ (let ((word (save-excursion
+ (and (not forward) other-end
+ (goto-char other-end))
+ (buffer-substring
+ (point)
+ (save-excursion
+ (if (eq char search-yank-line-char)
+ (end-of-line)
+ (forward-word 1))
+ (point))))))
+ (if regexp
+ (setq word (regexp-quote word)))
+ (setq search-string (concat search-string word)
+ search-message
+ (concat search-message
+ (mapconcat 'text-char-description
+ word "")))))
+ ;; Any other control char =>
+ ;; unread it and exit the search normally.
+ ((and search-exit-option
+ (/= char search-quote-char)
+ (or (= char ?\177)
+ (and (< char ? ) (/= char ?\t) (/= char ?\r))))
+ (setq unread-command-char char)
+ (throw 'search-done t))
+ (t
+ ;; Any other character => add it to the
+ ;; search string and search.
+ (cond ((= char search-quote-char)
+ (setq char (read-quoted-char
+ (isearch-message t))))
+ ((= char ?\r)
+ ;; unix braindeath
+ (setq char ?\n)))
+ (setq search-string (concat search-string
+ (char-to-string char))
+ search-message (concat search-message
+ (text-char-description char)))))
+ (if (and (not success)
+ ;; unsuccessful regexp search may become
+ ;; successful by addition of characters which
+ ;; make search-string valid
+ (not regexp))
+ nil
+ ;; If a regexp search may have been made more
+ ;; liberal, retreat the search start.
+ ;; Go back to place last successful search started
+ ;; or to the last ^S/^R (barrier), whichever is nearer.
+ (and regexp success cmds
+ (cond ((and (memq char '(?* ??))
+ ;; Don't treat *, ? as special
+ ;; within [] or after \.
+ (not (nth 6 (car cmds))))
+ (setq adjusted t)
+ ;; This used to use element 2
+ ;; in a reverse search, but it seems that 5
+ ;; (which is the end of the old match)
+ ;; is better in that case too.
+ (let ((cs (nth 5 ; old other-end.
+ (car (cdr cmds)))))
+ ;; (car cmds) is after last search;
+ ;; (car (cdr cmds)) is from before it.
+ (setq cs (or cs barrier))
+ (goto-char
+ (if forward
+ (max cs barrier)
+ (min cs barrier)))))
+ ((eq char ?\|)
+ (setq adjusted t)
+ (goto-char barrier))))
+ ;; In reverse regexp search, adding a character at
+ ;; the end may cause zero or many more chars to be
+ ;; matched, in the string following point.
+ ;; Allow all those possibiities without moving point as
+ ;; long as the match does not extend past search origin.
+ (if (and regexp (not forward) (not adjusted)
+ (condition-case ()
+ (looking-at search-string)
+ (error nil))
+ (<= (match-end 0) (min opoint barrier)))
+ (setq success t invalid-regexp nil
+ other-end (match-end 0))
+ ;; Not regexp, not reverse, or no match at point.
+ (if (and other-end (not adjusted))
+ (goto-char (if forward other-end
+ (min opoint barrier (1+ other-end)))))
+ (isearch-search)))
+ (isearch-push-state))))))
+ (setq found-start (window-start (selected-window)))
+ (setq found-point (point)))
+ (if (> (length search-string) 0)
+ (if regexp
+ (setq search-last-regexp search-string)
+ (setq search-last-string search-string)))
+ ;; If we displayed a single-line window, set point in this window.
+ (if small-window
+ (goto-char found-point))
+ ;; If there was movement, mark the starting position.
+ ;; Maybe should test difference between and set mark iff > threshold.
+ (if (/= (point) opoint)
+ (push-mark opoint)
+ (message ""))
+ (or small-window
+ ;; Exiting the save-window-excursion clobbers this; restore it.
+ (set-window-start (selected-window) found-start t))))
+
+(defun isearch-message (&optional c-q-hack ellipsis)
+ ;; If about to search, and previous search regexp was invalid,
+ ;; check that it still is. If it is valid now,
+ ;; let the message we display while searching say that it is valid.
+ (and invalid-regexp ellipsis
+ (condition-case ()
+ (progn (re-search-forward search-string (point) t)
+ (setq invalid-regexp nil))
+ (error nil)))
+ ;; If currently failing, display no ellipsis.
+ (or success (setq ellipsis nil))
+ (let ((m (concat (if success "" "failing ")
+ (if wrapped "wrapped ")
+ (if regexp "regexp " "")
+ "I-search"
+ (if forward ": " " backward: ")
+ search-message
+ (if c-q-hack "^Q" "")
+ (if invalid-regexp
+ (concat " [" invalid-regexp "]")
+ ""))))
+ (aset m 0 (upcase (aref m 0)))
+ (let ((cursor-in-echo-area ellipsis))
+ (if c-q-hack m (message "%s" m)))))
+
+(defun isearch-pop ()
+ (setq cmds (cdr cmds))
+ (let ((cmd (car cmds)))
+ (setq search-string (car cmd)
+ search-message (car (cdr cmd))
+ success (nth 3 cmd)
+ forward (nth 4 cmd)
+ other-end (nth 5 cmd)
+ invalid-regexp (nth 6 cmd)
+ wrapped (nth 7 cmd)
+ barrier (nth 8 cmd))
+ (goto-char (car (cdr (cdr cmd))))))
+
+(defun isearch-push-state ()
+ (setq cmds (cons (list search-string search-message (point)
+ success forward other-end invalid-regexp
+ wrapped barrier)
+ cmds)))
+
+(defun isearch-search ()
+ (isearch-message nil t)
+ (condition-case lossage
+ (let ((inhibit-quit nil))
+ (if regexp (setq invalid-regexp nil))
+ (setq success
+ (funcall
+ (if regexp
+ (if forward 're-search-forward 're-search-backward)
+ (if forward 'search-forward 'search-backward))
+ search-string nil t))
+ (if success
+ (setq other-end
+ (if forward (match-beginning 0) (match-end 0)))))
+ (quit (setq unread-command-char ?\C-g)
+ (setq success nil))
+ (invalid-regexp (setq invalid-regexp (car (cdr lossage)))
+ (if (string-match "\\`Premature \\|\\`Unmatched \\|\\`Invalid "
+ invalid-regexp)
+ (setq invalid-regexp "incomplete input"))))
+ (if success
+ nil
+ ;; Ding if failed this time after succeeding last time.
+ (and (nth 3 (car cmds))
+ (ding))
+ (goto-char (nth 2 (car cmds)))))
+
+;; This is called from incremental-search
+;; if the first input character is the exit character.
+;; The interactive-arg-reader uses free variables `forward' and `regexp'
+;; which are bound by `incremental-search'.
+
+;; We store the search string in `search-string'
+;; which has been bound already by `incremental-search'
+;; so that, when we exit, it is copied into `search-last-string'.
+
+(defun nonincremental-search (forward regexp)
+ (let (message char function string inhibit-quit)
+ (let ((cursor-in-echo-area t))
+ ;; Prompt assuming not word search,
+ (setq message (if regexp
+ (if forward "Regexp search: "
+ "Regexp search backward: ")
+ (if forward "Search: " "Search backward: ")))
+ (message "%s" message)
+ ;; Read 1 char and switch to word search if it is ^W.
+ (setq char (read-char)))
+ (if (eq char search-yank-word-char)
+ (setq message (if forward "Word search: " "Word search backward: "))
+ ;; Otherwise let that 1 char be part of the search string.
+ (setq unread-command-char char))
+ (setq function
+ (if (eq char search-yank-word-char)
+ (if forward 'word-search-forward 'word-search-backward)
+ (if regexp
+ (if forward 're-search-forward 're-search-backward)
+ (if forward 'search-forward 'search-backward))))
+ ;; Read the search string with corrected prompt.
+ (setq string (read-string message))
+ (let ((var (if regexp 'search-last-regexp 'search-last-string)))
+ ;; Empty means use default.
+ (if (= 0 (length string))
+ (setq string (symbol-value var))
+ ;; Set last search string now so it is set even if we fail.
+ (set var string)))
+ ;; Since we used the minibuffer, we should be available for redo.
+ (setq command-history (cons (list function string) command-history))
+ ;; Go ahead and search.
+ (funcall function string)))
diff --git a/lisp/isearch.elc b/lisp/isearch.elc
new file mode 100644
index 00000000000..e7fcdb45584
--- /dev/null
+++ b/lisp/isearch.elc
Binary files differ
diff --git a/lisp/kermit.el b/lisp/kermit.el
index a66165b9671..2c7ef76c59a 100644
--- a/lisp/kermit.el
+++ b/lisp/kermit.el
@@ -66,6 +66,19 @@
;; option to force kermit to be local, to use stdin and stdout for interactive
;; speech, and to forget about cbreak mode.
+;; 2) The "clean-filter" can be a troublesome item. The main problem arises if
+;; you are running a program under shell-mode which is doing periodic output,
+;; and you then try to switch to another buffer. I came across this while
+;; running kermit file transfers - kermit prints a dot each time a packet is
+;; received. Since emacs is interrupted each time a dot is printed, it becomes
+;; impossible to edit the other buffer. If you hit a key while the filter code
+;; is running, that character will wind up in the *shell* buffer instead of the
+;; current one! So you need to be careful to turn the filter off before
+;; leaving the buffer if a program is still running. In fact, you can't even
+;; use "M-x clean-shell-off" to do this, because you won't be able to type
+;; "clean-shell-off" in the minibuffer!! So you need to have this command
+;; bound to a keystroke.
+
;; Please let me know if any bugs turn up.
;; Feb 1988, Jeff Norden - jeff@colgate.csnet
@@ -90,49 +103,82 @@
;; extra bindings for folks suffering form ^S/^Q braindamage:
(define-key shell-mode-map "\C-c\\" 'kermit-esc)
-(defun kermit-send-input-cr ()
- "Like \\[comint-send-input] but end the line with carriage-return."
+(defun shell-send-input-cr ()
+ "Like \\[shell-send-input] but end the line with carriage-return."
(interactive)
- (comint-send-input "\r"))
+ (end-of-line)
+ (if (eobp)
+ (progn
+ (move-marker last-input-start
+ (process-mark (get-buffer-process (current-buffer))))
+ (insert ?\n)
+ (move-marker last-input-end (point)))
+ (beginning-of-line)
+ (re-search-forward shell-prompt-pattern nil t)
+ (let ((copy (buffer-substring (point)
+ (progn (forward-line 1) (point)))))
+ (goto-char (point-max))
+ (move-marker last-input-start (point))
+ (insert copy)
+ (move-marker last-input-end (point))))
+ (condition-case ()
+ (save-excursion
+ (goto-char last-input-start)
+ (shell-set-directory))
+ (error (funcall shell-set-directory-error-hook)))
+ (let ((process (get-buffer-process (current-buffer))))
+ (process-send-region process last-input-start (- last-input-end 1))
+ (process-send-string process "\r")
+ (set-marker (process-mark process) (point))))
;; This is backwards of what makes sense, but ...
-(define-key shell-mode-map "\n" 'kermit-send-input-cr)
+(define-key shell-mode-map "\n" 'shell-send-input-cr)
(defun kermit-default-cr ()
"Make RETURN end the line with carriage-return and LFD end it with a newline.
This is useful for talking to other systems on which carriage-return
is the normal way to end a line."
(interactive)
- (define-key shell-mode-map "\r" 'kermit-send-input-cr)
- (define-key shell-mode-map "\n" 'comint-send-input))
+ (define-key shell-mode-map "\r" 'shell-send-input-cr)
+ (define-key shell-mode-map "\n" 'shell-send-input))
(defun kermit-default-nl ()
"Make RETURN end the line with a newline char. This is the default state.
In this state, use LFD to send a line and end it with a carriage-return."
(interactive)
- (define-key shell-mode-map "\n" 'kermit-send-input-cr)
- (define-key shell-mode-map "\r" 'comint-send-input))
-
-(defun kermit-clean-filter (proc str)
- "Strip ^M and ^@ characters from process output."
- (save-excursion
- (let ((beg (process-mark proc)))
- (set-buffer (process-buffer proc))
- (goto-char beg)
- (insert-before-markers str)
- (while (re-search-backware "[\r\C-a]+" beg t)
- (replace-match "")))))
+ (define-key shell-mode-map "\n" 'shell-send-input-cr)
+ (define-key shell-mode-map "\r" 'shell-send-input))
+
+;; This filter works, but I don't especially recommend it.
+(defun kermit-clean-filter (process string)
+ "A process filter which deletes all ^M's and ^@'s from the output."
+ (set-buffer (process-buffer process))
+ (let
+ ((firstpos (string-match "[^\C-@\r]+" string))
+ (buffermark (process-mark process))
+ (oldpt (point))
+ (newstring '"")
+ goback)
+ (while firstpos
+ (setq newstring
+ (concat newstring (substring string firstpos (match-end 0))))
+ (setq firstpos (string-match "[^\C-@\r]+" string (match-end 0))))
+ (goto-char (marker-position buffermark))
+ (setq goback (< oldpt (point)))
+ (insert newstring)
+ (set-marker buffermark (point))
+ (if goback (goto-char oldpt))))
(defun kermit-clean-on ()
"Delete all null characters and ^M's from the kermit output.
Note that another (perhaps better) way to do this is to use the
-command \"kermit | tr -d '\\015'\"."
+command `kermit | tr -d '\\015''."
(interactive)
(set-process-filter (get-buffer-process (current-buffer))
'kermit-clean-filter))
(defun kermit-clean-off ()
- "Cancel a previous kermit-clean-shell-on command."
+ "Cancel a previous kermit-clean-shell-on command"
(interactive)
(set-process-filter (get-buffer-process (current-buffer)) nil))
diff --git a/lisp/keypad.el b/lisp/keypad.el
new file mode 100644
index 00000000000..49bc3eaa227
--- /dev/null
+++ b/lisp/keypad.el
@@ -0,0 +1,152 @@
+;; Terminal-independent keypad and function key bindings.
+;; Copyright (C) 1986 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+;; These keys are handled by a two-level process.
+;; The first level, terminal-dependent, maps input sequences
+;; into the function keys that they represent.
+;; The second level, terminal-independent but customized by users,
+;; map function keys into meanings.
+
+;; This file takes care of the second level of mapping.
+;; The first, terminal-dependent, level is handled by the
+;; terminal-specific files term/*.el.
+
+;; The second-level mapping is done by a keymap, function-keymap.
+;; Here we document the meanings of the "characters" defined by
+;; function-keymap.
+
+;; What do these letters mean?
+;; When we say that ``a stands for the clear-all-tabs key'',
+;; we mean that you should attach to the letter `a' in function-keymap
+;; whatever command you want to be executed when you type the
+;; clear-all-tabs key on any terminal. The terminal-dependent
+;; files will attempt to make this work. If a terminal has no
+;; clear-all-tabs key that can be recognized, it makes no difference
+;; what binding you give to `a' in function-keymap.
+
+;; a -- clear all tabs key
+;; c -- erase key
+;; d -- down-arrow
+;; e -- enter key
+;; f -- find key or search key
+;; h -- home-position key
+;; k -- delete key or remove key.
+;; l -- left-arrow
+;; p -- portrait mode
+;; q -- landscape mode
+;; r -- right-arrow
+;; s -- select key
+;; t -- clear tab this column key
+;; u -- up-arrow
+;; x -- do key
+;; ? -- help
+
+;; - -- keypad key labelled `-'.
+;; . -- keypad key labelled `.'.
+;; , -- keypad key labelled `,'.
+;; 0 ... 9 -- keypad key labelled with that digit,
+;; but only if that key is not also an arrow key.
+
+;; C-@, C-a, ... C-x -- numbered function keys 0 through 24.
+;; These are used for function keys with no labels but numbers,
+;; and may also be used for function keys with labels
+;; that we have not defined letters for.
+
+;; A -- insert line key
+;; C -- clear screen key
+;; D -- delete character key.
+;; E -- clear to end of line key
+;; F -- scroll forward key
+;; H -- home-down
+;; I -- insert character key
+;; If there is just an "insert" key, it should be this.
+;; L -- delete line key
+;; M -- exit insert mode key
+;; N -- next page key
+;; P -- previous page key
+;; R -- scroll reverse key
+;; S -- clear to end of screen key
+;; T -- set tab this column key
+
+(defun keypad-default (char definition)
+ (or (lookup-key function-keymap char)
+ (define-key function-keymap char definition)))
+
+;; Here are the standard command meanings we give to the various
+;; function key names. Because this file is loaded after the user's
+;; init file, we are careful to avoid overriding any definitions
+;; already stored in function-keymap by the init file or (less often)
+;; by the terminal-specific term/*.el file.
+
+(keypad-default "l" 'backward-char)
+(keypad-default "r" 'forward-char)
+(keypad-default "D" 'delete-char)
+(keypad-default "u" 'previous-line)
+(keypad-default "d" 'next-line)
+(keypad-default "N" 'scroll-up)
+(keypad-default "P" 'scroll-down)
+(keypad-default "C" 'recenter)
+(keypad-default "?" 'help-for-help)
+(keypad-default "s" 'set-mark-command)
+(keypad-default "k" 'kill-region)
+(keypad-default "f" 're-search-forward)
+
+(keypad-default "\C-a" 'beginning-of-line)
+(keypad-default "\C-b" 'end-of-line)
+(keypad-default "\C-c" 'isearch-forward)
+(keypad-default "\C-d" 'kill-line)
+
+(keypad-default "." 'delete-char)
+(keypad-default "0" 'yank)
+(keypad-default "e" 'open-line)
+(keypad-default "1" 'backward-word)
+(keypad-default "3" 'forward-word)
+(keypad-default "7" 'backward-paragraph)
+(keypad-default "9" 'forward-paragraph)
+(keypad-default "h" 'move-to-window-line)
+
+(defun setup-terminal-keymap (map translations)
+ "Set up keymap MAP to forward to function-keymap according to TRANSLATIONS.
+TRANSLATIONS is an alist; each element of it looks like (FROMSTRING . TOCHAR).
+For each such pair, we define the key sequence FROMSTRING in MAP
+to forward to the definition of character TOCHAR in function-keymap.
+\"Forwarding\" means that subsequent redefinition of TOCHAR in
+function-keymap will be seen automatically in MAP as well.
+
+This function is used by files term/*.el to set up the mapping from the
+escape sequences sent by function keys on particular terminals (FROMSTRINGs)
+into Emacs standard function key slots (TOCHARs).
+An actual definition (such as a symbol) may be given in place of TOCHAR.
+Generally, MAP is a prefix keymap which will be attached to a key
+that is the common prefix sent by all function keys (often ESC O or ESC [)."
+ (while translations
+ (define-key map (car (car translations))
+ (if (numberp (cdr (car translations)))
+ (cons function-keymap (cdr (car translations)))
+ (cdr (car translations))))
+ (setq translations (cdr translations))))
+
+(defun function-key-sequence (char)
+ "Return key sequence for function key that on this terminal
+translates into slot CHAR in function-keymap.
+Or return nil if there is none."
+ (car (where-is-internal (cons function-keymap char) (current-local-map))))
+
+(provide 'keypad)
diff --git a/lisp/keypad.elc b/lisp/keypad.elc
new file mode 100644
index 00000000000..ab51cfd5e9f
--- /dev/null
+++ b/lisp/keypad.elc
Binary files differ
diff --git a/lisp/ledit.el b/lisp/ledit.el
index 0428fa8b228..2cdca35a470 100644
--- a/lisp/ledit.el
+++ b/lisp/ledit.el
@@ -23,12 +23,12 @@
(defvar ledit-mode-map nil)
-(defconst ledit-zap-file (concat "/tmp/" (user-login-name) ".l1")
+(defconst ledit-zap-file (concat "/tmp/" (getenv "USER") ".l1")
"File name for data sent to Lisp by Ledit.")
-(defconst ledit-read-file (concat "/tmp/" (user-login-name) ".l2")
+(defconst ledit-read-file (concat "/tmp/" (getenv "USER") ".l2")
"File name for data sent to Ledit by Lisp.")
(defconst ledit-compile-file
- (concat "/tmp/" (user-login-name) ".l4")
+ (concat "/tmp/" (getenv "USER") ".l4")
"File name for data sent to Lisp compiler by Ledit.")
(defconst ledit-buffer "*LEDIT*"
"Name of buffer in which Ledit accumulates data to send to Lisp.")
@@ -57,19 +57,19 @@
(message "Region saved for Lisp"))
(defun ledit-zap-defun-to-lisp ()
- "Carry the current defun to Lisp."
+ "Carry the current defun to lisp"
(interactive)
(ledit-save-defun)
(ledit-go-to-lisp))
(defun ledit-zap-defun-to-liszt ()
- "Carry the current defun to liszt."
+ "Carry the current defun to liszt"
(interactive)
(ledit-save-defun)
(ledit-go-to-liszt))
(defun ledit-zap-region-to-lisp (beg end)
- "Carry the current region to Lisp."
+ "Carry the current region to lisp"
(interactive "r")
(ledit-save-region beg end)
(ledit-go-to-lisp))
@@ -104,7 +104,7 @@
(load ledit-read-file t t))
(defun ledit-setup ()
- "Set up key bindings for the Lisp/Emacs interface."
+ "Set up key bindings for the Lisp / Emacs interface"
(if (not ledit-mode-map)
(progn (setq ledit-mode-map (make-sparse-keymap))
(lisp-mode-commands ledit-mode-map)))
@@ -116,13 +116,13 @@
(ledit-setup)
(defun ledit-mode ()
- "\\<ledit-mode-map>Major mode for editing text and stuffing it to a Lisp job.
+ "Major mode for editing text and stuffing it to a Lisp job.
Like Lisp mode, plus these special commands:
- \\[ledit-save-defun] -- record defun at or after point
+ M-C-d -- record defun at or after point
for later transmission to Lisp job.
- \\[ledit-save-region] -- record region for later transmission to Lisp job.
- \\[ledit-go-to-lisp] -- transfer to Lisp job and transmit saved text.
- \\[ledit-go-to-liszt] -- transfer to Liszt (Lisp compiler) job
+ M-C-r -- record region for later transmission to Lisp job.
+ C-x z -- transfer to Lisp job and transmit saved text.
+ M-C-c -- transfer to Liszt (Lisp compiler) job
and transmit saved text.
\\{ledit-mode-map}
To make Lisp mode automatically change to Ledit mode,
diff --git a/lisp/play/life.el b/lisp/life.el
index 059bf350fd4..16b0e719b5b 100644
--- a/lisp/play/life.el
+++ b/lisp/life.el
@@ -97,8 +97,8 @@
(defun life (&optional sleeptime)
"Run Conway's Life simulation.
-The starting pattern is randomly selected. Prefix arg (optional first
-arg non-nil from a program) is the number of seconds to sleep between
+The starting pattern is randomly selected. Prefix arg (optional first arg
+non-nil from a program) is the number of seconds to sleep between
generations (this defaults to 1)."
(interactive "p")
(or sleeptime (setq sleeptime 1))
@@ -131,7 +131,7 @@ generations (this defaults to 1)."
life-generation-string)
fill-column (1- (window-width))
life-window-start 1)
- (buffer-disable-undo (current-buffer))
+ (buffer-flush-undo (current-buffer))
;; stuff in the random pattern
(life-insert-random-pattern)
;; make sure (life-life-char) is used throughout
@@ -272,3 +272,5 @@ generations (this defaults to 1)."
(put 'life-extinct 'error-conditions '(life-extinct quit))
(put 'life-extinct 'error-message "All life has perished")
+
+
diff --git a/lisp/life.elc b/lisp/life.elc
new file mode 100644
index 00000000000..6ad5e273a0d
--- /dev/null
+++ b/lisp/life.elc
Binary files differ
diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/lisp-mode.el
index e9a05c5abca..860dc368ee8 100644
--- a/lisp/emacs-lisp/lisp-mode.el
+++ b/lisp/lisp-mode.el
@@ -48,8 +48,7 @@
(modify-syntax-entry ?` "' " emacs-lisp-mode-syntax-table)
(modify-syntax-entry ?' "' " emacs-lisp-mode-syntax-table)
(modify-syntax-entry ?, "' " emacs-lisp-mode-syntax-table)
- ;; Used to be singlequote; changed for flonums.
- (modify-syntax-entry ?. "_ " emacs-lisp-mode-syntax-table)
+ (modify-syntax-entry ?. "' " emacs-lisp-mode-syntax-table)
(modify-syntax-entry ?# "' " emacs-lisp-mode-syntax-table)
(modify-syntax-entry ?\" "\" " emacs-lisp-mode-syntax-table)
(modify-syntax-entry ?\\ "\\ " emacs-lisp-mode-syntax-table)
@@ -81,10 +80,6 @@
(setq paragraph-ignore-fill-prefix t)
(make-local-variable 'indent-line-function)
(setq indent-line-function 'lisp-indent-line)
- (make-local-variable 'indent-region-function)
- (setq indent-region-function 'lisp-indent-region)
- (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)
@@ -93,26 +88,18 @@
(setq comment-column 40)
(make-local-variable 'comment-indent-hook)
(setq comment-indent-hook 'lisp-comment-indent))
-
-(defvar shared-lisp-mode-map ()
- "Keymap for commands shared by all sorts of Lisp modes.")
-
-(if shared-lisp-mode-map
- ()
- (setq shared-lisp-mode-map (make-sparse-keymap))
- (define-key shared-lisp-mode-map "\e\C-q" 'indent-sexp)
- (define-key shared-lisp-mode-map "\177" 'backward-delete-char-untabify)
- (define-key shared-lisp-mode-map "\t" 'lisp-indent-line))
-
-(defvar emacs-lisp-mode-map ()
- "Keymap for Emacs Lisp mode.
-All commands in shared-lisp-mode-map are inherited by this map.")
+(defun lisp-mode-commands (map)
+ (define-key map "\e\C-q" 'indent-sexp)
+ (define-key map "\177" 'backward-delete-char-untabify)
+ (define-key map "\t" 'lisp-indent-line))
+
+(defvar emacs-lisp-mode-map () "")
(if emacs-lisp-mode-map
()
- (setq emacs-lisp-mode-map
- (nconc (make-sparse-keymap) shared-lisp-mode-map))
- (define-key emacs-lisp-mode-map "\e\C-x" 'eval-defun))
+ (setq emacs-lisp-mode-map (make-sparse-keymap))
+ (define-key emacs-lisp-mode-map "\e\C-x" 'eval-defun)
+ (lisp-mode-commands emacs-lisp-mode-map))
(defun emacs-lisp-mode ()
"Major mode for editing Lisp code to run in Emacs.
@@ -120,7 +107,7 @@ Commands:
Delete converts tabs to spaces as it moves back.
Blank lines separate paragraphs. Semicolons start comments.
\\{emacs-lisp-mode-map}
-Entry to this mode calls the value of `emacs-lisp-mode-hook'
+Entry to this mode calls the value of emacs-lisp-mode-hook
if that value is non-nil."
(interactive)
(kill-all-local-variables)
@@ -131,16 +118,13 @@ if that value is non-nil."
(lisp-mode-variables nil)
(run-hooks 'emacs-lisp-mode-hook))
-(defvar lisp-mode-map ()
- "Keymap for ordinary Lisp mode.
-All commands in `shared-lisp-mode-map' are inherited by this map.")
-
+(defvar lisp-mode-map ())
(if lisp-mode-map
()
- (setq lisp-mode-map
- (nconc (make-sparse-keymap) shared-lisp-mode-map))
+ (setq lisp-mode-map (make-sparse-keymap))
(define-key lisp-mode-map "\e\C-x" 'lisp-send-defun)
- (define-key lisp-mode-map "\C-c\C-l" 'run-lisp))
+ (define-key lisp-mode-map "\C-c\C-l" 'run-lisp)
+ (lisp-mode-commands lisp-mode-map))
(defun lisp-mode ()
"Major mode for editing Lisp code for Lisps other than GNU Emacs Lisp.
@@ -151,7 +135,7 @@ Blank lines separate paragraphs. Semicolons start comments.
Note that `run-lisp' may be used either to start an inferior Lisp job
or to switch back to an existing one.
-Entry to this mode calls the value of `lisp-mode-hook'
+Entry to this mode calls the value of lisp-mode-hook
if that value is non-nil."
(interactive)
(kill-all-local-variables)
@@ -164,18 +148,15 @@ if that value is non-nil."
;; This will do unless shell.el is loaded.
(defun lisp-send-defun nil
- "Send the current defun to the Lisp process made by \\[run-lisp]."
+ "Send the current defun to the Lisp process made by M-x run-lisp."
(interactive)
(error "Process lisp does not exist"))
-(defvar lisp-interaction-mode-map ()
- "Keymap for Lisp Interaction moe.
-All commands in `shared-lisp-mode-map' are inherited by this map.")
-
+(defvar lisp-interaction-mode-map ())
(if lisp-interaction-mode-map
()
- (setq lisp-interaction-mode-map
- (nconc (make-sparse-keymap) shared-lisp-mode-map))
+ (setq lisp-interaction-mode-map (make-sparse-keymap))
+ (lisp-mode-commands lisp-interaction-mode-map)
(define-key lisp-interaction-mode-map "\e\C-x" 'eval-defun)
(define-key lisp-interaction-mode-map "\n" 'eval-print-last-sexp))
@@ -186,17 +167,16 @@ before point, and prints its value into the buffer, advancing point.
Commands:
Delete converts tabs to spaces as it moves back.
-Paragraphs are separated only by blank lines.
-Semicolons start comments.
+Paragraphs are separated only by blank lines. Semicolons start comments.
\\{lisp-interaction-mode-map}
-Entry to this mode calls the value of `lisp-interaction-mode-hook'
+Entry to this mode calls the value of lisp-interaction-mode-hook
if that value is non-nil."
(interactive)
(kill-all-local-variables)
(use-local-map lisp-interaction-mode-map)
+ (set-syntax-table emacs-lisp-mode-syntax-table)
(setq major-mode 'lisp-interaction-mode)
(setq mode-name "Lisp Interaction")
- (set-syntax-table emacs-lisp-mode-syntax-table)
(lisp-mode-variables nil)
(run-hooks 'lisp-interaction-mode-hook))
@@ -230,21 +210,21 @@ With argument, print output into current buffer."
(if arg (current-buffer) t)))
(defun eval-defun (arg)
- "Evaluate defun that point is in or before. Print value in minibuffer.
-With argument, edebug-defun it instead, preparing it for source-level
-debugging with the electric debugger."
+ "Evaluate defun that point is in or before.
+Print value in minibuffer.
+With argument, insert value in current buffer after the defun."
(interactive "P")
- (if arg (edebug-defun)
- (save-excursion
- (end-of-defun)
- (let ((end (point)))
- (beginning-of-defun)
- (eval-region (point) end t)))))
+ (save-excursion
+ (end-of-defun)
+ (let ((end (point)))
+ (beginning-of-defun)
+ (eval-region (point) end
+ (if arg (current-buffer) t)))))
(defun lisp-comment-indent ()
- (if (looking-at "\\s<\\s<\\s<")
+ (if (looking-at ";;;")
(current-column)
- (if (looking-at "\\s<\\s<")
+ (if (looking-at ";;")
(let ((tem (calculate-lisp-indent)))
(if (listp tem) (car tem) tem))
(skip-chars-backward " \t")
@@ -252,7 +232,7 @@ debugging with the electric debugger."
comment-column))))
(defconst lisp-indent-offset nil "")
-(defconst lisp-indent-function 'lisp-indent-function "")
+(defconst lisp-indent-hook 'lisp-indent-hook "")
(defun lisp-indent-line (&optional whole-exp)
"Indent current line as Lisp code.
@@ -264,10 +244,10 @@ rigidly along with this one."
(beginning-of-line)
(setq beg (point))
(skip-chars-forward " \t")
- (if (looking-at "\\s<\\s<\\s<")
+ (if (looking-at ";;;")
;; Don't alter indentation of a ;;; comment line.
nil
- (if (and (looking-at "\\s<") (not (looking-at "\\s<\\s<")))
+ (if (and (looking-at ";") (not (looking-at ";;")))
;; Single-semicolon comment lines should be indented
;; as comment lines, not as code.
(progn (indent-for-comment) (forward-char -1))
@@ -375,17 +355,17 @@ of the start of the containing expression."
((and (integerp lisp-indent-offset) containing-sexp)
;; Indent by constant offset
(goto-char containing-sexp)
- (+ (current-column) lisp-indent-offset))
+ (+ normal-indent lisp-indent-offset))
(desired-indent)
- ((and (boundp 'lisp-indent-function)
- lisp-indent-function
+ ((and (boundp 'lisp-indent-hook)
+ lisp-indent-hook
(not retry))
- (or (funcall lisp-indent-function indent-point state)
+ (or (funcall lisp-indent-hook indent-point state)
normal-indent))
(t
normal-indent))))))
-(defun lisp-indent-function (indent-point state)
+(defun lisp-indent-hook (indent-point state)
(let ((normal-indent (current-column)))
(goto-char (1+ (elt state 1)))
(parse-partial-sexp (point) last-sexp 0 t)
@@ -407,7 +387,7 @@ of the start of the containing expression."
(let ((function (buffer-substring (point)
(progn (forward-sexp 1) (point))))
method)
- (setq method (get (intern-soft function) 'lisp-indent-function))
+ (setq method (get (intern-soft function) 'lisp-indent-hook))
(cond ((or (eq method 'defun)
(and (null method)
(> (length function) 3)
@@ -427,7 +407,7 @@ of the start of the containing expression."
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. lisp-indent-function guarantees that there is at
+ ;; function symbol. lisp-indent-hook guarantees that there is at
;; least one word or symbol character following open paren of containing
;; form.
(goto-char containing-form-start)
@@ -475,41 +455,35 @@ of the start of the containing expression."
(+ lisp-body-indent (current-column)))))
-;; (put 'progn 'lisp-indent-function 0), say, causes progn to be indented
+;; (put 'progn 'lisp-indent-hook 0), say, causes progn 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 'lambda 'lisp-indent-function 'defun)
-(put 'autoload 'lisp-indent-function 'defun)
-(put 'progn 'lisp-indent-function 0)
-(put 'prog1 'lisp-indent-function 1)
-(put 'prog2 'lisp-indent-function 2)
-(put 'save-excursion 'lisp-indent-function 0)
-(put 'save-window-excursion 'lisp-indent-function 0)
-(put 'save-restriction 'lisp-indent-function 0)
-(put 'let 'lisp-indent-function 1)
-(put 'let* 'lisp-indent-function 1)
-(put 'while 'lisp-indent-function 1)
-(put 'if 'lisp-indent-function 2)
-(put 'catch 'lisp-indent-function 1)
-(put 'condition-case 'lisp-indent-function 2)
-(put 'unwind-protect 'lisp-indent-function 1)
-(put 'with-output-to-temp-buffer 'lisp-indent-function 1)
-
-(defun indent-sexp (&optional endpos)
- "Indent each line of the list starting just after point.
-If optional arg ENDPOS is given, indent each line, stopping when
-ENDPOS is encountered."
+(put 'lambda 'lisp-indent-hook 'defun)
+(put 'progn 'lisp-indent-hook 0)
+(put 'prog1 'lisp-indent-hook 1)
+(put 'save-excursion 'lisp-indent-hook 0)
+(put 'save-window-excursion 'lisp-indent-hook 0)
+(put 'save-restriction 'lisp-indent-hook 0)
+(put 'let 'lisp-indent-hook 1)
+(put 'let* 'lisp-indent-hook 1)
+(put 'while 'lisp-indent-hook 1)
+(put 'if 'lisp-indent-hook 2)
+(put 'catch 'lisp-indent-hook 1)
+(put 'condition-case 'lisp-indent-hook 2)
+(put 'unwind-protect 'lisp-indent-hook 1)
+(put 'with-output-to-temp-buffer 'lisp-indent-hook 1)
+
+(defun indent-sexp ()
+ "Indent each line of the list starting just after point."
(interactive)
- (let ((indent-stack (list nil)) (next-depth 0) last-depth bol
- outer-loop-done inner-loop-done state this-indent
- (last-point (point)))
+ (let ((indent-stack (list nil)) (next-depth 0) bol
+ outer-loop-done inner-loop-done state this-indent)
;; Get error now if we don't have a complete sexp after point.
(save-excursion (forward-sexp 1))
(save-excursion
(setq outer-loop-done nil)
- (while (if endpos (< (point) endpos)
- (not outer-loop-done))
+ (while (not outer-loop-done)
(setq last-depth next-depth
inner-loop-done nil)
;; Parse this line so we can learn the state
@@ -539,14 +513,7 @@ ENDPOS is encountered."
(forward-line 1)
(setcar (nthcdr 5 state) nil))
(setq inner-loop-done t)))
- (and endpos
- (while (<= next-depth 0)
- (setq indent-stack (append indent-stack (list nil)))
- (setq next-depth (1+ next-depth))
- (setq last-depth (1+ last-depth))))
- (or outer-loop-done
- (setq outer-loop-done (<= next-depth 0)))
- (if outer-loop-done
+ (if (or outer-loop-done (setq outer-loop-done (<= next-depth 0)))
nil
(while (> last-depth next-depth)
(setq indent-stack (cdr indent-stack)
@@ -561,14 +528,13 @@ ENDPOS is encountered."
(skip-chars-forward " \t")
;; But not if the line is blank, or just a comment
;; (except for double-semi comments; indent them as usual).
- (if (or (eobp) (looking-at "\\s<\\|\n"))
+ (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-lisp-indent
- (if (car indent-stack) (- (car indent-stack))
- last-point))))
+ (if (car indent-stack) (- (car indent-stack))))))
(if (integerp val)
(setcar indent-stack
(setq this-indent val))
@@ -576,26 +542,12 @@ ENDPOS is encountered."
(setq this-indent (car val)))))
(if (/= (current-column) this-indent)
(progn (delete-region bol (point))
- (indent-to this-indent)))))
- (or outer-loop-done
- (setq outer-loop-done (= (point) last-point))
- (setq last-point (point)))))))
-
-;; Indent every line whose first char is between START and END inclusive.
-(defun lisp-indent-region (start end)
- (save-excursion
- (goto-char start)
- (and (bolp) (not (eolp))
- (lisp-indent-line))
- (let ((endmark (copy-marker end)))
- (indent-sexp endmark)
- (set-marker endmark nil))))
+ (indent-to this-indent)))))))))
(defun indent-code-rigidly (start end arg &optional nochange-regexp)
"Indent all lines of code, starting in the region, sideways by ARG columns.
-Does not affect lines starting inside comments or strings, assuming that
-the start of the region is not inside them.
-
+Does not affect lines starting inside comments or strings,
+assuming that the start of the region is not inside them.
Called from a program, takes args START, END, COLUMNS and NOCHANGE-REGEXP.
The last is a regexp which, if matched at the beginning of a line,
means don't indent that line."
@@ -623,3 +575,4 @@ means don't indent that line."
(progn
(forward-line 1) (point))
nil nil state))))))
+
diff --git a/lisp/lisp-mode.elc b/lisp/lisp-mode.elc
new file mode 100644
index 00000000000..e5820af34f8
--- /dev/null
+++ b/lisp/lisp-mode.elc
Binary files differ
diff --git a/lisp/emacs-lisp/lisp.el b/lisp/lisp.el
index db2a4169ae3..8ecf0f329f8 100644
--- a/lisp/emacs-lisp/lisp.el
+++ b/lisp/lisp.el
@@ -18,30 +18,23 @@
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-(defvar defun-prompt-regexp nil
- "Non-nil => regexp to ignore, before the `(' that starts a defun.")
-
(defun forward-sexp (&optional arg)
- "Move forward across one balanced expression (sexp).
-With argument, do it that many times. Negative arg -N means
-move backward across N balanced expressions."
+ "Move forward across one balanced expression.
+With argument, do this that many times."
(interactive "p")
(or arg (setq arg 1))
(goto-char (or (scan-sexps (point) arg) (buffer-end arg)))
(if (< arg 0) (backward-prefix-chars)))
(defun backward-sexp (&optional arg)
- "Move backward across one balanced expression (sexp).
-With argument, do it that many times. Negative arg -N means
-move forward across N balanced expressions."
+ "Move backward across one balanced expression.
+With argument, do this that many times."
(interactive "p")
(or arg (setq arg 1))
(forward-sexp (- arg)))
(defun mark-sexp (arg)
- "Set mark ARG sexps from point.
-The place mark goes is the same place \\[forward-sexp] would
-move to with the same argument."
+ "Set mark ARG sexps from point."
(interactive "p")
(push-mark
(save-excursion
@@ -50,16 +43,14 @@ move to with the same argument."
(defun forward-list (&optional arg)
"Move forward across one balanced group of parentheses.
-With argument, do it that many times.
-Negative arg -N means move backward across N groups of parentheses."
+With argument, do this that many times."
(interactive "p")
(or arg (setq arg 1))
(goto-char (or (scan-lists (point) arg 0) (buffer-end arg))))
(defun backward-list (&optional arg)
"Move backward across one balanced group of parentheses.
-With argument, do it that many times.
-Negative arg -N means move forward across N groups of parentheses."
+With argument, do this that many times."
(interactive "p")
(or arg (setq arg 1))
(forward-list (- arg)))
@@ -67,8 +58,7 @@ Negative arg -N means move forward across N groups of parentheses."
(defun down-list (arg)
"Move forward down one level of parentheses.
With argument, do this that many times.
-A negative argument means move backward but still go down a level.
-In Lisp programs, an argument is required."
+A negative argument means move backward but still go down a level."
(interactive "p")
(let ((inc (if (> arg 0) 1 -1)))
(while (/= arg 0)
@@ -78,16 +68,14 @@ In Lisp programs, an argument is required."
(defun backward-up-list (arg)
"Move backward out of one level of parentheses.
With argument, do this that many times.
-A negative argument means move forward but still to a less deep spot.
-In Lisp programs, an argument is required."
+A negative argument means move forward but still to a less deep spot."
(interactive "p")
(up-list (- arg)))
(defun up-list (arg)
"Move forward out of one level of parentheses.
With argument, do this that many times.
-A negative argument means move backward but still to a less deep spot.
-In Lisp programs, an argument is required."
+A negative argument means move backward but still to a less deep spot."
(interactive "p")
(let ((inc (if (> arg 0) 1 -1)))
(while (/= arg 0)
@@ -95,49 +83,34 @@ In Lisp programs, an argument is required."
(setq arg (- arg inc)))))
(defun kill-sexp (arg)
- "Kill the sexp (balanced expression) following the cursor.
-With argument, kill that many sexps after the cursor.
-Negative arg -N means kill N sexps before the cursor."
+ "Kill the syntactic expression following the cursor.
+With argument, kill that many expressions after (or before) the cursor."
(interactive "p")
(let ((opoint (point)))
(forward-sexp arg)
(kill-region opoint (point))))
(defun backward-kill-sexp (arg)
- "Kill the sexp (balanced expression) preceding the cursor.
-With argument, kill that many sexps before the cursor.
-Negative arg -N means kill N sexps after the cursor."
+ "Kill the syntactic expression preceding the cursor.
+With argument, kill that many expressions before (or after) the cursor."
(interactive "p")
(kill-sexp (- arg)))
(defun beginning-of-defun (&optional arg)
- "Move backward to the beginning of a defun.
-With argument, do it that many times. Negative arg -N
-means move forward to Nth following beginning of defun.
-Returns t unless search stops due to beginning or end of buffer.
-
-Normally a defun starts when there is an char with open-parenthesis
-syntax at the beginning of a line. If `defun-prompt-regexp' is
-non-nil, then a string which matches that regexp may precede the
-open-parenthesis."
+ "Move backward to next beginning-of-defun.
+With argument, do this that many times.
+Returns t unless search stops due to end of buffer."
(interactive "p")
(and arg (< arg 0) (forward-char 1))
- (and (re-search-backward (if defun-prompt-regexp
- (concat "^\\s(\\|"
- "\\(" defun-prompt-regexp "\\)\\s(")
- "^\\s(")
- nil 'move (or arg 1))
+ (and (re-search-backward "^\\s(" nil 'move (or arg 1))
(progn (beginning-of-line) t)))
(defun buffer-end (arg)
(if (> arg 0) (point-max) (point-min)))
(defun end-of-defun (&optional arg)
- "Move forward to next end of defun. With argument, do it that many times.
-Negative argument -N means move back to Nth preceding end of defun.
-
-An end of a defun occurs right after the close-parenthesis that matches
-the open-parenthesis that starts a defun; see `beginning-of-defun'."
+ "Move forward to next end of defun.
+An end of a defun is found by moving forward from the beginning of one."
(interactive "p")
(if (or (null arg) (= arg 0)) (setq arg 1))
(let ((first t))
@@ -154,7 +127,7 @@ the open-parenthesis that starts a defun; see `beginning-of-defun'."
(setq first nil)
(forward-list 1)
(skip-chars-forward " \t")
- (if (looking-at "\\s<\\|\n")
+ (if (looking-at "[;\n]")
(forward-line 1))
(<= (point) pos))))
(setq arg (1- arg)))
@@ -174,8 +147,7 @@ the open-parenthesis that starts a defun; see `beginning-of-defun'."
(setq arg (1+ arg)))))
(defun mark-defun ()
- "Put mark at end of this defun, point at beginning.
-The defun marked is the one that contains point or follows point."
+ "Put mark at end of defun, point at beginning."
(interactive)
(push-mark (point))
(end-of-defun)
@@ -187,20 +159,21 @@ The defun marked is the one that contains point or follows point."
"Put parentheses around next ARG sexps. Leave point after open-paren.
No argument is equivalent to zero: just insert () and leave point between."
(interactive "P")
- (if arg (setq arg (prefix-numeric-value arg))
- (setq arg 0))
- (or (eq arg 0) (skip-chars-forward " \t"))
- (and (memq (char-syntax (preceding-char)) '(?w ?_ ?\) ))
- (insert " "))
+;Install these commented-out lines for version 19.
+; (if arg (skip-chars-forward " \t")
+; (or (memq (char-syntax (preceding-char)) '(?\ ?> ?\( ))
+; (insert " ")))
(insert ?\()
(save-excursion
- (or (eq arg 0) (forward-sexp arg))
+ (if arg
+ (forward-sexp (prefix-numeric-value arg)))
(insert ?\))
- (and (memq (char-syntax (following-char)) '(?w ?_ ?\( ))
- (insert " "))))
+; (or (memq (char-syntax (following-char)) '(?\ ?> ?\( ))
+; (insert " "))
+ ))
(defun move-past-close-and-reindent ()
- "Move past next `)', delete indentation before it, then indent after it."
+ "Move past next ), delete indentation before it, then indent after it."
(interactive)
(up-list 1)
(forward-char -1)
@@ -213,12 +186,14 @@ No argument is equivalent to zero: just insert () and leave point between."
(newline-and-indent))
(defun lisp-complete-symbol ()
- "Perform completion on Lisp symbol preceding point. That symbol is
-compared against the symbols that exist and any additional characters
-determined by what is there are inserted.
- If the symbol starts just after an open-parenthesis, only symbols
-with function definitions are considered. Otherwise, all symbols with
-function definitions, values or properties are considered."
+ "Perform completion on Lisp symbol preceding point.
+That symbol is compared against the symbols that exist
+and any additional characters determined by what is there
+are inserted.
+If the symbol starts just after an open-parenthesis,
+only symbols with function definitions are considered.
+Otherwise, all symbols with function definitions, values
+or properties are considered."
(interactive)
(let* ((end (point))
(buffer-syntax (syntax-table))
diff --git a/lisp/lisp.elc b/lisp/lisp.elc
new file mode 100644
index 00000000000..e8ac960a0f9
--- /dev/null
+++ b/lisp/lisp.elc
Binary files differ
diff --git a/lisp/loaddefs.el b/lisp/loaddefs.el
new file mode 100644
index 00000000000..c2ce00f04f7
--- /dev/null
+++ b/lisp/loaddefs.el
@@ -0,0 +1,1942 @@
+;; Define standard autoloads and keys of other files, for Emacs.
+;; Copyright (C) 1985, 1986, 1987 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+;;; Special formatting conventions are used in this file!
+;;;
+;;; a backslash-newline is used at the beginning of a documentation string
+;;; when that string should be stored in the file etc/DOCnnn, not in core.
+;;;
+;;; Such strings read into Lisp as numbers (during the pure-loading phase).
+;;;
+;;; But you must obey certain rules to make sure the string is understood
+;;; and goes into etc/DOCnnn properly. Otherwise, the string will not go
+;;; anywhere!
+;;;
+;;; The doc string must appear in the standard place in a call to
+;;; defun, autoload, defvar or defconst. No Lisp macros are recognized.
+;;; The open-paren starting the definition must appear in column 0.
+;;;
+;;; In defvar and defconst, there is an additional rule:
+;;; The double-quote that starts the string must be on the same
+;;; line as the defvar or defconst.
+;;; !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+;; Know which function the debugger is!
+(setq debugger 'debug)
+
+(defconst mode-line-buffer-identification (purecopy '("Emacs: %17b")) "\
+Mode-line control for identifying the buffer being displayed.
+Its default value is \"Emacs: %17b\". Major modes that edit things
+other than ordinary files may change this (e.g. Info, Dired,...)")
+
+(make-variable-buffer-local 'mode-line-buffer-identification)
+
+(defconst mode-line-process nil "\
+Mode-line control for displaying info on process status.
+Normally nil in most modes, since there is no process to display.")
+
+(make-variable-buffer-local 'mode-line-process)
+
+(defconst mode-line-modified (purecopy '("--%1*%1*-")) "\
+Mode-line control for displaying whether current buffer is modified.")
+
+(make-variable-buffer-local 'mode-line-modified)
+
+(setq-default mode-line-format
+ (list (purecopy "")
+ 'mode-line-modified
+ 'mode-line-buffer-identification
+ (purecopy " ")
+ 'global-mode-string
+ (purecopy " %[(")
+ 'mode-name 'minor-mode-alist "%n" 'mode-line-process
+ (purecopy ")%]----")
+ (purecopy '(-3 . "%p"))
+ (purecopy "-%-")))
+
+(defvar minor-mode-alist nil "\
+Alist saying how to show minor modes in the mode line.
+Each element looks like (VARIABLE STRING);
+STRING is included in the mode line iff VARIABLE's value is non-nil.")
+(setq minor-mode-alist (mapcar 'purecopy
+ '((abbrev-mode " Abbrev")
+ (overwrite-mode " Ovwrt")
+ (auto-fill-hook " Fill")
+ ;; not really a minor mode...
+ (defining-kbd-macro " Def"))))
+
+(defconst function-keymap (make-sparse-keymap) "\
+Keymap containing definitions of keypad and function keys.")
+
+;; These variables are used by autoloadable packages.
+;; They are defined here so that they do not get overridden
+;; by the loading of those packages.
+
+(defconst paragraph-start "^[ \t\n\f]" "\
+*Regexp for beginning of a line that starts OR separates paragraphs.")
+(defconst paragraph-separate "^[ \t\f]*$" "\
+*Regexp for beginning of a line that separates paragraphs.
+If you change this, you may have to change paragraph-start also.")
+
+(defconst sentence-end (purecopy "[.?!][]\"')}]*\\($\\|\t\\| \\)[ \t\n]*") "\
+*Regexp describing the end of a sentence.
+All paragraph boundaries also end sentences, regardless.")
+
+(defconst page-delimiter "^\014" "\
+*Regexp describing line-beginnings that separate pages.")
+
+(defconst case-replace t "\
+*Non-nil means query-replace should preserve case in replacements.")
+
+;; indent.el may not be autoloading, but it still loses
+;; if lisp-mode is ever called before this defvar is done.
+(defvar indent-line-function 'indent-to-left-margin "\
+Function to indent current line.")
+
+(defconst only-global-abbrevs nil "\
+*t means user plans to use global abbrevs only.
+Makes the commands to define mode-specific abbrevs define global ones instead.")
+
+;; Names in directory that end in one of these
+;; are ignored in completion,
+;; making it more likely you will get a unique match.
+(setq completion-ignored-extensions
+ (if (eq system-type 'vax-vms)
+ '(".obj" ".elc" ".exe" ".bin" ".lbin"
+ ".dvi" ".toc" ".log" ".aux"
+ ".lof" ".brn" ".rnt" ".mem" ".lni" ".lis"
+ ".olb" ".tlb" ".mlb" ".hlb" ".glo" ".idx" ".lot")
+ '(".o" ".elc" "~" ".bin" ".lbin" ".fasl"
+ ".dvi" ".toc" ".log" ".aux"
+ ".lof" ".blg" ".bbl" ".glo" ".idx" ".lot")))
+
+(defvar compile-command "make -k" "\
+*Last shell command used to do a compilation; default for next compilation.")
+
+(defvar dired-listing-switches "-al" "\
+*Switches passed to ls for Dired. MUST contain the `l' option.
+MUST NOT contain the `F, `s' or `i'' option.")
+
+(defconst lpr-switches nil "\
+*List of strings to pass as extra switch args to lpr when it is invoked.")
+
+(defvar tags-file-name nil "\
+*File name of tag table.
+To switch to a new tag table, setting this variable is sufficient.
+Use the `etags' program to make a tag table file.")
+
+(defconst shell-prompt-pattern "^[^#$%>]*[#$%>] *" "\
+*Regexp used by Newline command in shell mode to match subshell prompts.
+Anything from beginning of line up to the end of what this pattern matches
+is deemed to be prompt, and is not reexecuted.")
+
+(defconst ledit-save-files t "\
+*Non-nil means Ledit should save files before transferring to Lisp.")
+(defconst ledit-go-to-lisp-string "%?lisp" "\
+*Shell commands to execute to resume Lisp job.")
+(defconst ledit-go-to-liszt-string "%?liszt" "\
+*Shell commands to execute to resume Lisp compiler job.")
+
+(defconst display-time-day-and-date nil "\
+*Non-nil means M-x display-time should display day and date as well as time.")
+
+;;; Determine mode according to filename
+
+(defvar auto-mode-alist nil "\
+Alist of filename patterns vs corresponding major mode functions.
+Each element looks like (REGEXP . FUNCTION).
+Visiting a file whose name matches REGEXP causes FUNCTION to be called.")
+(setq auto-mode-alist (mapcar 'purecopy
+ '(("\\.text$" . text-mode)
+ ("\\.c$" . c-mode)
+ ("\\.h$" . c-mode)
+ ("\\.tex$" . TeX-mode)
+ ("\\.el$" . emacs-lisp-mode)
+ ("\\.scm$" . scheme-mode)
+ ("\\.l$" . lisp-mode)
+ ("\\.lisp$" . lisp-mode)
+ ("\\.f$" . fortran-mode)
+ ("\\.mss$" . scribe-mode)
+ ("\\.pl$" . prolog-mode)
+;;; Less common extensions come here
+;;; so more common ones above are found faster.
+ ("\\.TeX$" . TeX-mode)
+ ("\\.sty$" . LaTeX-mode)
+ ("\\.bbl$" . LaTeX-mode)
+ ("\\.bib$" . text-mode)
+ ("\\.article$" . text-mode)
+ ("\\.letter$" . text-mode)
+ ("\\.texinfo$" . texinfo-mode)
+ ("\\.texi$" . texinfo-mode)
+ ("\\.lsp$" . lisp-mode)
+ ("\\.prolog$" . prolog-mode)
+ ;; Mailer puts message to be edited in /tmp/Re.... or Message
+ ("^/tmp/Re" . text-mode)
+ ;; some news reader is reported to use this
+ ("^/tmp/fol/" . text-mode)
+ ("/Message[0-9]*$" . text-mode)
+ ("\\.y$" . c-mode)
+ ("\\.cc$" . c-mode)
+ ("\\.scm.[0-9]*$" . scheme-mode)
+ ;; .emacs following a directory delimiter
+ ;; in either Unix or VMS syntax.
+ ("[]>:/]\\..*emacs$" . emacs-lisp-mode)
+ ("\\.ml$" . lisp-mode))))
+
+(make-variable-buffer-local 'indent-tabs-mode)
+
+(defvar ctl-x-4-map (make-keymap) "\
+Keymap for subcommands of C-x 4")
+
+;; Reduce total amount of space we must allocate during this function
+;; that we will not need to keep permanently.
+(garbage-collect)
+
+;; Autoload random libraries.
+;; Alphabetical order by library name.
+
+(autoload 'add-change-log-entry "add-log"
+ "\
+Find change log file and add an entry for today.
+First arg (interactive prefix) non-nil means prompt for user name and site.
+Second arg is file name of change log.
+Optional third arg OTHER-WINDOW non-nil means visit in other window."
+ t)
+
+(define-key ctl-x-4-map "a" 'add-change-log-entry-other-window)
+
+(autoload 'add-change-log-entry-other-window "add-log"
+ "\
+Find change log file in other window, and add an entry for today."
+ t)
+
+(autoload '\` "backquote"
+ "\
+\(` FORM) Expands to a form that will generate FORM.
+FORM is `almost quoted' -- see backquote.el for a description."
+ nil t)
+
+(autoload 'byte-compile-file "bytecomp"
+ "\
+Compile a file of Lisp code named FILENAME into a file of byte code.
+The output file's name is made by appending \"c\" to the end of FILENAME."
+ t)
+
+(autoload 'byte-recompile-directory "bytecomp"
+ "\
+Recompile every .el file in DIRECTORY that needs recompilation.
+This is if a .elc file exists but is older than the .el file.
+If the .elc file does not exist, offer to compile the .el file
+only if a prefix argument has been specified."
+ t)
+
+(autoload 'batch-byte-compile "bytecomp"
+ "\
+Runs byte-compile-file on the files remaining on the command line.
+Must be used only with -batch, and kills emacs on completion.
+Each file will be processed even if an error occurred previously.
+For example, invoke \"emacs -batch -f batch-byte-compile $emacs/ ~/*.el\""
+ nil)
+
+(autoload 'calendar "cal"
+ "\
+Display three-month calendar in another window.
+The three months appear side by side, with the current month in the middle
+surrounded by the previous and next months. The cursor is put on today's date.
+
+An optional prefix argument ARG causes the calendar displayed to be
+ARG months in the future if ARG is positive or in the past if ARG is
+negative; in this case the cursor goes on the first day of the month.
+
+The Gregorian calendar is assumed.
+
+After preparing the calendar window, the hooks calendar-hook are run
+when the calendar is for the current month--that is, the was no prefix
+argument. If the calendar is for a future or past month--that is, there
+was a prefix argument--the hooks offset-calendar-hook are run. Thus, for
+example, setting calendar-hooks to 'star-date will cause today's date to be
+replaced by asterisks to highlight it in the window."
+ t)
+
+(autoload 'list-command-history "chistory"
+ "\
+List history of commands typed to minibuffer.
+The number of commands listed is controlled by list-command-history-max.
+Calls value of list-command-history-filter (if non-nil) on each history
+element to judge if that element should be excluded from the list.
+
+The buffer is left in Command History mode."
+ t)
+
+(autoload 'command-history-mode "chistory"
+ "\
+Major mode for examining commands from command-history.
+The number of commands listed is controlled by list-command-history-max.
+The command history is filtered by list-command-history-filter if non-nil.
+
+Like Emacs-Lisp Mode except that characters do not insert themselves and
+Digits provide prefix arguments. Tab does not indent.
+\\{command-history-map}
+Calls the value of command-history-hook if that is non-nil
+The Command History listing is recomputed each time this mode is
+invoked."
+ t)
+
+(autoload 'repeat-matching-complex-command "chistory"
+ "\
+Edit and re-evaluate complex command with name matching PATTERN.
+Matching occurrences are displayed, most recent first, until you
+select a form for evaluation. If PATTERN is empty (or nil), every form
+in the command history is offered. The form is placed in the minibuffer
+for editing and the result is evaluated."
+ t)
+
+
+(autoload 'common-lisp-indent-hook "cl-indent")
+
+(autoload 'compare-windows "compare-w"
+ "\
+Compare text in current window with text in next window.
+Compares the text starting at point in each window,
+moving over text in each one as far as they match."
+ t)
+
+(autoload 'compile "compile"
+ "\
+Compile the program including the current buffer. Default: run `make'.
+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 source code that caused it."
+ t)
+
+(autoload 'grep "compile"
+ "\
+Run grep, with user-specified args, and collect output in a buffer.
+While grep runs asynchronously, you can use the \\[next-error] command
+to find the text that grep hits refer to."
+ t)
+
+(define-key ctl-x-map "`" 'next-error)
+
+(autoload 'next-error "compile"
+ "\
+Visit next compilation error message and corresponding source code.
+This operates on the output from the \\[compile] command.
+If all preparsed error messages have been processed,
+the error message buffer is checked for new ones.
+A non-nil argument (prefix arg, if interactive)
+means reparse the error message buffer and start at the first error."
+ t)
+
+(define-key esc-map "/" 'dabbrev-expand)
+
+(autoload 'dabbrev-expand "dabbrev"
+ "\
+Expand previous word \"dynamically\".
+Expands to the most recent, preceding word for which this is a prefix.
+If no suitable preceding word is found, words following point are considered.
+
+A positive prefix argument, N, says to take the Nth backward DISTINCT
+possibility. A negative argument says search forward. The variable
+dabbrev-backward-only may be used to limit the direction of search to
+backward if set non-nil.
+
+If the cursor has not moved from the end of the previous expansion and
+no argument is given, replace the previously-made expansion
+with the next possible expansion not yet tried."
+ t)
+
+(autoload 'debug "debug"
+ "\
+Enter debugger. Returns if user says \"continue\".
+Arguments are mainly for use when this is called
+ from the internals of the evaluator.
+You may call with no args, or you may
+ pass nil as the first arg and any other args you like.
+ In that case, the list of args after the first will
+ be printed into the backtrace buffer.")
+
+(autoload 'cancel-debug-on-entry "debug"
+ "\
+Undoes effect of debug-on-entry on FUNCTION."
+ t)
+
+(autoload 'debug-on-entry "debug"
+ "\
+Request FUNCTION to invoke debugger each time it is called.
+If the user continues, FUNCTION's execution proceeds.
+Works by modifying the definition of FUNCTION,
+which must be written in Lisp, not predefined.
+Use `cancel-debug-on-entry' to cancel the effect of this command.
+Redefining FUNCTION also does that."
+ t)
+
+(define-key ctl-x-map "d" 'dired)
+
+(autoload 'dired "dired"
+ "\
+\"Edit\" directory DIRNAME--delete, rename, print, etc. some files in it.
+Dired displays a list of files in DIRNAME.
+You can move around in it with the usual commands.
+You can flag files for deletion with C-d
+and then delete them by typing `x'.
+Type `h' after entering dired for more info."
+ t)
+
+(define-key ctl-x-4-map "d" 'dired-other-window)
+
+(autoload 'dired-other-window "dired"
+ "\
+\"Edit\" directory DIRNAME. Like \\[dired] but selects in another window."
+ t)
+
+(autoload 'dired-noselect "dired"
+ "\
+Like M-x dired but returns the dired buffer as value, does not select it.")
+
+(autoload 'dissociated-press "dissociate"
+ "\
+Dissociate the text of the current buffer.
+Output goes in buffer named *Dissociation*,
+which is redisplayed each time text is added to it.
+Every so often the user must say whether to continue.
+If ARG is positive, require ARG chars of continuity.
+If ARG is negative, require -ARG words of continuity.
+Default is 2."
+ t)
+
+(autoload 'doctor "doctor"
+ "\
+Switch to *doctor* buffer and start giving psychotherapy."
+ t)
+
+(autoload 'disassemble "disass"
+ "\
+Print disassembled code for OBJECT on (optional) STREAM.
+OBJECT can be a function name, lambda expression or any function object
+returned by SYMBOL-FUNCTION. If OBJECT is not already compiled, we will
+compile it (but not redefine it)."
+ t)
+
+(autoload 'electric-buffer-list "ebuff-menu"
+ "\
+Vaguely like ITS lunar select buffer;
+combining typeoutoid buffer listing with menuoid buffer selection.
+
+This pops up a buffer describing the set of emacs buffers.
+If the very next character typed is a space then the buffer list
+ window disappears.
+
+Otherwise, one may move around in the buffer list window, marking
+ buffers to be selected, saved or deleted.
+
+To exit and select a new buffer, type Space when the cursor is on the
+ appropriate line of the buffer-list window.
+
+Other commands are much like those of buffer-menu-mode.
+
+Calls value of electric-buffer-menu-mode-hook on entry if non-nil.
+
+\\{electric-buffer-menu-mode-map}"
+ t)
+
+
+(autoload 'electric-command-history "echistory"
+ "\
+Major mode for examining and redoing commands from command-history.
+The number of command listed is controlled by list-command-history-max.
+The command history is filtered by list-command-history-filter if non-nil.
+Combines typeout Command History list window with menu like selection
+of an expression from the history for re-evaluation in the *original* buffer.
+
+The history displayed is filtered by list-command-history-filter if non-nil.
+
+This pops up a window with the Command History listing. If the very
+next character typed is Space, the listing is killed and the previous
+window configuration is restored. Otherwise, you can browse in the
+Command History with Return moving down and Delete moving up, possibly
+selecting an expression to be redone with Space or quitting with `Q'.
+
+Like Emacs-Lisp Mode except that characters do not insert themselves and
+Tab and linefeed do not indent. Instead these commands are provided:
+Space or ! edit then evaluate current line in history inside
+ the ORIGINAL buffer which invoked this mode.
+ The previous window configuration is restored
+ unless the invoked command changes it.
+C-c C-c, C-], Q Quit and restore previous window configuration.
+LFD, RET Move to the next line in the history.
+DEL Move to the previous line in the history.
+? Provides a complete list of commands.
+
+Calls the value of electric-command-history-hook if that is non-nil
+The Command History listing is recomputed each time this mode is invoked."
+ t)
+
+(autoload 'edt-emulation-on "edt"
+ "\
+Begin emulating DEC's EDT editor.
+Certain keys are rebound; including nearly all keypad keys.
+Use \\[edt-emulation-off] to undo all rebindings except the keypad keys.
+Note that this function does not work if called directly from the .emacs file.
+Instead, the .emacs file should do (setq term-setup-hook 'edt-emulation-on)
+Then this function will be called at the time when it will work."
+ t)
+
+(autoload 'fortran-mode "fortran"
+ "\
+Major mode for editing fortran code.
+Tab indents the current fortran line correctly.
+`do' statements must not share a common `continue'.
+
+Type `;?' or `;\\[help-command]' to display a list of built-in abbrevs for Fortran keywords.
+
+Variables controlling indentation style and extra features:
+
+ comment-start
+ Normally nil in Fortran mode. If you want to use comments
+ starting with `!', set this to the string \"!\".
+ fortran-do-indent
+ Extra indentation within do blocks. (default 3)
+ fortran-if-indent
+ Extra indentation within if blocks. (default 3)
+ fortran-continuation-indent
+ Extra indentation appled to continuation statements. (default 5)
+ fortran-comment-line-column
+ Amount of indentation for text within full-line comments. (default 6)
+ fortran-comment-indent-style
+ nil means don't change indentation of text in full-line comments,
+ fixed means indent that text at column fortran-comment-line-column
+ relative means indent at fortran-comment-line-column beyond the
+ indentation for a line of code.
+ Default value is fixed.
+ fortran-comment-indent-char
+ Character to be inserted instead of space for full-line comment
+ indentation. (default is a space)
+ fortran-minimum-statement-indent
+ Minimum indentation for fortran statements. (default 6)
+ fortran-line-number-indent
+ Maximum indentation for line numbers. A line number will get
+ less than this much indentation if necessary to avoid reaching
+ column 5. (default 1)
+ fortran-check-all-num-for-matching-do
+ Non-nil causes all numbered lines to be treated as possible 'continue'
+ statements. (default nil)
+ fortran-continuation-char
+ character to be inserted in column 5 of a continuation line.
+ (default $)
+ fortran-comment-region
+ String inserted by \\[fortran-comment-region] at start of each line in
+ region. (default \"c$$$\")
+ fortran-electric-line-number
+ Non-nil causes line number digits to be moved to the correct column
+ as typed. (default t)
+ fortran-startup-message
+ Set to nil to inhibit message first time fortran-mode is used.
+
+Turning on Fortran mode calls the value of the variable fortran-mode-hook
+with no args, if that value is non-nil.
+\\{fortran-mode-map}"
+ t)
+
+(autoload 'ftp-find-file "ftp"
+ "\
+FTP to HOST to get FILE, logging in as USER with password PASSWORD.
+Interactively, HOST and FILE are specified by reading a string with
+ a colon character separating the host from the filename.
+USER and PASSWORD are defaulted from the values used when
+ last ftping from HOST (unless password-remembering is disabled).
+ Supply a password of the symbol `t' to override this default
+ (interactively, this is done by giving a prefix arg)"
+ t)
+
+(autoload 'ftp-write-file "ftp"
+ "\
+FTP to HOST to write FILE, logging in as USER with password PASSWORD.
+Interactively, HOST and FILE are specified by reading a string with colon
+separating the host from the filename.
+USER and PASSWORD are defaulted from the values used when
+ last ftping from HOST (unless password-remembering is disabled).
+ Supply a password of the symbol `t' to override this default
+ (interactively, this is done by giving a prefix arg)"
+ t)
+
+(autoload 'gdb "gdb"
+ "\
+Run gdb on program FILE in buffer *gdb-FILE*.
+The directory containing FILE becomes the initial working directory
+and source-file directory for GDB. If you wish to change this, use
+the GDB commands `cd DIR' and `directory'."
+ t)
+
+(autoload 'set-gosmacs-bindings "gosmacs"
+ "\
+Rebind some keys globally to make GNU Emacs resemble Gosling Emacs.
+Use \\[set-gnu-bindings] to restore previous global bindings."
+ t)
+
+(autoload 'hanoi "hanoi"
+ "\
+Towers of Hanoi diversion. Argument is number of rings."
+ t)
+
+(autoload 'Helper-help "helper"
+ "\
+Provide help for current mode."
+ t)
+
+(autoload 'Helper-describe-bindings "helper"
+ "\
+Describe local key bindings of current mode."
+ t)
+
+(autoload 'info "info"
+ "\
+Enter Info, the documentation browser."
+ t)
+
+(autoload 'Info-tagify "informat"
+ "\
+Create or update Info-file tag table in current buffer."
+ t)
+
+(autoload 'Info-validate "informat"
+ "\
+Check current buffer for validity as an Info file.
+Check that every node pointer points to an existing node."
+ t)
+
+(autoload 'Info-split "informat"
+ "\
+Split an info file into an indirect file plus bounded-size subfiles.
+Each subfile will be up to 50000 characters plus one node.
+
+To use this command, first visit a large Info file that has a tag table.
+The buffer is modified into a (small) indirect info file
+which should be saved in place of the original visited file.
+
+The subfiles are written in the same directory the original file is in,
+with names generated by appending `-' and a number to the original file name.
+
+The indirect file still functions as an Info file, but it contains
+just the tag table and a directory of subfiles."
+ t)
+
+(autoload 'batch-info-validate "informat"
+ "\
+Runs Info-validate on the files remaining on the command line.
+Must be used only with -batch, and kills emacs on completion.
+Each file will be processed even if an error occurred previously.
+For example, invoke \"emacs -batch -f batch-info-validate $info/ ~/*.info\""
+ nil)
+
+(autoload 'ledit-mode "ledit"
+ "\
+Major mode for editing text and stuffing it to a Lisp job.
+Like Lisp mode, plus these special commands:
+ M-C-d -- record defun at or after point
+ for later transmission to Lisp job.
+ M-C-r -- record region for later transmission to Lisp job.
+ C-x z -- transfer to Lisp job and transmit saved text.
+ M-C-c -- transfer to Liszt (Lisp compiler) job
+ and transmit saved text.
+\\{ledit-mode-map}
+To make Lisp mode automatically change to Ledit mode,
+do (setq lisp-mode-hook 'ledit-from-lisp-mode)"
+ t)
+
+(autoload 'ledit-from-lisp-mode "ledit")
+
+(autoload 'lpr-buffer "lpr"
+ "\
+Print buffer contents as with Unix command `lpr'.
+`lpr-switches' is a list of extra switches (strings) to pass to lpr."
+ t)
+
+(autoload 'print-buffer "lpr"
+ "\
+Print buffer contents as with Unix command `lpr -p'.
+`lpr-switches' is a list of extra switches (strings) to pass to lpr."
+ t)
+
+(autoload 'lpr-region "lpr"
+ "\
+Print region contents as with Unix command `lpr'.
+`lpr-switches' is a list of extra switches (strings) to pass to lpr."
+ t)
+
+(autoload 'print-region "lpr"
+ "\
+Print region contents as with Unix command `lpr -p'.
+`lpr-switches' is a list of extra switches (strings) to pass to lpr."
+ t)
+
+(autoload 'insert-kbd-macro "macros"
+ "\
+Insert in buffer the definition of kbd macro NAME, as Lisp code.
+Second argument KEYS non-nil means also record the keys it is on.
+ (This is the prefix argument, when calling interactively.)
+
+This Lisp code will, when executed, define the kbd macro with the
+same definition it has now. If you say to record the keys,
+the Lisp code will also rebind those keys to the macro.
+Only global key bindings are recorded since executing this Lisp code
+always makes global bindings.
+
+To save a kbd macro, visit a file of Lisp code such as your ~/.emacs,
+use this command, and then save the file."
+ t)
+
+(define-key ctl-x-map "q" 'kbd-macro-query)
+
+(autoload 'kbd-macro-query "macros"
+ "\
+Query user during kbd macro execution.
+With prefix argument, enters recursive edit,
+ reading keyboard commands even within a kbd macro.
+ You can give different commands each time the macro executes.
+Without prefix argument, reads a character. Your options are:
+ Space -- execute the rest of the macro.
+ DEL -- skip the rest of the macro; start next repetition.
+ C-d -- skip rest of the macro and don't repeat it any more.
+ C-r -- enter a recursive edit, then on exit ask again for a character
+ C-l -- redisplay screen and ask again."
+ t)
+
+(autoload 'name-last-kbd-macro "macros"
+ "\
+Assign a name to the last keyboard macro defined.
+One arg, a symbol, which is the name to define.
+The symbol's function definition becomes the keyboard macro string.
+Such a \"function\" cannot be called from Lisp, but it is a valid command
+definition for the editor command loop."
+ t)
+
+(autoload 'make-command-summary "makesum"
+ "\
+Make a summary of current key bindings in the buffer *Summary*.
+Previous contents of that buffer are killed first."
+ t)
+
+(autoload 'define-mail-alias "mailalias"
+ "\
+Define NAME as a mail-alias that translates to DEFINITION."
+ t)
+
+(autoload 'manual-entry "man"
+ "\
+Display the Unix manual entry for TOPIC.
+TOPIC is either the title of the entry, or has the form TITLE(SECTION)
+where SECTION is the desired section of the manual, as in `tty(4)'."
+ t)
+
+(autoload 'mh-rmail "mh-e"
+ "\
+Inc(orporate) new mail (no arg) or scan a MH mail box (arg given).
+This front end uses the MH mail system, which uses different conventions
+from the usual mail system."
+ t)
+
+(autoload 'mh-smail "mh-e"
+ "\
+Send mail using the MH mail system."
+ t)
+
+(autoload 'convert-mocklisp-buffer "mlconvert"
+ "\
+Convert buffer of Mocklisp code to real Lisp that GNU Emacs can run."
+ t)
+
+(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
+Control-C followed by the first character of the construct.
+\\{m2-mode-map}
+ Control-c b begin Control-c c case
+ Control-c d definition Control-c e else
+ Control-c f for Control-c h header
+ Control-c i if Control-c m module
+ Control-c l loop Control-c o or
+ Control-c p procedure Control-c Control-w with
+ Control-c r record Control-c s stdio
+ Control-c t type Control-c u until
+ Control-c v var Control-c w while
+ Control-c x export Control-c y import
+ Control-c { begin-comment Control-c } end-comment
+ Control-c Control-z suspend-emacs Control-c Control-t toggle
+ Control-c Control-c compile Control-x ` next-error
+ Control-c Control-l 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)
+
+(setq disabled-command-hook 'disabled-command-hook)
+
+(autoload 'disabled-command-hook "novice")
+(autoload 'enable-command "novice"
+ "\
+Allow COMMAND to be executed without special confirmation from now on.
+The user's .emacs file is altered so that this will apply
+to future sessions." t)
+
+(autoload 'disable-command "novice"
+ "\
+Require special confirmation to execute COMMAND from now on.
+The user's .emacs file is altered so that this will apply
+to future sessions." t)
+
+(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)
+
+(autoload 'list-options "options"
+ "\
+Display a list of Emacs user options, with values and documentation."
+ t)
+
+(autoload 'edit-options "options"
+ "\
+Edit a list of Emacs user option values.
+Selects a buffer containing such a list,
+in which there are commands to set the option values.
+Type \\[describe-mode] in that buffer for a list of commands."
+ t)
+
+(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:
+C-c C-n outline-next-visible-heading move by visible headings
+C-c C-p outline-previous-visible-heading
+C-c C-f outline-forward-same-level similar but skip subheadings
+C-c C-b outline-backward-same-level
+C-c C-u outline-up-heading move from subheading to heading
+
+Meta-x hide-body make all text invisible (not headings).
+Meta-x 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.
+C-c C-h hide-subtree make body and subheadings invisible.
+C-c C-s show-subtree make body and subheadings visible.
+C-c C-i 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.
+M-x hide-entry make immediately following body invisible.
+M-x show-entry make it visible.
+M-x hide-leaves make body under heading and under its subheadings invisible.
+ The subheadings remain visible.
+M-x 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)
+
+(autoload 'edit-picture "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 mode line. 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:
+ C-p Move vertically to SAME column in previous line.
+ C-n Move vertically to SAME column in next line.
+ C-e Move to column following last non-whitespace character.
+ C-f Move right inserting spaces if required.
+ C-b 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 charecter.
+ `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.
+ Delete Clear (replace) ARG columns before point, moving back over them.
+ C-k Clear ARG lines, advancing over them. The cleared
+ text is saved in the kill ring.
+ C-o 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 edit-picture-hook if non-nil.
+
+Note that Picture mode commands will work outside of Picture mode, but
+they are not defaultly assigned to keys."
+ t)
+
+(fset 'picture-mode 'edit-picture)
+
+(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)
+
+(autoload 'run-prolog "prolog"
+ "\
+Run an inferior Prolog process, input and output via buffer *prolog*."
+ t)
+
+
+(autoload 'clear-rectangle "rect"
+ "\
+Blank out rectangle with corners at point and mark.
+The text previously in the region is overwritten by the blanks."
+ t)
+
+(autoload 'delete-rectangle "rect"
+ "\
+Delete (don't save) text in rectangle with point and mark as corners.
+The same range of columns is deleted in each line
+starting with the line where the region begins
+and ending with the line where the region ends."
+ t)
+
+(autoload 'delete-extract-rectangle "rect"
+ "\
+Return and delete contents of rectangle with corners at START and END.
+Value is list of strings, one for each line of the rectangle.")
+
+(autoload 'extract-rectangle "rect"
+ "\
+Return contents of rectangle with corners at START and END.
+Value is list of strings, one for each line of the rectangle.")
+
+(autoload 'insert-rectangle "rect"
+ "\
+Insert text of RECTANGLE with upper left corner at point.
+RECTANGLE's first line is inserted at point,
+its second line is inserted at a point vertically under point, etc.
+RECTANGLE should be a list of strings.")
+
+(autoload 'kill-rectangle "rect"
+ "\
+Delete rectangle with corners at point and mark; save as last killed one.
+Calling from program, supply two args START and END, buffer positions.
+But in programs you might prefer to use delete-extract-rectangle."
+ t)
+
+(autoload 'open-rectangle "rect"
+ "\
+Blank out rectangle with corners at point and mark, shifting text right.
+The text previously in the region is not overwritten by the blanks,
+but insted winds up to the right of the rectangle."
+ t)
+
+(autoload 'yank-rectangle "rect"
+ "\
+Yank the last killed rectangle with upper left corner at point."
+ t)
+
+(autoload 'rnews "rnews"
+ "\
+Read USENET news for groups for which you are a member and add or
+delete groups.
+You can reply to articles posted and send articles to any group.
+
+Type \\[describe-mode] once reading news to get a list of rnews commands."
+ t)
+
+(autoload 'news-post-news "rnewspost"
+ "\
+Begin editing a new USENET news article to be posted.
+Type \\[describe-mode] once editing the article to get a list of commands."
+ t)
+(fset 'sendnews 'news-post-news)
+(fset 'postnews 'news-post-news)
+
+(autoload 'rmail "rmail"
+ "\
+Read and edit incoming mail.
+Moves messages into file named by rmail-file-name (a babyl format file)
+ and edits that file in RMAIL Mode.
+Type \\[describe-mode] once editing that file, for a list of RMAIL commands.
+
+May be called with filename as argument;
+then performs rmail editing on that file,
+but does not copy any new mail into the file."
+ t)
+
+(autoload 'rmail-input "rmail"
+ "\
+Run RMAIL on file FILENAME."
+ t)
+
+(defconst rmail-dont-reply-to-names nil "\
+*A regular expression specifying names to prune in replying to messages.
+nil means don't reply to yourself.")
+
+(defvar rmail-default-dont-reply-to-names "info-" "\
+A regular expression specifying part of the value of the default value of
+the variable `rmail-dont-reply-to-names', for when the user does not set
+`rmail-dont-reply-to-names' explicitly. (The other part of the default
+value is the user's name.)
+It is useful to set this variable in the site customisation file.")
+
+(defconst rmail-primary-inbox-list nil "\
+*List of files which are inboxes for user's primary mail file ~/RMAIL.
+`nil' means the default, which is (\"~/mbox\" \"/usr/spool/mail/$USER\")
+(the second name varies depending on the operating system).")
+
+(defconst rmail-ignored-headers "^via:\\|^mail-from:\\|^origin:\\|^status:\\|^received:\\|^[a-z-]*message-id:\\|^summary-line:\\|^errors-to:" "\
+*Gubbish header fields one would rather not see.")
+
+(defvar rmail-delete-after-output nil "\
+*Non-nil means automatically delete a message that is copied to a file.")
+
+;;; Others are in paths.el.
+
+(autoload 'run-scheme "xscheme"
+ "\
+Run an inferior Scheme process.
+Output goes to the buffer `*scheme*'.
+With argument, asks for a command line."
+ t)
+
+(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)
+
+(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)
+
+;; Useful to set in site-init.el
+(defconst send-mail-function 'sendmail-send-it "\
+Function to call to send the current buffer as mail.
+The headers are delimited by a string found in mail-header-separator.")
+
+(defconst 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.")
+
+(defconst 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.")
+
+(defconst mail-yank-ignored-headers "^via:\\|^mail-from:\\|^origin:\\|^status:\\|^remailed\\|^received:\\|^[a-z-]*message-id:\\|^summary-line:\\|^to:\\|^cc:\\|^subject:\\|^in-reply-to:\\|^return-path:" "\
+Delete these headers from old message when it's inserted in a reply.")
+
+(defconst mail-header-separator "--text follows this line--" "\
+*Line used to separate headers from text in messages being composed.")
+
+(defconst mail-archive-file-name nil "\
+*Name of file to write all outgoing messages in, or nil for none.")
+
+(defvar mail-aliases t "\
+Alias of mail address aliases,
+or t meaning should be initialized from .mailrc.")
+
+(autoload 'mail-other-window "sendmail"
+ "\
+Like `mail' command, but display mail buffer in another window."
+ t)
+
+(autoload 'mail "sendmail"
+ "\
+Edit a message to be sent. Argument means resume editing (don't erase).
+Returns with message buffer selected; value t if message freshly initialized.
+While editing message, type C-c C-c 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}
+
+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.
+
+If mail-setup-hook is bound, its value is called with no arguments
+after the message is initialized. It can add more default fields.
+
+When calling from a program, 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."
+ t)
+
+(define-key ctl-x-4-map "m" 'mail-other-window)
+(define-key ctl-x-map "m" 'mail)
+
+;; used in mail-utils
+(defvar mail-use-rfc822 nil "\
+*If non-nil, use a full, hairy RFC822 parser on mail addresses.
+Otherwise, (the default) use a smaller, somewhat faster and
+often-correct parser.")
+
+
+(autoload 'server-start "server"
+ "\
+Allow this Emacs process to be a server for client processes.
+This starts a server communications subprocess through which
+client \"editors\" can send your editing commands to this Emacs job.
+To use the server, set up the program `etc/emacsclient' in the
+Emacs distribution as your standard \"editor\".
+
+Prefix arg means just kill any existing server communications subprocess."
+ t)
+
+(autoload 'run-lisp "shell"
+ "\
+Run an inferior Lisp process, input and output via buffer *lisp*."
+ t)
+
+(autoload 'shell "shell"
+ "\
+Run an inferior shell, with I/O through buffer *shell*.
+If buffer exists but shell process is not running, make new shell.
+Program used comes from variable explicit-shell-file-name,
+ or (if that is nil) from the ESHELL environment variable,
+ or else from SHELL if there is no ESHELL.
+If a file ~/.emacs_SHELLNAME exists, it is given as initial input
+ (Note that this may lose due to a timing error if the shell
+ discards input when it starts up.)
+The buffer is put in shell-mode, giving commands for sending input
+and controlling the subjobs of the shell. See shell-mode.
+See also variable shell-prompt-pattern.
+
+The shell file name (sans directories) is used to make a symbol name
+such as `explicit-csh-arguments'. If that symbol is a variable,
+its value is used as a list of arguments when invoking the shell.
+Otherwise, one argument `-i' is passed to the shell.
+
+Note that many people's .cshrc files unconditionally clear the prompt.
+If yours does, you will probably want to change it."
+ t)
+
+(autoload 'sort-lines "sort"
+ "\
+Sort lines in region alphabetically; argument means descending order.
+Called from a program, there are three arguments:
+REVERSE (non-nil means reverse order), BEG and END (region to sort)."
+ t)
+
+(autoload 'sort-paragraphs "sort"
+ "\
+Sort paragraphs in region alphabetically; argument means descending order.
+Called from a program, there are three arguments:
+REVERSE (non-nil means reverse order), BEG and END (region to sort)."
+ t)
+
+(autoload 'sort-pages "sort"
+ "\
+Sort pages in region alphabetically; argument means descending order.
+Called from a program, there are three arguments:
+REVERSE (non-nil means reverse order), BEG and END (region to sort)."
+ t)
+
+(autoload 'sort-numeric-fields "sort"
+ "\
+Sort lines in region numerically by the ARGth field of each line.
+Fields are separated by whitespace and numbered from 1 up.
+Specified field must contain a number in each line of the region.
+With a negative arg, sorts by the -ARG'th field, in reverse order.
+Called from a program, there are three arguments:
+FIELD, BEG and END. BEG and END specify region to sort."
+ t)
+
+(autoload 'sort-fields "sort"
+ "\
+Sort lines in region lexicographically by the ARGth field of each line.
+Fields are separated by whitespace and numbered from 1 up.
+With a negative arg, sorts by the -ARG'th field, in reverse order.
+Called from a program, there are three arguments:
+FIELD, BEG and END. BEG and END specify region to sort."
+ t)
+
+(autoload 'sort-columns "sort"
+ "\
+Sort lines in region alphabetically by a certain range of columns.
+For the purpose of this command, the region includes
+the entire line that point is in and the entire line the mark is in.
+The column positions of point and mark bound the range of columns to sort on.
+A prefix argument means sort into reverse order.
+
+Note that sort-columns uses the sort utility program and therefore
+cannot work on text containing TAB characters. Use M-x untabify
+to convert tabs to spaces before sorting."
+ t)
+
+(autoload 'sort-regexp-fields "sort"
+ "\
+Sort the region lexicographically as specifed by RECORD-REGEXP and KEY.
+RECORD-REGEXP specifies the textual units which should be sorted.
+ For example, to sort lines RECORD-REGEXP would be \"^.*$\"
+KEY specifies the part of each record (ie each match for RECORD-REGEXP)
+ is to be used for sorting.
+ If it is \"\\digit\" then the digit'th \"\\(...\\)\" match field from
+ RECORD-REGEXP is used.
+ If it is \"\\&\" then the whole record is used.
+ Otherwise, it is a regular-expression for which to search within the record.
+If a match for KEY is not found within a record then that record is ignored.
+
+With a negative prefix arg sorts in reverse order.
+
+For example: to sort lines in the region by the first word on each line
+ starting with the letter \"f\",
+ RECORD-REGEXP would be \"^.*$\" and KEY \"\\<f\\w*\\>\""
+ t)
+
+
+(autoload 'spell-buffer "spell"
+ "\
+Check spelling of every word in the buffer.
+For each incorrect word, you are asked for the correct spelling
+and then put into a query-replace to fix some or all occurrences.
+If you do not want to change a word, just give the same word
+as its \"correct\" spelling; then the query replace is skipped."
+ t)
+
+(autoload 'spell-region "spell"
+ "\
+Like spell-buffer but applies only to region.
+From program, applies from START to END."
+ t)
+
+(define-key esc-map "$" 'spell-word)
+(autoload 'spell-word "spell"
+ "\
+Check spelling of word at or before point.
+If it is not correct, ask user for the correct spelling
+and query-replace the entire buffer to substitute it."
+ t)
+
+(autoload 'spell-string "spell"
+ "\
+Check spelling of string supplied as argument."
+ t)
+
+(autoload 'untabify "tabify"
+ "\
+Convert all tabs in region to multiple spaces, preserving columns.
+The variable tab-width controls the action."
+ t)
+
+(autoload 'tabify "tabify"
+ "\
+Convert multiple spaces in region to tabs when possible.
+A group of spaces is partially replaced by tabs
+when this can be done without changing the column they end at.
+The variable tab-width controls the action."
+ t)
+
+(define-key esc-map "." 'find-tag)
+
+(autoload 'find-tag "tags"
+ "\
+Find tag (in current tag table) 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 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.
+
+See documentation of variable tags-file-name."
+ t)
+
+(define-key ctl-x-4-map "." 'find-tag-other-window)
+
+(autoload 'find-tag-other-window "tags"
+ "\
+Find tag (in current tag table) 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.
+
+See documentation of variable tags-file-name."
+ t)
+
+(autoload 'list-tags "tags"
+ "\
+Display list of tags in file FILE.
+FILE should not contain a directory spec
+unless it has one in the tag table."
+ t)
+
+(autoload 'next-file "tags"
+ "\
+Select next file among files in current tag table.
+Non-nil argument (prefix arg, if interactive)
+initializes to the beginning of the list of files in the tag table."
+ t)
+
+(autoload 'tags-apropos "tags"
+ "\
+Display list of all tags in tag table REGEXP matches."
+ t)
+
+(define-key esc-map "," 'tags-loop-continue)
+(autoload 'tags-loop-continue "tags"
+ "\
+Continue last \\[tags-search] or \\[tags-query-replace] command.
+Used noninteractively with non-nil argument
+to begin such a command. See variable tags-loop-form."
+ t)
+
+(autoload 'tag-table-files "tags"
+ "\
+Return a list of files in the current tag table.
+File names returned are absolute.")
+
+(autoload 'tags-query-replace "tags"
+ "\
+Query-replace-regexp FROM with TO through all files listed in tag table.
+Third arg DELIMITED (prefix arg) means replace only word-delimited matches.
+If you exit (C-G or ESC), you can resume the query-replace
+with the command \\[tags-loop-continue].
+
+See documentation of variable tags-file-name."
+ t)
+
+(autoload 'tags-search "tags"
+ "\
+Search through all files listed in tag 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 tags-file-name."
+ t)
+
+(autoload 'visit-tags-table "tags"
+ "\
+Tell tags commands to use tag table file FILE.
+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)
+
+(autoload 'telnet "telnet"
+ "\
+Open a network login connection to host named HOST (a string).
+Communication with HOST is recorded in a buffer *HOST-telnet*.
+Normally input is edited in Emacs and sent a line at a time."
+ t)
+
+(autoload 'terminal-emulator "terminal"
+ "\
+Under a display-terminal emulator in BUFFER, run PROGRAM on arguments ARGS.
+ARGS is a list of argument-strings. Remaining arguments are WIDTH and HEIGHT.
+BUFFER's contents are made an image of the display generated by that program,
+and any input typed when BUFFER is the current Emacs buffer is sent to that
+program an keyboard input.
+
+Interactively, BUFFER defaults to \"*terminal*\" and PROGRAM and ARGS
+are parsed from an input-string using your usual shell.
+WIDTH and HEIGHT are determined from the size of the current window
+-- WIDTH will be one less than the window's width, HEIGHT will be its height.
+
+To switch buffers and leave the emulator, or to give commands
+to the emulator itself (as opposed to the program running under it),
+type Control-^. The following character is an emulator command.
+Type Control-^ twice to send it to the subprogram.
+This escape character may be changed using the variable `terminal-escape-char'.
+
+`Meta' characters may not currently be sent through the terminal emulator.
+
+Here is a list of some of the variables which control the behaviour
+of the emulator -- see their documentation for more information:
+terminal-escape-char, terminal-scrolling, terminal-more-processing,
+terminal-redisplay-interval.
+
+This function calls the value of terminal-mode-hook if that exists
+and is non-nil after the terminal buffer has been set up and the
+subprocess started.
+
+Presently with `termcap' only; if somebody sends us code to make this
+work with `terminfo' we will try to use it."
+ t)
+
+(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-print] prints the .dvi file made by either of these.
+
+Use \\[validate-TeX-buffer] to check buffer for paragraphs containing
+mismatched $'s or braces.
+
+Special commands:
+\\{TeX-mode-map}
+
+Mode variables:
+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-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."
+ t)
+
+(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-print] prints the .dvi file made by either of these.
+
+Use \\[validate-TeX-buffer] to check buffer for paragraphs containing
+mismatched $'s or braces.
+
+Special commands:
+\\{TeX-mode-map}
+
+Mode variables:
+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-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."
+ t)
+
+(autoload 'tex-mode "tex-mode"
+ "\
+Major mode for editing files of input for TeX or LaTeX.
+Trys to intuit whether this file is for plain TeX or LaTeX and
+calls plain-tex-mode or latex-mode. If it cannot be determined
+(e.g., there are no commands in the file), the value of
+TeX-default-mode is used."
+ t)
+
+(fset 'TeX-mode 'tex-mode)
+(fset 'plain-TeX-mode 'plain-tex-mode)
+(fset 'LaTeX-mode 'latex-mode)
+
+(autoload 'texinfo-mode "texinfo"
+ "\
+Major mode for editing texinfo files.
+These are files that are input for TEX and also to be turned
+into Info files by \\[texinfo-format-buffer].
+These files must be written in a very restricted and
+modified version of TEX input format.
+
+As for editing commands, like text-mode except for syntax table,
+which is set up so expression commands skip texinfo bracket groups."
+ t)
+
+(autoload 'texinfo-format-buffer "texinfmt"
+ "\
+Process the current buffer as texinfo code, into an Info file.
+The Info file output is generated in a buffer
+visiting the Info file names specified in the @setfilename command.
+
+Non-nil argument (prefix, if interactive) means don't make tag table
+and don't split the file if large. You can use Info-tagify and
+Info-split to do these manually."
+ t)
+
+(autoload 'texinfo-format-region "texinfmt"
+ "\
+Convert the the current region of the Texinfo file to Info format.
+This lets you see what that part of the file will look like in Info.
+The command is bound to \\[texinfo-format-region]. The text that is
+converted to Info is stored in a temporary buffer."
+ t)
+
+(autoload 'batch-texinfo-format "texinfmt"
+ "\
+Runs texinfo-format-buffer on the files remaining on the command line.
+Must be used only with -batch, and kills emacs on completion.
+Each file will be processed even if an error occurred previously.
+For example, invoke
+ \"emacs -batch -funcall batch-texinfo-format $docs/ ~/*.texinfo\"."
+ nil)
+
+(autoload 'display-time "time"
+ "\
+Display current time and load level in mode line of each buffer.
+Updates automatically every minute.
+If display-time-day-and-date is non-nil, the current day and date
+are displayed as well."
+ t)
+
+(autoload 'underline-region "underline"
+ "\
+Underline all nonblank characters in the region.
+Works by overstriking underscores.
+Called from program, takes two arguments START and END
+which specify the range to operate on."
+ t)
+
+(autoload 'ununderline-region "underline"
+ "\
+Remove all underlining (overstruck underscores) in the region.
+Called from program, takes two arguments START and END
+which specify the range to operate on."
+ t)
+
+(autoload 'ask-user-about-lock "userlock"
+ "\
+Ask user what to do when he wants to edit FILE but it is locked by USER.
+This function has a choice of three things to do:
+ do (signal 'buffer-file-locked (list FILE USER))
+ to refrain from editing the file
+ return t (grab the lock on the file)
+ return nil (edit the file even though it is locked).
+You can rewrite it to use any criterion you like to choose which one to do."
+ nil)
+
+(autoload 'ask-user-about-supersession-threat "userlock"
+ "\
+Ask a user who is about to modify an obsolete buffer what to do.
+This function has two choices: it can return, in which case the modification
+of the buffer will proceed, or it can (signal 'file-supersession (file)),
+in which case the proposed buffer modification will not be made.
+You can rewrite this to use any criterion you like to choose which one to do."
+ nil)
+
+(autoload 'vi-mode "vi"
+ "\
+Major mode that acts like the `vi' editor.
+The purpose of this mode is to provide you the combined power of vi (namely,
+the \"cross product\" effect of commands and repeat last changes) and Emacs.
+
+This command redefines nearly all keys to look like vi commands.
+It records the previous major mode, and any vi command for input
+\(`i', `a', `s', etc.) switches back to that mode.
+Thus, ordinary Emacs (in whatever major mode you had been using)
+is \"input\" mode as far as vi is concerned.
+
+To get back into vi from \"input\" mode, you must issue this command again.
+Therefore, it is recommended that you assign it to a key.
+
+Major differences between this mode and real vi :
+
+* Limitations and unsupported features
+ - Search patterns with line offset (e.g. /pat/+3 or /pat/z.) are
+ not supported.
+ - Ex commands are not implemented; try ':' to get some hints.
+ - No line undo (i.e. the 'U' command), but multi-undo is a standard feature.
+
+* Modifications
+ - The stopping positions for some point motion commands (word boundary,
+ pattern search) are slightly different from standard 'vi'.
+ Also, no automatic wrap around at end of buffer for pattern searching.
+ - Since changes are done in two steps (deletion then insertion), you need
+ to undo twice to completely undo a change command. But this is not needed
+ for undoing a repeated change command.
+ - No need to set/unset 'magic', to search for a string with regular expr
+ in it just put a prefix arg for the search commands. Replace cmds too.
+ - ^R is bound to incremental backward search, so use ^L to redraw screen.
+
+* Extensions
+ - Some standard (or modified) Emacs commands were integrated, such as
+ incremental search, query replace, transpose objects, and keyboard macros.
+ - In command state, ^X links to the 'ctl-x-map', and ESC can be linked to
+ esc-map or set undefined. These can give you the full power of Emacs.
+ - See vi-com-map for those keys that are extensions to standard vi, e.g.
+ `vi-name-last-change-or-macro', `vi-verify-spelling', `vi-locate-def',
+ `vi-mark-region', and 'vi-quote-words'. Some of them are quite handy.
+ - Use \\[vi-switch-mode] to switch among different modes quickly.
+
+Syntax table and abbrevs while in vi mode remain as they were in Emacs."
+ t)
+
+(autoload 'view-file "view"
+ "\
+View FILE in View mode, returning to previous buffer when done.
+The usual Emacs commands are not available; instead,
+a special set of commands (mostly letters and punctuation)
+are defined for moving around in the buffer.
+Space scrolls forward, Delete scrolls backward.
+For list of all View commands, type ? or h while viewing.
+
+Calls the value of view-hook if that is non-nil."
+ t)
+
+(autoload 'view-buffer "view"
+ "\
+View BUFFER in View mode, returning to previous buffer when done.
+The usual Emacs commands are not available; instead,
+a special set of commands (mostly letters and punctuation)
+are defined for moving around in the buffer.
+Space scrolls forward, Delete scrolls backward.
+For list of all View commands, type ? or h while viewing.
+
+Calls the value of view-hook if that is non-nil."
+ t)
+
+(autoload 'view-mode "view"
+ "\
+Major mode for viewing text but not editing it.
+Letters do not insert themselves. Instead these commands are provided.
+Most commands take prefix arguments. Commands dealing with lines
+default to \"scroll size\" lines (initially size of window).
+Search commands default to a repeat count of one.
+M-< or < move to beginning of buffer.
+M-> or > move to end of buffer.
+C-v or Space scroll forward lines.
+M-v or DEL scroll backward lines.
+CR or LF scroll forward one line (backward with prefix argument).
+z like Space except set number of lines for further
+ scrolling commands to scroll by.
+C-u and Digits provide prefix arguments. `-' denotes negative argument.
+= prints the current line number.
+g goes to line given by prefix argument.
+/ or M-C-s searches forward for regular expression
+\\ or M-C-r searches backward for regular expression.
+n searches forward for last regular expression.
+p searches backward for last regular expression.
+C-@ or . set the mark.
+x exchanges point and mark.
+C-s or s do forward incremental search.
+C-r or r do reverse incremental search.
+@ or ' return to mark and pops mark ring.
+ Mark ring is pushed at start of every
+ successful search and when jump to line to occurs.
+ The mark is set on jump to buffer start or end.
+? or h provide help message (list of commands).
+C-h provides help (list of commands or description of a command).
+C-n moves down lines vertically.
+C-p moves upward lines vertically.
+C-l recenters the screen.
+q or C-c exit view-mode and return to previous buffer.
+
+Entry to this mode calls the value of view-hook if non-nil.
+\\{view-mode-map}")
+
+(autoload 'vip-mode "vip"
+ "\
+Begin emulating the vi editor. This is distinct from `vi-mode'.
+This emulator has different capabilities from the `vi-mode' emulator.
+See the text at the beginning of the source file .../lisp/vip.el
+in the Emacs distribution."
+ t)
+
+(autoload 'yow "yow"
+ "\
+Return or display a Zippy quotation" t)
+(autoload 'psychoanalyze-pinhead "yow"
+ "\
+Zippy goes to the analyst." t)
+
+
+(define-key esc-map "\C-f" 'forward-sexp)
+(define-key esc-map "\C-b" 'backward-sexp)
+(define-key esc-map "\C-u" 'backward-up-list)
+(define-key esc-map "\C-@" 'mark-sexp)
+(define-key esc-map "\C-d" 'down-list)
+(define-key esc-map "\C-k" 'kill-sexp)
+(define-key esc-map "\C-n" 'forward-list)
+(define-key esc-map "\C-p" 'backward-list)
+(define-key esc-map "\C-a" 'beginning-of-defun)
+(define-key esc-map "\C-e" 'end-of-defun)
+(define-key esc-map "\C-h" 'mark-defun)
+(define-key esc-map "(" 'insert-parentheses)
+(define-key esc-map ")" 'move-past-close-and-reindent)
+(define-key esc-map "\t" 'lisp-complete-symbol)
+
+(define-key ctl-x-map "\C-e" 'eval-last-sexp)
+
+(define-key ctl-x-map "/" 'point-to-register)
+(define-key ctl-x-map "j" 'register-to-point)
+(define-key ctl-x-map "x" 'copy-to-register)
+(define-key ctl-x-map "g" 'insert-register)
+(define-key ctl-x-map "r" 'copy-rectangle-to-register)
+
+(define-key esc-map "q" 'fill-paragraph)
+(define-key esc-map "g" 'fill-region)
+(define-key ctl-x-map "." 'set-fill-prefix)
+
+(define-key esc-map "[" 'backward-paragraph)
+(define-key esc-map "]" 'forward-paragraph)
+(define-key esc-map "h" 'mark-paragraph)
+(define-key esc-map "a" 'backward-sentence)
+(define-key esc-map "e" 'forward-sentence)
+(define-key esc-map "k" 'kill-sentence)
+(define-key ctl-x-map "\177" 'backward-kill-sentence)
+
+(define-key ctl-x-map "[" 'backward-page)
+(define-key ctl-x-map "]" 'forward-page)
+(define-key ctl-x-map "\C-p" 'mark-page)
+(put 'narrow-to-region 'disabled t)
+(define-key ctl-x-map "p" 'narrow-to-page)
+(put 'narrow-to-page 'disabled t)
+(define-key ctl-x-map "l" 'count-lines-page)
+
+(defun isearch-forward ()
+ "\
+Do incremental search forward.
+As you type characters, they add to the search string and are found.
+Type Delete to cancel characters from end of search string.
+Type ESC to exit, leaving point at location found.
+Type C-s to search again forward, C-r to search again backward.
+Type C-w to yank word from buffer onto end of search string and search for it.
+Type C-y to yank rest of line onto end of search string, etc.
+Type C-q to quote control character to search for it.
+Other control and meta characters terminate the search
+ and are then executed normally.
+The above special characters are mostly controlled by parameters;
+ do M-x apropos on search-.*-char to find them.
+C-g while searching or when search has failed
+ cancels input back to what has been found successfully.
+C-g when search is successful aborts and moves point to starting point."
+ (interactive)
+ (isearch t))
+
+(defun isearch-forward-regexp ()
+ "\
+Do incremental search forward for regular expression.
+Like ordinary incremental search except that your input
+is treated as a regexp. See \\[isearch-forward] for more info."
+ (interactive)
+ (isearch t t))
+
+(defun isearch-backward ()
+ "\
+Do incremental search backward.
+See \\[isearch-forward] for more information."
+ (interactive)
+ (isearch nil))
+
+(defun isearch-backward-regexp ()
+ "\
+Do incremental search backward for regular expression.
+Like ordinary incremental search except that your input
+is treated as a regexp. See \\[isearch-forward] for more info."
+ (interactive)
+ (isearch nil t))
+
+(defvar search-last-string "" "\
+Last string search for by a non-regexp search command.
+This does not include direct calls to the primitive search functions,
+and does not include searches that are aborted.")
+
+(defvar search-last-regexp "" "\
+Last string searched for by a regexp search command.
+This does not include direct calls to the primitive search functions,
+and does not include searches that are aborted.")
+
+(defconst search-repeat-char ?\C-s "\
+*Character to repeat incremental search forwards.")
+(defconst search-reverse-char ?\C-r "\
+*Character to repeat incremental search backwards.")
+(defconst search-exit-char ?\e "\
+*Character to exit incremental search.")
+(defconst search-delete-char ?\177 "\
+*Character to delete from incremental search string.")
+(defconst search-quote-char ?\C-q "\
+*Character to quote special characters for incremental search.")
+(defconst search-yank-word-char ?\C-w "\
+*Character to pull next word from buffer into search string.")
+(defconst search-yank-line-char ?\C-y "\
+*Character to pull rest of line from buffer into search string.")
+(defconst search-exit-option t "\
+*Non-nil means random control characters terminate incremental search.")
+
+(defvar search-slow-window-lines 1 "\
+*Number of lines in slow search display windows.
+These are the short windows used during incremental search on slow terminals.
+Negative means put the slow search window at the top (normally it's at bottom)
+and the value is minus the number of lines.")
+
+(defvar search-slow-speed 1200 "\
+*Highest terminal speed at which to use \"slow\" style incremental search.
+This is the style where a one-line window is created to show the line
+that the search has reached.")
+
+(autoload 'isearch "isearch")
+
+(define-key global-map "\C-s" 'isearch-forward)
+(define-key global-map "\C-r" 'isearch-backward)
+(define-key esc-map "\C-s" 'isearch-forward-regexp)
+
+(defun query-replace (from-string to-string &optional arg)
+ "\
+Replace some occurrences of FROM-STRING with TO-STRING.
+As each match is found, the user must type a character saying
+what to do with it. For directions, type \\[help-command] at that time.
+
+Preserves case in each replacement if case-replace and case-fold-search
+are non-nil and FROM-STRING has no uppercase letters.
+Third arg DELIMITED (prefix arg if interactive) non-nil means replace
+only matches surrounded by word boundaries."
+ (interactive "sQuery replace: \nsQuery replace %s with: \nP")
+ (perform-replace from-string to-string t nil arg)
+ (message "Done"))
+
+(defun query-replace-regexp (regexp to-string &optional arg)
+ "\
+Replace some things after point matching REGEXP with TO-STRING.
+As each match is found, the user must type a character saying
+what to do with it. For directions, type \\[help-command] at that time.
+
+Preserves case in each replacement if case-replace and case-fold-search
+are non-nil and REGEXP has no uppercase letters.
+Third arg DELIMITED (prefix arg if interactive) non-nil means replace
+only matches surrounded by word boundaries.
+In TO-STRING, \\& means insert what matched REGEXP,
+and \\=\\<n> means insert what matched <n>th \\(...\\) in REGEXP."
+ (interactive "sQuery replace regexp: \nsQuery replace regexp %s with: \nP")
+ (perform-replace regexp to-string t t arg)
+ (message "Done"))
+
+(defun replace-string (from-string to-string &optional delimited)
+ "\
+Replace occurrences of FROM-STRING with TO-STRING.
+Preserve case in each match if case-replace and case-fold-search
+are non-nil and FROM-STRING has no uppercase letters.
+Third arg DELIMITED (prefix arg if interactive) non-nil means replace
+only matches surrounded by word boundaries."
+ (interactive "sReplace string: \nsReplace string %s with: \nP")
+ (perform-replace from-string to-string nil nil delimited)
+ (message "Done"))
+
+(defun replace-regexp (regexp to-string &optional delimited)
+ "\
+Replace things after point matching REGEXP with TO-STRING.
+Preserve case in each match if case-replace and case-fold-search
+are non-nil and REGEXP has no uppercase letters.
+Third arg DELIMITED (prefix arg if interactive) non-nil means replace
+only matches surrounded by word boundaries.
+In TO-STRING, \\& means insert what matched REGEXP,
+and \\=\\<n> means insert what matched <n>th \\(...\\) in REGEXP."
+ (interactive "sReplace regexp: \nsReplace regexp %s with: \nP")
+ (perform-replace regexp to-string nil t delimited)
+ (message "Done"))
+
+(define-key esc-map "%" 'query-replace)
+
+(autoload 'perform-replace "replace")
+
+(define-key ctl-x-map "\C-a" 'add-mode-abbrev)
+(define-key ctl-x-map "\+" 'add-global-abbrev)
+(define-key ctl-x-map "\C-h" 'inverse-add-mode-abbrev)
+(define-key ctl-x-map "\-" 'inverse-add-global-abbrev)
+(define-key esc-map "'" 'abbrev-prefix-mark)
+(define-key ctl-x-map "'" 'expand-abbrev)
diff --git a/lisp/loadup.el b/lisp/loadup.el
index 9447c74891d..01f74e7ebc3 100644
--- a/lisp/loadup.el
+++ b/lisp/loadup.el
@@ -1,4 +1,4 @@
-;;Load up standardly loaded Lisp files for Emacs.
+;Load up standardly loaded Lisp files for Emacs.
;; This is loaded into a bare Emacs to make a dumpable one.
;; Copyright (C) 1985, 1986 Free Software Foundation, Inc.
@@ -18,6 +18,8 @@
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;;; Disable undo in the *scratch* buffer so it doesn't get dumped.
+(buffer-flush-undo (get-buffer "*scratch*"))
(load "subr")
(garbage-collect)
@@ -62,10 +64,6 @@
(progn
(garbage-collect)
(load "vms-patch")))
-(if (fboundp 'atan) ; preload some constants and
- (progn ; floating pt. functions if
- (garbage-collect) ; we have float support.
- (load "float-sup")))
;If you want additional libraries to be preloaded and their
;doc strings kept in the DOC file rather than in core,
@@ -103,6 +101,10 @@
(load "site-init" t)
(garbage-collect)
+;;; Re-enable undo in the *scratch* buffer, so the dumped Emacs will
+;;; start up that way.
+(buffer-enable-undo (get-buffer "*scratch*"))
+
(if (or (equal (nth 3 command-line-args) "dump")
(equal (nth 4 command-line-args) "dump"))
(if (eq system-type 'vax-vms)
@@ -110,24 +112,32 @@
(message "Dumping data as file temacs.dump")
(dump-emacs "temacs.dump" "temacs")
(kill-emacs))
- (let ((name (concat "emacs-" emacs-version)))
- (while (string-match "[^-+_.a-zA-Z0-9]+" name)
- (setq name (concat (downcase (substring name 0 (match-beginning 0)))
- "-"
- (substring name (match-end 0)))))
- (message "Dumping under names xemacs and %s" name))
- (condition-case ()
- (delete-file "xemacs")
- (file-error nil))
- (dump-emacs "xemacs" "temacs")
- ;; Recompute NAME now, so that it isn't set when we dump.
- (let ((name (concat "emacs-" emacs-version)))
- (while (string-match "[^-+_.a-zA-Z0-9]+" name)
- (setq name (concat (downcase (substring name 0 (match-beginning 0)))
- "-"
- (substring name (match-end 0)))))
- (add-name-to-file "xemacs" name t))
- (kill-emacs)))
+ (if (fboundp 'dump-emacs-data)
+ ;; Handle the IBM RS/6000, and perhaps eventually other machines.
+ (progn
+ ;; This strange nesting is so that the variable `name'
+ ;; is not bound when the data is dumped.
+ (message "Dumping data as file ../etc/EMACS-DATA")
+ (dump-emacs-data "../etc/EMACS-DATA")
+ (kill-emacs))
+ (let ((name (concat "emacs-" emacs-version)))
+ (while (string-match "[^-+_.a-zA-Z0-9]+" name)
+ (setq name (concat (downcase (substring name 0 (match-beginning 0)))
+ "-"
+ (substring name (match-end 0)))))
+ (message "Dumping under names xemacs and %s" name))
+ (condition-case ()
+ (delete-file "xemacs")
+ (file-error nil))
+ (dump-emacs "xemacs" "temacs")
+ ;; Recompute NAME now, so that it isn't set when we dump.
+ (let ((name (concat "emacs-" emacs-version)))
+ (while (string-match "[^-+_.a-zA-Z0-9]+" name)
+ (setq name (concat (downcase (substring name 0 (match-beginning 0)))
+ "-"
+ (substring name (match-end 0)))))
+ (add-name-to-file "xemacs" name t))
+ (kill-emacs))))
;; Avoid error if user loads some more libraries now.
(setq purify-flag nil)
diff --git a/lisp/lpr.el b/lisp/lpr.el
index 3ae55b2f24a..c2b17f17b92 100644
--- a/lisp/lpr.el
+++ b/lisp/lpr.el
@@ -21,71 +21,52 @@
;(defconst lpr-switches nil
; "*List of strings to pass as extra switch args to lpr when it is invoked.")
-(defvar lpr-command (if (eq system-type 'usg-unix-v)
+(defvar lpr-command (if (memq system-type
+ '(usg-unix-v hpux silicon-graphics-unix))
"lp" "lpr")
"Shell command for printing a file")
-(defvar print-region-function nil
- "Function to call to print the region on a printer.
-See definition of `print-region-1' for calling conventions.")
-
(defun lpr-buffer ()
"Print buffer contents as with Unix command `lpr'.
`lpr-switches' is a list of extra switches (strings) to pass to lpr."
(interactive)
- (print-region-1 (point-min) (point-max) lpr-switches nil))
+ (print-region-1 (point-min) (point-max) lpr-switches))
(defun print-buffer ()
"Print buffer contents as with Unix command `lpr -p'.
`lpr-switches' is a list of extra switches (strings) to pass to lpr."
(interactive)
- (print-region-1 (point-min) (point-max) lpr-switches t))
+ (print-region-1 (point-min) (point-max) (cons "-p" lpr-switches)))
(defun lpr-region (start end)
"Print region contents as with Unix command `lpr'.
`lpr-switches' is a list of extra switches (strings) to pass to lpr."
(interactive "r")
- (print-region-1 start end lpr-switches nil))
+ (print-region-1 start end lpr-switches))
(defun print-region (start end)
"Print region contents as with Unix command `lpr -p'.
`lpr-switches' is a list of extra switches (strings) to pass to lpr."
(interactive "r")
- (print-region-1 start end lpr-switches t))
+ (print-region-1 start end (cons "-p" lpr-switches)))
-(defun print-region-1 (start end switches page-headers)
+(defun print-region-1 (start end switches)
(let ((name (concat (buffer-name) " Emacs buffer"))
(width tab-width))
(save-excursion
- (message "Spooling...")
- (if (/= tab-width 8)
- (progn
- (print-region-new-buffer start end)
- (setq tab-width width)
- (untabify (point-min) (point-max))))
- (if page-headers
- (if (eq system-type 'usg-unix-v)
- (progn
- (print-region-new-buffer)
- (call-process-region start end "pr" t t nil))
- ;; On BSD, use an option to get page headers.
- (setq switches (cons "-p" switches))))
- (apply (or print-region-function 'call-process-region)
- (nconc (list start end lpr-command
- nil nil nil)
- (nconc (and (eq system-type 'berkeley-unix)
- (list "-J" name "-T" name))
- switches)))
- (message "Spooling...done"))))
-
-;; This function copies the text between start and end
-;; into a new buffer, makes that buffer current,
-;; and sets start and end to the buffer bounds.
-;; start and end are used free.
-(defun print-region-new-buffer ()
- (or (string= (buffer-name) " *spool temp*")
- (let ((oldbuf (current-buffer)))
- (set-buffer (get-buffer-create " *spool temp*"))
- (widen) (erase-buffer)
- (insert-buffer-substring oldbuf start end)
- (setq start (point-min) end (point-max)))))
+ (message "Spooling...")
+ (if (/= tab-width 8)
+ (let ((oldbuf (current-buffer)))
+ (set-buffer (get-buffer-create " *spool temp*"))
+ (widen) (erase-buffer)
+ (insert-buffer-substring oldbuf start end)
+ (setq tab-width width)
+ (untabify (point-min) (point-max))
+ (setq start (point-min) end (point-max))))
+ (apply 'call-process-region
+ (nconc (list start end lpr-command
+ nil nil nil)
+ (nconc (and (eq system-type 'berkeley-unix)
+ (list "-J" name "-T" name))
+ switches)))
+ (message "Spooling...done"))))
diff --git a/lisp/lpr.elc b/lisp/lpr.elc
new file mode 100644
index 00000000000..efcfac8abd6
--- /dev/null
+++ b/lisp/lpr.elc
Binary files differ
diff --git a/lisp/ls-lisp.el b/lisp/ls-lisp.el
deleted file mode 100644
index 63c1f66e148..00000000000
--- a/lisp/ls-lisp.el
+++ /dev/null
@@ -1,132 +0,0 @@
-;;;; dired-lisp.el - emulate ls completely in Emacs Lisp. $Revision: 1.2 $
-;;;; Copyright (C) 1991 Sebastian Kremer <sk@thp.uni-koeln.de>
-
-;;;; READ THE WARNING BELOW BEFORE USING THIS PROGRAM!
-
-;;;; Useful if you cannot afford to fork Emacs on a real memory UNIX,
-;;;; under VMS, or if you don't have the ls program.
-
-;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;;;; WARNING:
-
-;;;; Sometimes I get an internal Emacs error:
-
-;;;; Signalling: (wrong-type-argument natnump #<EMACS BUG: ILLEGAL
-;;;; DATATYPE (#o37777777727) Save your buffers immediately and please
-;;;; report this bug>)
-
-;;;; Sometimes emacs just crashes with a fatal error.
-
-;;; RESTRICTIONS:
-;;;; Always sorts by name (ls switches are completely ignored for now)
-;;;; Cannot display date of file, displays a fake date "Jan 00 00:00" instead
-;;;; Only numeric uid/gid
-;;;; Loading ange-ftp breaks it
-
-;;;; It is surprisingly fast, though!
-
-;;;; TODO:
-;;;; Recognize at least some ls switches: l R g F i
-
-(require 'dired) ; we will redefine this function:
-
-(defun dired-ls (file &optional switches wildcard full-directory-p)
- "dired-lisp.el's version of dired-ls."
-; "Insert ls output of FILE, optionally formatted with SWITCHES.
-;Optional third arg WILDCARD means treat FILE as shell wildcard.
-;Optional fourth arg FULL-DIRECTORY-P means file is a directory and
-;switches do not contain `d'.
-;
-;SWITCHES default to dired-listing-switches."
- (or switches (setq switches dired-listing-switches))
- (if wildcard
- (error "Cannot handle wildcards in lisp emulation of `ls'."))
- (if full-directory-p
- (let* ((dir (file-name-as-directory file))
- (start (length dir))
- (sum 0))
- (insert "total \007\n") ; fill in afterwards
- (insert
- (mapconcat
- (function (lambda (short)
- (let* ((fil (concat dir short))
- (attr (file-attributes fil))
- (size (nth 7 attr)))
- ;;(debug)
- (setq sum (+ sum size))
- (dired-lisp-format
- ;;(file-name-nondirectory fil)
- ;;(dired-make-relative fil dir)
- ;;(substring fil start)
- short
- attr
- switches))))
- (directory-files dir)
- ""))
- (save-excursion
- (search-backward "total \007")
- (goto-char (match-end 0))
- (delete-char -1)
- (insert (format "%d" sum)))
- )
- ;; if not full-directory-p, FILE *must not* end in /, as
- ;; file-attributes will not recognize a symlink to a directory
- ;; must make it a relative filename as ls does:
- (setq file (file-name-nondirectory file))
- (insert (dired-lisp-format file (file-attributes file) switches)))
- )
-
-(defun dired-lisp-format (file-name file-attr &optional switches)
- (let ((file-type (nth 0 file-attr)))
- (concat (nth 8 file-attr) ; permission bits
- " "
- (dired-lisp-pad (nth 1 file-attr) -3) ; no. of links
- ;; numeric uid/gid are more confusing than helpful
- ;; Emacs should be able to make strings of them
- " " (dired-lisp-pad (nth 2 file-attr) -6) ; uid
- " " (dired-lisp-pad (nth 3 file-attr) -6) ; gid
- " "
- (dired-lisp-pad (nth 7 file-attr) -8) ; size in bytes
- ;; file-attributes's time is in a braindead format
- ;; Emacs should have a ctime function
- " " "Jan 00 00:00 " ; fake time
- file-name
- (if (stringp file-type) ; is a symbolic link
- (concat " -> " file-type)
- "")
- "\n"
- )))
-
-;; format should really do anything printf can!!
-(defun dired-lisp-pad (arg width &optional pad-char)
- "Pad ARG to WIDTH, from left if WIDTH < 0.
-Non-nil third arg optional PAD-CHAR defaults to a space."
- (or pad-char (setq pad-char ?\040))
- (if (integerp arg)
- (setq arg (int-to-string arg)))
- (let (l pad reverse)
- (if (< width 0)
- (setq reverse t
- width (- width)))
- (setq l (length arg)
- pad (- width l))
- (if (> pad 0)
- (if reverse
- (concat (make-string pad pad-char) arg)
- (concat arg (make-string pad pad-char)))
- arg)))
diff --git a/lisp/macros.el b/lisp/macros.el
index b318ff8eefb..bd2bd9ce449 100644
--- a/lisp/macros.el
+++ b/lisp/macros.el
@@ -20,9 +20,10 @@
(defun name-last-kbd-macro (symbol)
"Assign a name to the last keyboard macro defined.
-Argument SYMBOL is the name to define.
+One arg, a symbol, which is the name to define.
The symbol's function definition becomes the keyboard macro string.
-Such a \"function\" cannot be called from Lisp, but it is a valid editor command."
+Such a \"function\" cannot be called from Lisp, but it is a valid command
+definition for the editor command loop."
(interactive "SName for last kbd macro: ")
(or last-kbd-macro
(error "No keyboard macro defined"))
@@ -34,14 +35,14 @@ Such a \"function\" cannot be called from Lisp, but it is a valid editor command
(defun insert-kbd-macro (macroname &optional keys)
"Insert in buffer the definition of kbd macro NAME, as Lisp code.
-Optional second arg KEYS means also record the keys it is on
-(this is the prefix argument, when calling interactively).
+Second argument KEYS non-nil means also record the keys it is on.
+ (This is the prefix argument, when calling interactively.)
-This Lisp code will, when executed, define the kbd macro with the same
-definition it has now. If you say to record the keys, the Lisp code
-will also rebind those keys to the macro. Only global key bindings
-are recorded since executing this Lisp code always makes global
-bindings.
+This Lisp code will, when executed, define the kbd macro with the
+same definition it has now. If you say to record the keys,
+the Lisp code will also rebind those keys to the macro.
+Only global key bindings are recorded since executing this Lisp code
+always makes global bindings.
To save a kbd macro, visit a file of Lisp code such as your ~/.emacs,
use this command, and then save the file."
@@ -63,15 +64,15 @@ use this command, and then save the file."
(defun kbd-macro-query (flag)
"Query user during kbd macro execution.
- With prefix argument, enters recursive edit, reading keyboard
-commands even within a kbd macro. You can give different commands
-each time the macro executes.
- Without prefix argument, reads a character. Your options are:
-Space -- execute the rest of the macro.
-DEL -- skip the rest of the macro; start next repetition.
-C-d -- skip rest of the macro and don't repeat it any more.
-C-r -- enter a recursive edit, then on exit ask again for a character
-C-l -- redisplay screen and ask again."
+With prefix argument, enters recursive edit,
+ reading keyboard commands even within a kbd macro.
+ You can give different commands each time the macro executes.
+Without prefix argument, reads a character. Your options are:
+ Space -- execute the rest of the macro.
+ DEL -- skip the rest of the macro; start next repetition.
+ C-d -- skip rest of the macro and don't repeat it any more.
+ C-r -- enter a recursive edit, then on exit ask again for a character
+ C-l -- redisplay screen and ask again."
(interactive "P")
(or executing-macro
defining-kbd-macro
diff --git a/lisp/macros.elc b/lisp/macros.elc
new file mode 100644
index 00000000000..9410bfd5dd9
--- /dev/null
+++ b/lisp/macros.elc
Binary files differ
diff --git a/lisp/mail/mail-utils.el b/lisp/mail-utils.el
index a9eafa4b5e3..402b72eccdd 100644
--- a/lisp/mail/mail-utils.el
+++ b/lisp/mail-utils.el
@@ -23,8 +23,8 @@
;; should be in loaddefs
(defvar mail-use-rfc822 nil
"*If non-nil, use a full, hairy RFC822 parser on mail addresses.
-Otherwise, (the default) use a smaller, somewhat faster, and
-often correct parser.")
+Otherwise, (the default) use a smaller, somewhat faster and
+often-correct parser.")
(defun mail-string-delete (string start end)
"Returns a string containing all of STRING except the part
@@ -37,64 +37,76 @@ from START (inclusive) to END (exclusive)."
"Delete comments and quoted strings in an address list ADDRESS.
Also delete leading/trailing whitespace and replace FOO <BAR> with just BAR.
Return a modified address list."
- (if mail-use-rfc822
- (progn (require 'rfc822)
- (mapconcat 'identity (rfc822-addresses address) ", "))
- (let (pos)
- (string-match "\\`[ \t\n]*" address)
- ;; strip surrounding whitespace
- (setq address (substring address
- (match-end 0)
- (string-match "[ \t\n]*\\'" address
- (match-end 0))))
+ (if (null address)
+ nil
+ (if mail-use-rfc822
+ (progn (require 'rfc822)
+ (mapconcat 'identity (rfc822-addresses address) ", "))
+ (let (pos)
+ ;; Strip rfc822 comments (within parens).
+ ;; Understand properly the effect of backslashes and string quotes.
+ (let (instring (depth 0) start)
+ (setq pos -1)
+ (while pos
+ (cond ((< pos 0))
+ ((= (aref address pos) ?\\)
+ (setq pos (1+ pos)))
+ ((= (aref address pos) ?\")
+ (setq instring (not instring)))
+ (instring nil)
+ ((= (aref address pos) ?\()
+ (if (= depth 0) (setq start pos))
+ (setq depth (1+ depth)))
+ ((= (aref address pos) ?\))
+ (setq depth (1- depth))
+ (if (= depth 0)
+ (setq address (mail-string-delete address start (1+ pos))
+ pos (1- start)))))
+ (setq pos (string-match "[\"\\()]" address (1+ pos)))))
- ;; Detect nested comments.
- (if (string-match "[ \t]*(\\([^)\"\\]\\|\\\\.\\|\\\\\n\\)*(" address)
- ;; Strip nested comments.
- (save-excursion
- (set-buffer (get-buffer-create " *temp*"))
- (erase-buffer)
- (insert address)
- (set-syntax-table lisp-mode-syntax-table)
- (goto-char 1)
- (while (search-forward "(" nil t)
- (forward-char -1)
- (skip-chars-backward " \t")
- (delete-region (point)
- (save-excursion (forward-sexp 1) (point))))
- (setq address (buffer-string))
- (erase-buffer))
- ;; Strip non-nested comments an easier way.
- (while (setq pos (string-match
- ;; This doesn't hack rfc822 nested comments
- ;; `(xyzzy (foo) whinge)' properly. Big deal.
- "[ \t]*(\\([^)\"\\]\\|\\\\.\\|\\\\\n\\)*)"
- address))
- (setq address
- (mail-string-delete address
- pos (match-end 0)))))
+ ;; strip surrounding whitespace
+ (string-match "\\`[ \t\n]*" address)
+ (setq address (substring address
+ (match-end 0)
+ (string-match "[ \t\n]*\\'" address
+ (match-end 0))))
- ;; strip `quoted' names (This is supposed to hack `"Foo Bar" <bar@host>')
- (setq pos 0)
- (while (setq pos (string-match
- "[ \t]*\"\\([^\"\\]\\|\\\\.\\|\\\\\n\\)*\"[ \t\n]*"
- address pos))
- ;; If the next thing is "@", we have "foo bar"@host. Leave it.
- (if (and (> (length address) (match-end 0))
- (= (aref address (match-end 0)) ?@))
- (setq pos (match-end 0))
- (setq address
- (mail-string-delete address
- pos (match-end 0)))))
- ;; Retain only part of address in <> delims, if there is such a thing.
- (while (setq pos (string-match "\\(,\\|\\`\\)[^,]*<\\([^>,]*>\\)"
- address))
- (let ((junk-beg (match-end 1))
- (junk-end (match-beginning 2))
- (close (match-end 0)))
- (setq address (mail-string-delete address (1- close) close))
- (setq address (mail-string-delete address junk-beg junk-end))))
- address)))
+ ;; Strip whitespace before commas.
+ (let (instring)
+ (setq pos -1)
+ (while pos
+ (cond ((< pos 0))
+ ((= (aref address pos) ?\\)
+ (setq pos (1+ pos)))
+ ((= (aref address pos) ?\")
+ (setq instring (not instring)))
+ (instring nil)
+ ((eq (string-match "[ \t]*," address pos) pos)
+ (setq address (mail-string-delete address pos
+ (1- (match-end 0))))))
+ (setq pos (string-match "[ \t,\"\\]" address (1+ pos)))))
+
+ ;; strip `quoted' names (This is supposed to hack `"Foo Bar" <bar@host>')
+ (setq pos 0)
+ (while (setq pos (string-match
+ "[ \t]*\"\\([^\"\\]\\|\\\\.\\|\\\\\n\\)*\"[ \t\n]*"
+ address pos))
+ ;; If the next thing is "@", we have "foo bar"@host. Leave it.
+ (if (and (> (length address) (match-end 0))
+ (= (aref address (match-end 0)) ?@))
+ (setq pos (match-end 0))
+ (setq address
+ (mail-string-delete address
+ pos (match-end 0)))))
+ ;; Retain only part of address in <> delims, if there is such a thing.
+ (while (setq pos (string-match "\\(,\\|\\`\\)[^,]*<\\([^>,]*>\\)"
+ address))
+ (let ((junk-beg (match-end 1))
+ (junk-end (match-beginning 2))
+ (close (match-end 0)))
+ (setq address (mail-string-delete address (1- close) close))
+ (setq address (mail-string-delete address junk-beg junk-end))))
+ address))))
(or (and (boundp 'rmail-default-dont-reply-to-names)
(not (null rmail-default-dont-reply-to-names)))
@@ -103,14 +115,16 @@ Return a modified address list."
; rmail-dont-reply-to-names is defined in loaddefs
(defun rmail-dont-reply-to (userids)
"Returns string of mail addresses USERIDS sans any recipients
-that start with matches for `rmail-dont-reply-to-names'.
+that start with matches for rmail-dont-reply-to-names.
Usenet paths ending in an element that matches are removed also."
(if (null rmail-dont-reply-to-names)
(setq rmail-dont-reply-to-names
(concat (if rmail-default-dont-reply-to-names
(concat rmail-default-dont-reply-to-names "\\|")
"")
- (concat (regexp-quote (user-original-login-name))
+ (concat (regexp-quote
+ (or (getenv "USER") (getenv "LOGNAME")
+ (user-login-name)))
"\\>"))))
(let ((match (concat "\\(^\\|,\\)[ \t\n]*\\([^,\n]*!\\|\\)\\("
rmail-dont-reply-to-names
@@ -135,10 +149,10 @@ Usenet paths ending in an element that matches are removed also."
userids)))
(defun mail-fetch-field (field-name &optional last all)
- "Return the value of the header field FIELD-NAME.
+ "Return the value of the header field FIELD.
The buffer is expected to be narrowed to just the headers of the message.
-If second arg LAST is non-nil, use the last such field if there are several.
-If third arg ALL is non-nil, concatenate all such fields with commas between."
+If 2nd arg LAST is non-nil, use the last such field if there are several.
+If 3rd arg ALL is non-nil, concatenate all such fields, with commas between."
(save-excursion
(goto-char (point-min))
(let ((case-fold-search t)
diff --git a/lisp/mail-utils.elc b/lisp/mail-utils.elc
new file mode 100644
index 00000000000..5ef56786ed7
--- /dev/null
+++ b/lisp/mail-utils.elc
Binary files differ
diff --git a/lisp/mail/rmailout.el b/lisp/mail/rmailout.el
deleted file mode 100644
index a4018b5cf52..00000000000
--- a/lisp/mail/rmailout.el
+++ /dev/null
@@ -1,182 +0,0 @@
-;; "RMAIL" mail reader for Emacs: output message to a file.
-;; Copyright (C) 1985, 1987 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-
-;; Temporary until Emacs always has this variable.
-(defvar rmail-delete-after-output nil
- "*Non-nil means automatically delete a message that is copied to a file.")
-
-(defvar rmail-output-file-alist nil
- "*Alist matching regexps to suggested output Rmail files.
-This is a list of elements of the form (REGEXP . FILENAME).")
-
-(defun rmail-output-to-rmail-file (count file-name)
- "Append the current message to an Rmail file named FILE-NAME.
-If the file does not exist, ask if it should be created.
-If file is being visited, the message is appended to the Emacs
-buffer visiting that file.
-A prefix argument N says to output N consecutive messages
-starting with the current one. Deleted messages are skipped and don't count."
- (interactive (list (prefix-numeric-value current-prefix-arg)
- (read-file-name
- (concat "Output message to Rmail file: (default "
- (file-name-nondirectory rmail-last-rmail-file)
- ") ")
- (file-name-directory rmail-last-rmail-file)
- (let (answer tail)
- (setq tail rmail-output-file-alist)
- ;; Suggest a file based on a pattern match.
- (while (and tail (not answer))
- (save-excursion
- (goto-char (point-min))
- (if (re-search-forward (car (car tail)) nil t)
- (setq answer (cdr (car tail))))
- (setq tail (cdr tail))))
- ;; If not suggestions, use same file as last time.
- (or answer rmail-last-rmail-file)))))
- (setq file-name
- (expand-file-name file-name
- (file-name-directory rmail-last-rmail-file)))
- (setq rmail-last-rmail-file file-name)
- (rmail-maybe-set-message-counters)
- (or (get-file-buffer file-name)
- (file-exists-p file-name)
- (if (yes-or-no-p
- (concat "\"" file-name "\" does not exist, create it? "))
- (let ((file-buffer (create-file-buffer file-name)))
- (save-excursion
- (set-buffer file-buffer)
- (rmail-insert-rmail-file-header)
- (let ((require-final-newline nil))
- (write-region (point-min) (point-max) file-name t 1)))
- (kill-buffer file-buffer))
- (error "Output file does not exist")))
- (while (> count 0)
- (let (redelete)
- (unwind-protect
- (progn
- (save-restriction
- (widen)
- (if (rmail-message-deleted-p rmail-current-message)
- (progn (setq redelete t)
- (rmail-set-attribute "deleted" nil)))
- ;; Decide whether to append to a file or to an Emacs buffer.
- (save-excursion
- (let ((buf (get-file-buffer file-name))
- (cur (current-buffer))
- (beg (1+ (rmail-msgbeg rmail-current-message)))
- (end (1+ (rmail-msgend rmail-current-message))))
- (if (not buf)
- (append-to-file beg end file-name)
- (if (eq buf (current-buffer))
- (error "Can't output message to same file it's already in"))
- ;; File has been visited, in buffer BUF.
- (set-buffer buf)
- (let ((buffer-read-only nil)
- (msg (and (boundp 'rmail-current-message)
- rmail-current-message)))
- ;; If MSG is non-nil, buffer is in RMAIL mode.
- (if msg
- (progn
- (rmail-maybe-set-message-counters)
- (widen)
- (narrow-to-region (point-max) (point-max))
- (insert-buffer-substring cur beg end)
- (goto-char (point-min))
- (widen)
- (search-backward "\n\^_")
- (narrow-to-region (point) (point-max))
- (rmail-count-new-messages t)
- (rmail-show-message msg))
- ;; Output file not in rmail mode => just insert at the end.
- (narrow-to-region (point-min) (1+ (buffer-size)))
- (goto-char (point-max))
- (insert-buffer-substring cur beg end)))))))
- (rmail-set-attribute "filed" t))
- (if redelete (rmail-set-attribute "deleted" t))))
- (setq count (1- count))
- (if rmail-delete-after-output
- (rmail-delete-forward)
- (if (> count 0)
- (rmail-next-undeleted-message 1)))))
-
-(defun rmail-output (count file-name)
- "Append this message to Unix mail file named FILE-NAME.
-A prefix argument N says to output N consecutive messages
-starting with the current one. Deleted messages are skipped and don't count."
- (interactive
- (list (prefix-numeric-value current-prefix-arg)
- (read-file-name
- (concat "Output message to Unix mail file"
- (if rmail-last-file
- (concat " (default "
- (file-name-nondirectory rmail-last-file)
- "): " )
- ": "))
- (and rmail-last-file (file-name-directory rmail-last-file))
- rmail-last-file)))
- (setq file-name
- (expand-file-name file-name
- (and rmail-last-file
- (file-name-directory rmail-last-file))))
- (setq rmail-last-file file-name)
- (while (> count 0)
- (let ((rmailbuf (current-buffer))
- (tembuf (get-buffer-create " rmail-output"))
- (case-fold-search t))
- (save-excursion
- (set-buffer tembuf)
- (erase-buffer)
- ;; If we can do it, read a little of the file
- ;; to check whether it is an RMAIL file.
- ;; If it is, don't mess it up.
- (if (fboundp 'insert-partial-file-contents)
- (progn
- (insert-partial-file-contents file-name 0 20)
- (if (looking-at "BABYL OPTIONS:\n")
- (error (save-excursion
- (set-buffer rmailbuf)
- (substitute-command-keys
- "File %s is an RMAIL file; use the \\[rmail-output-to-rmail-file] command"))
- file-name))
- (erase-buffer)))
- (insert-buffer-substring rmailbuf)
- (insert "\n")
- (goto-char (point-min))
- (insert "From "
- (mail-strip-quoted-names (or (mail-fetch-field "from")
- (mail-fetch-field "really-from")
- (mail-fetch-field "sender")
- "unknown"))
- " " (current-time-string) "\n")
- ;; ``Quote'' "\nFrom " as "\n>From "
- ;; (note that this isn't really quoting, as there is no requirement
- ;; that "\n[>]+From " be quoted in the same transparent way.)
- (while (search-forward "\nFrom " nil t)
- (forward-char -5)
- (insert ?>))
- (append-to-file (point-min) (point-max) file-name))
- (kill-buffer tembuf))
- (if (equal major-mode 'rmail-mode)
- (rmail-set-attribute "filed" t))
- (setq count (1- count))
- (if rmail-delete-after-output
- (rmail-delete-forward)
- (if (> count 0)
- (rmail-next-undeleted-message 1)))))
diff --git a/lisp/mail/rmailsort.el b/lisp/mail/rmailsort.el
deleted file mode 100644
index e1f01ad2f8f..00000000000
--- a/lisp/mail/rmailsort.el
+++ /dev/null
@@ -1,203 +0,0 @@
-;;; Rmail: sort messages.
-;; Copyright (C) 1990 Masanobu UMEDA
-;; umerin@tc.Nagasaki.GO.JP?
-
-;; This file is part of GNU Emacs.
-
-;; 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.
-
-(provide 'rmailsort)
-(require 'rmail)
-(require 'sort)
-
-;; GNUS compatible key bindings.
-(define-key rmail-mode-map "\C-c\C-s\C-d" 'rmail-sort-by-date)
-(define-key rmail-mode-map "\C-c\C-s\C-s" 'rmail-sort-by-subject)
-(define-key rmail-mode-map "\C-c\C-s\C-a" 'rmail-sort-by-author)
-(define-key rmail-mode-map "\C-c\C-s\C-r" 'rmail-sort-by-recipient)
-(define-key rmail-mode-map "\C-c\C-s\C-c" 'rmail-sort-by-correspondent)
-(define-key rmail-mode-map "\C-c\C-s\C-l" 'rmail-sort-by-size-lines)
-
-(defun rmail-sort-by-date (reverse)
- "Sort messages of current Rmail file by date.
-If prefix argument REVERSE is non-nil, sort them in reverse order."
- (interactive "P")
- (rmail-sort-messages reverse
- (function
- (lambda (msg)
- (rmail-sortable-date-string
- (rmail-fetch-field msg "Date"))))))
-
-(defun rmail-sort-by-subject (reverse)
- "Sort messages of current Rmail file by subject.
-If prefix argument REVERSE is non-nil, sort them in reverse order."
- (interactive "P")
- (rmail-sort-messages reverse
- (function
- (lambda (msg)
- (let ((key (or (rmail-fetch-field msg "Subject") ""))
- (case-fold-search t))
- ;; Remove `Re:'
- (if (string-match "^\\(re:[ \t]+\\)*" key)
- (substring key (match-end 0)) key))))))
-
-(defun rmail-sort-by-author (reverse)
- "Sort messages of current Rmail file by author.
-If prefix argument REVERSE is non-nil, sort them in reverse order."
- (interactive "P")
- (rmail-sort-messages reverse
- (function
- (lambda (msg)
- (mail-strip-quoted-names
- (or (rmail-fetch-field msg "From")
- (rmail-fetch-field msg "Sender") ""))))))
-
-(defun rmail-sort-by-recipient (reverse)
- "Sort messages of current Rmail file by recipient.
-If prefix argument REVERSE is non-nil, sort them in reverse order."
- (interactive "P")
- (rmail-sort-messages reverse
- (function
- (lambda (msg)
- (mail-strip-quoted-names
- (or (rmail-fetch-field msg "To")
- (rmail-fetch-field msg "Apparently-To") "")
- )))))
-
-(defun rmail-sort-by-correspondent (reverse)
- "Sort messages of current Rmail file by other correspondent.
-If prefix argument REVERSE is non-nil, sort them in reverse order."
- (interactive "P")
- (rmail-sort-messages reverse
- (function
- (lambda (msg)
- (rmail-select-correspondent
- msg
- '("From" "Sender" "To" "Apparently-To"))))))
-
-(defun rmail-select-correspondent (msg fields)
- (let ((ans ""))
- (while (and fields (string= ans ""))
- (setq ans
- (rmail-dont-reply-to
- (mail-strip-quoted-names
- (or (rmail-fetch-field msg (car fields)) ""))))
- (setq fields (cdr fields)))
- ans))
-
-(defun rmail-sort-by-size-lines (reverse)
- "Sort messages of current Rmail file by message size.
-If prefix argument REVERSE is non-nil, sort them in reverse order."
- (interactive "P")
- (rmail-sort-messages reverse
- (function
- (lambda (msg)
- (format "%9d"
- (count-lines (rmail-msgbeg msgnum)
- (rmail-msgend msgnum)))))))
-
-
-(defun rmail-sort-messages (reverse keyfunc)
- "Sort messages of current Rmail file.
-1st argument REVERSE is non-nil, sort them in reverse order.
-2nd argument KEYFUNC is called with message number, and should return a key."
- (let ((buffer-read-only nil)
- (sort-lists nil))
- (message "Finding sort keys...")
- (widen)
- (let ((msgnum 1))
- (while (>= rmail-total-messages msgnum)
- (setq sort-lists
- (cons (cons (funcall keyfunc msgnum) ;A sort key.
- (buffer-substring
- (rmail-msgbeg msgnum) (rmail-msgend msgnum)))
- sort-lists))
- (if (zerop (% msgnum 10))
- (message "Finding sort keys...%d" msgnum))
- (setq msgnum (1+ msgnum))))
- (or reverse (setq sort-lists (nreverse sort-lists)))
- (setq sort-lists
- (sort sort-lists
- (function
- (lambda (a b)
- (string-lessp (car a) (car b))))))
- (if reverse (setq sort-lists (nreverse sort-lists)))
- (message "Reordering buffer...")
- (delete-region (rmail-msgbeg 1) (rmail-msgend rmail-total-messages))
- (let ((msgnum 1))
- (while sort-lists
- (insert (cdr (car sort-lists)))
- (if (zerop (% msgnum 10))
- (message "Reordering buffer...%d" msgnum))
- (setq sort-lists (cdr sort-lists))
- (setq msgnum (1+ msgnum))))
- (rmail-set-message-counters)
- (rmail-show-message 1)))
-
-(defun rmail-fetch-field (msg field)
- "Return the value of the header field FIELD of MSG.
-Arguments are MSG and FIELD."
- (let ((next (rmail-msgend msg)))
- (save-restriction
- (goto-char (rmail-msgbeg msg))
- (narrow-to-region (if (search-forward "\n*** EOOH ***\n" next t)
- (point)
- (forward-line 1)
- (point))
- (progn (search-forward "\n\n" nil t) (point)))
- (mail-fetch-field field))))
-
-;; Copy of the function gnus-comparable-date in gnus.el
-
-(defun rmail-sortable-date-string (date)
- "Make sortable string by string-lessp from DATE."
- (let ((month '(("JAN" . " 1")("FEB" . " 2")("MAR" . " 3")
- ("APR" . " 4")("MAY" . " 5")("JUN" . " 6")
- ("JUL" . " 7")("AUG" . " 8")("SEP" . " 9")
- ("OCT" . "10")("NOV" . "11")("DEC" . "12")
- ("JANUARY" . " 1") ("FEBRUARY" . " 2")
- ("MARCH" . " 3") ("APRIL" . " 4")
- ("MAY" . " 5") ("JUNE" . " 6")
- ("JULY" . " 7") ("AUGUST" . " 8")
- ("SEPTEMBER" " 9") ("OCTOBER" . "10")
- ("NOVEMBER" "11") ("DECEMBER" . "12")))
- (date (or date "")))
- ;; Can understand the following styles:
- ;; (1) 14 Apr 89 03:20:12 GMT
- ;; (2) Fri, 17 Mar 89 4:01:33 GMT
- (if (string-match
- "\\([0-9]+\\) +\\([^ ,]+\\) +\\([0-9]+\\) +\\([0-9:]+\\)" date)
- (concat
- ;; Year
- (rmail-date-full-year
- (substring date (match-beginning 3) (match-end 3)))
- ;; Month
- (cdr
- (assoc
- (upcase (substring date (match-beginning 2) (match-end 2))) month))
- ;; Day
- (format "%2d" (string-to-int
- (substring date
- (match-beginning 1) (match-end 1))))
- ;; Time
- (substring date (match-beginning 4) (match-end 4)))
- ;; Cannot understand DATE string.
- date)))
-
-(defun rmail-date-full-year (year-string)
- (if (<= (length year-string) 2)
- (concat "19" year-string)
- year-string))
diff --git a/lisp/mail/mailalias.el b/lisp/mailalias.el
index 792514330fb..bfeb7c78ba7 100644
--- a/lisp/mail/mailalias.el
+++ b/lisp/mailalias.el
@@ -20,18 +20,16 @@
;; Called from sendmail-send-it, or similar functions,
;; only if some mail aliases are defined.
-(defun expand-mail-aliases (beg end &optional exclude)
+(defun expand-mail-aliases (beg end)
"Expand all mail aliases in suitable header fields found between BEG and END.
-Suitable header fields are `To', `Cc' and `Bcc' and their `Resent-' variants.
-Optional second arg EXCLUDE may be a regular expression defining text to be
-removed from alias expansions."
+Suitable header fields are To, Cc and Bcc."
(if (eq mail-aliases t)
(progn (setq mail-aliases nil) (build-mail-aliases)))
(goto-char beg)
(setq end (set-marker (make-marker) end))
(let ((case-fold-search nil))
(while (let ((case-fold-search t))
- (re-search-forward "^\\(to\\|cc\\|bcc\\|resent-to\\|resent-cc\\|resent-bcc\\):" end t))
+ (re-search-forward "^\\(to\\|cc\\|bcc\\):" end t))
(skip-chars-forward " \t")
(let ((beg1 (point))
end1 pos epos seplen
@@ -71,14 +69,6 @@ removed from alias expansions."
;; then rescan the expansion for more aliases.
(goto-char pos)
(insert translation)
- (if exclude
- (let ((regexp
- (concat "\\b\\(" exclude "\\)\\b"))
- (end (point-marker)))
- (goto-char pos)
- (while (re-search-forward regexp end t)
- (replace-match ""))
- (goto-char end)))
(delete-region (point) (+ (point) (- epos pos)))
(goto-char pos))
;; Name is not an alias. Skip to start of next name.
@@ -89,14 +79,14 @@ removed from alias expansions."
;; Called by mail-setup, or similar functions, only if ~/.mailrc exists.
(defun build-mail-aliases (&optional file)
- "Read mail aliases from ~/.mailrc and set `mail-aliases'."
+ "Read mail aliases from ~/.mailrc and set mail-aliases."
(setq file (expand-file-name (or file "~/.mailrc")))
(let ((buffer nil)
(obuf (current-buffer)))
(unwind-protect
(progn
(setq buffer (generate-new-buffer "mailrc"))
- (buffer-disable-undo buffer)
+ (buffer-flush-undo buffer)
(set-buffer buffer)
(cond ((get-file-buffer file)
(insert (save-excursion
@@ -131,9 +121,7 @@ removed from alias expansions."
;; Always autoloadable in case the user wants to define aliases
;; interactively or in .emacs.
(defun define-mail-alias (name definition)
- "Define NAME as a mail alias that translates to DEFINITION.
-This means that sending a message to NAME will actually send to DEFINITION.
-DEFINITION can be one or more mail addresses separated by commas."
+ "Define NAME as a mail-alias that translates to DEFINITION."
(interactive "sDefine mail alias: \nsDefine %s as mail alias for: ")
;; Read the defaults first, if we have not done so.
(if (eq mail-aliases t)
diff --git a/lisp/mailalias.elc b/lisp/mailalias.elc
new file mode 100644
index 00000000000..1c79288dadd
--- /dev/null
+++ b/lisp/mailalias.elc
Binary files differ
diff --git a/lisp/mail/mailpost.el b/lisp/mailpost.el
index 326d5092575..0a7c4e0a1d1 100644
--- a/lisp/mail/mailpost.el
+++ b/lisp/mailpost.el
@@ -13,9 +13,9 @@
;; (setq send-mail-function 'post-mail-send-it)
(defun post-mail-send-it ()
- "The MH -post interface for `rmail-mail' to call.
-To use it, include \"(setq send-mail-function 'post-mail-send-it)\" in
-site-init."
+ "\
+the MH -post interface for rmail-mail to call.
+to use it, include (setq send-mail-function 'post-mail-send-it) in site-init."
(let ((errbuf (if mail-interactive
(generate-new-buffer " post-mail errors")
0))
diff --git a/lisp/makesum.elc b/lisp/makesum.elc
new file mode 100644
index 00000000000..39785642e47
--- /dev/null
+++ b/lisp/makesum.elc
Binary files differ
diff --git a/lisp/man.el b/lisp/man.el
index a663373dea4..18407e44289 100644
--- a/lisp/man.el
+++ b/lisp/man.el
@@ -20,18 +20,16 @@
(defun manual-entry (topic &optional section)
"Display the Unix manual entry for TOPIC.
TOPIC is either the title of the entry, or has the form TITLE(SECTION)
-where SECTION is the desired section of the manual, as in \"tty(4)\"."
+where SECTION is the desired section of the manual, as in `tty(4)'."
(interactive "sManual entry (topic): ")
- (if (= (length topic) 0)
- (error "Must specify topic"))
(if (and (null section)
(string-match "\\`[ \t]*\\([^( \t]+\\)[ \t]*(\\(.+\\))[ \t]*\\'" topic))
(setq section (substring topic (match-beginning 2)
(match-end 2))
topic (substring topic (match-beginning 1)
(match-end 1))))
- (with-output-to-temp-buffer (concat "*" topic " Manual Entry*")
- (buffer-disable-undo standard-output)
+ (with-output-to-temp-buffer "*Manual Entry*"
+ (buffer-flush-undo standard-output)
(save-excursion
(set-buffer standard-output)
(message "Looking for formatted entry for %s%s..."
@@ -89,28 +87,11 @@ where SECTION is the desired section of the manual, as in \"tty(4)\"."
(message "Cleaning manual entry for %s..." topic)
(nuke-nroff-bs)
(set-buffer-modified-p nil)
- (setq buffer-read-only t)
- (view-mode nil 'bury-buffer)
(message ""))))
-;; Hint: BS stands for more things than "back space"
+;; Hint: BS stands form more things than "back space"
(defun nuke-nroff-bs ()
(interactive "*")
- ;; Nuke headers: "MORE(1) UNIX Programmer's Manual MORE(1)"
- ;; We expext to find a footer just before the header except at the beginning.
- (goto-char (point-min))
- (while (re-search-forward "^ *\\([A-Za-z][-_.A-Za-z0-9]*([0-9A-Z]+)\\).*\\1$" nil t)
- (let (start end)
- ;; Put START and END around footer and header and garbage blank lines.
- ;; Fixed line counts are risky, but allow us to preserve
- ;; significant blank lines.
- (setq start (save-excursion (forward-line -10) (point)))
- (setq end (save-excursion (forward-line 4) (point)))
- (delete-region start end)))
- ;; Catch the final footer.
- (goto-char (point-max))
- (delete-region (point) (save-excursion (forward-line -7) (point)))
-
;; Nuke underlining and overstriking (only by the same letter)
(goto-char (point-min))
(while (search-forward "\b" nil t)
@@ -119,9 +100,6 @@ where SECTION is the desired section of the manual, as in \"tty(4)\"."
(cond ((= preceding following)
;; x\bx
(delete-char -2))
- ((and (= preceding ?o) (= following ?\+))
- ;; o\b+
- (delete-char -2))
((= preceding ?\_)
;; _\b
(delete-char -2))
@@ -129,10 +107,28 @@ where SECTION is the desired section of the manual, as in \"tty(4)\"."
;; \b_
(delete-region (1- (point)) (1+ (point)))))))
- ;; Zap ESC7, ESC8, and ESC9.
- ;; This is for Sun man pages like "man 1 csh"
+ ;; Nuke headers: "MORE(1) UNIX Programmer's Manual MORE(1)"
+ (goto-char (point-min))
+ (while (re-search-forward "^ *\\([A-Za-z][-_A-Za-z0-9]*([0-9A-Z]+)\\).*\\1$" nil t)
+ (replace-match ""))
+
+ ;; Nuke footers: "Printed 12/3/85 27 April 1981 1"
+ ;; Sun appear to be on drugz:
+ ;; "Sun Release 3.0B Last change: 1 February 1985 1"
+ ;; HP are even worse!
+ ;; " Hewlett-Packard -1- (printed 12/31/99)" FMHWA12ID!!
+ ;; System V (well WICATs anyway):
+ ;; "Page 1 (printed 7/24/85)"
+ ;; Who is administering PCP to these corporate bozos?
(goto-char (point-min))
- (while (re-search-forward "\e[789]" nil t)
+ (while (re-search-forward
+ (cond ((eq system-type 'hpux)
+ "^[ \t]*Hewlett-Packard\\(\\| Company\\)[ \t]*- [0-9]* -.*$")
+ ((eq system-type 'usg-unix-v)
+ "^ *Page [0-9]*.*(printed [0-9/]*)$")
+ (t
+ "^\\(Printed\\|Sun Release\\) [0-9].*[0-9]$"))
+ nil t)
(replace-match ""))
;; Crunch blank lines
diff --git a/lisp/man.elc b/lisp/man.elc
new file mode 100644
index 00000000000..914039f49d4
--- /dev/null
+++ b/lisp/man.elc
Binary files differ
diff --git a/lisp/medit.el b/lisp/medit.el
index d42e67a26a3..4a37d8622d5 100644
--- a/lisp/medit.el
+++ b/lisp/medit.el
@@ -24,7 +24,7 @@
(require 'mim-mode)
-(defconst medit-zap-file (concat "/tmp/" (user-login-name) ".medit.mud")
+(defconst medit-zap-file (concat "/tmp/" (getenv "USER") ".medit.mud")
"File name for data sent to MDL by Medit.")
(defconst medit-buffer "*MEDIT*"
"Name of buffer in which Medit accumulates data to send to MDL.")
@@ -92,7 +92,7 @@ Optionally, offers to save changed files."
(defconst medit-mode-map nil)
(if (not medit-mode-map)
(progn
- (setq medit-mode-map (copy-keymap mim-mode-map))
+ (setq medit-mode-map (copy-alist mim-mode-map))
(define-key medit-mode-map "\e\z" 'medit-save-define)
(define-key medit-mode-map "\e\^z" 'medit-save-buffer)
(define-key medit-mode-map "\^xz" 'medit-goto-mdl)
diff --git a/lisp/medit.elc b/lisp/medit.elc
new file mode 100644
index 00000000000..8e803366f33
--- /dev/null
+++ b/lisp/medit.elc
Binary files differ
diff --git a/lisp/play/meese.el b/lisp/meese.el
index 5ba9dfd2ad2..5ba9dfd2ad2 100644
--- a/lisp/play/meese.el
+++ b/lisp/meese.el
diff --git a/lisp/mh-e.el b/lisp/mh-e.el
new file mode 100644
index 00000000000..16a2490e414
--- /dev/null
+++ b/lisp/mh-e.el
@@ -0,0 +1,2910 @@
+;;; mh-e.el (Version: 3.8 for GNU Emacs Version 18 and MH.5 and MH.6)
+
+(defvar mh-e-RCS-id)
+(setq mh-e-RCS-id "$Header: mh-e.el,v 3.5 92/01/21 11:21:59 gildea Exp $")
+(setq mh-e-time-stamp "92/01/21 10:59:18 gildea")
+(provide 'mh-e)
+
+;;; Copyright (c) 1985,1986,1987,1988,1990,1992 Free Software Foundation
+;;; Maintainer: Stephen Gildea <gildea@lcs.mit.edu>
+;;; Please send suggestions and corrections to the above address.
+;;;
+;;; This file contains mh-e, a GNU Emacs front end to the MH mail system.
+
+;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+;;; Original version for Gosling emacs by Brian Reid, Stanford, 1982.
+;;; Modified by James Larus, BBN, July 1984 and UCB, 1984 & 1985.
+;;; Rewritten for GNU Emacs, James Larus 1985. larus@ginger.berkeley.edu
+;;; Modified by Stephen Gildea, BBN, 1988, and MIT, 1990. gildea@lcs.mit.edu
+
+
+;;; NB. MH must have been compiled with the MHE compiler flag or several
+;;; features necessary mh-e will be missing from MH commands, specifically
+;;; the -build switch to repl and forw.
+
+;;; HOW TO USE:
+;;; M-x mh-rmail to read mail. Type C-h m there for a list of commands.
+;;; C-u M-x mh-rmail to visit any folder.
+;;; M-x mh-smail to send mail. From within the mail reader, "m" works, too.
+;;; Your .emacs might benefit from these bindings:
+;;; (global-set-key "\C-xm" 'mh-smail)
+;;; (global-set-key "\C-x4m" 'mh-smail-other-window)
+;;; (global-set-key "\C-xr" 'mh-rmail) ;clobbers copy-rectangle-to-register
+
+
+
+;;; Constants:
+
+;;; Set for local environment:
+;;;* These are now in paths.el.
+;;;(defvar mh-progs "/usr/new/mh/" "Directory containing MH commands.")
+;;;(defvar mh-lib "/usr/new/lib/mh/" "Directory of MH library.")
+
+(defvar mh-redist-full-contents nil
+ "Non-nil if the `dist' command needs whole letter for redistribution.
+This is the case when `send' is compiled with the BERK option.")
+
+
+;;; Hooks:
+
+(defvar mh-folder-mode-hook nil
+ "Invoked in `mh-folder mode' on a new folder.")
+
+(defvar mh-letter-mode-hook nil
+ "Invoked in `mh-letter-mode' on a new letter.")
+
+(defvar mh-compose-letter-function nil
+ "Invoked in `mh-compose-and-send-mail' on a draft letter.
+It is passed three arguments: TO recipients, SUBJECT, and CC recipients.")
+
+(defvar mh-before-send-letter-hook nil
+ "Invoked at the beginning of the \\[mh-send-letter] command.")
+
+(defvar mh-inc-folder-hook nil
+ "Invoked after incorporating mail into a folder with \\[mh-inc-folder].")
+
+(defvar mh-before-quit-hook nil
+ "Invoked by \\[mh-quit] before quitting mh-e. See also mh-quit-hook")
+
+(defvar mh-quit-hook nil
+ "Invoked after quitting mh-e by \\[mh-quit]. See also mh-before-quit-hook")
+
+
+(defvar mh-ins-string nil
+ "Temporarily set by `mh-insert-prefix' prior to running `mh-yank-hooks'.")
+
+(defvar mh-yank-hooks
+ '(lambda ()
+ (save-excursion
+ (goto-char (point))
+ (or (bolp) (forward-line 1))
+ (while (< (point) (mark))
+ (insert mh-ins-string)
+ (forward-line 1))))
+ "Hook to run citation function.
+Expects POINT and MARK to be set to the region to cite.")
+
+
+;;; Personal preferences:
+
+(defvar mh-clean-message-header nil
+ "*Non-nil means clean headers of messages that are displayed or inserted.
+The variables `mh-visible-headers' and `mh-invisible-headers' control what
+is removed.")
+
+(defvar mh-visible-headers nil
+ "*If non-nil, contains a regexp specifying the headers to keep when cleaning.
+Only used if `mh-clean-message-header' is non-nil. Setting this variable
+overrides `mh-invisible-headers'.")
+
+(defvar mhl-formfile nil
+ "*Name of format file to be used by mhl to show messages.
+A value of T means use the default format file.
+Nil means don't use mhl to format messages.")
+
+(defvar mh-lpr-command-format "lpr -p -J '%s'"
+ "*Format for Unix command that prints a message.
+The string should be a Unix command line, with the string '%s' where
+the job's name (folder and message number) should appear. The message text
+is piped to this command.")
+
+(defvar mh-print-background nil
+ "*Print messages in the background if non-nil.
+WARNING: do not delete the messages until printing is finished;
+otherwise, your output may be truncated.")
+
+(defvar mh-summary-height 4
+ "*Number of lines in summary window (including the mode line).")
+
+(defvar mh-recenter-summary-p nil
+ "*Recenter summary window when the show window is toggled off if non-nil.")
+
+(defvar mh-ins-buf-prefix "> "
+ "*String to put before each non-blank line of a yanked or inserted message.
+Used when the message is inserted in an outgoing letter.")
+
+(defvar mh-do-not-confirm nil
+ "*Non-nil means do not prompt for confirmation before some commands.
+Only affects certain innocuous commands.")
+
+(defvar mh-bury-show-buffer t
+ "*Non-nil means that the displayed show buffer for a folder is buried.")
+
+(defvar mh-delete-yanked-msg-window nil
+ "*Controls window display when a message is yanked by \\[mh-yank-cur-msg].
+If non-nil, yanking the current message into a draft letter deletes any
+windows displaying the message.")
+
+(defvar mh-yank-from-start-of-msg t
+ "*Controls which part of a message is yanked by \\[mh-yank-cur-msg].
+If non-nil, include the entire message. If the symbol `body', then yank the
+message minus the header. If nil, yank only the portion of the message
+following the point. If the show buffer has a region, this variable is
+ignored.")
+
+(defvar mh-reply-default-reply-to nil
+ "*Sets the person or persons to whom a reply will be sent.
+If nil, prompt for recipient. If non-nil, then \\[mh-reply] will use this
+value and it should be one of \"from\", \"to\", or \"cc\".")
+
+(defvar mh-recursive-folders nil
+ "*If non-nil, then commands which operate on folders do so recursively.")
+
+(defvar mh-unshar-default-directory ""
+ "*Default for directory name prompted for by mh-unshar-msg.")
+
+
+;;; Parameterize mh-e to work with different scan formats. The defaults work
+;;; with the standard MH scan listings.
+
+(defvar mh-cmd-note 4
+ "Offset to insert notation.")
+
+(defvar mh-note-repl "-"
+ "String whose first character is used to notate replied to messages.")
+
+(defvar mh-note-forw "F"
+ "String whose first character is used to notate forwarded messages.")
+
+(defvar mh-note-dist "R"
+ "String whose first character is used to notate redistributed messages.")
+
+(defvar mh-good-msg-regexp "^....[^D^]"
+ "Regexp specifiying the scan lines that are 'good' messages.")
+
+(defvar mh-deleted-msg-regexp "^....D"
+ "Regexp matching scan lines of deleted messages.")
+
+(defvar mh-refiled-msg-regexp "^....\\^"
+ "Regexp matching scan lines of refiled messages.")
+
+(defvar mh-valid-scan-line "^ *[0-9]"
+ "Regexp matching scan lines for messages (not error messages).")
+
+(defvar mh-msg-number-regexp "^ *\\([0-9]+\\)"
+ "Regexp to find the number of a message in a scan line.
+The message's number must be surrounded with \\( \\)")
+
+(defvar mh-msg-search-regexp "^[^0-9]*%d[^0-9]"
+ "Format string containing a regexp matching the scan listing for a message.
+The desired message's number will be an argument to format.")
+
+(defvar mh-flagged-scan-msg-regexp "^....\\D\\|^....\\^\\|^....\\+\\|^.....%"
+ "Regexp matching flagged scan lines.
+Matches lines marked as deleted, refiled, in a sequence, or the cur message.")
+
+(defvar mh-cur-scan-msg-regexp "^....\\+"
+ "Regexp matching scan line for the cur message.")
+
+(defvar mh-show-buffer-mode-line-buffer-id "{%%b} %s/%d"
+ "Format string to produce `mode-line-buffer-id' for show buffers.
+First argument is folder name. Second is message number.")
+
+(defvar mh-partial-folder-mode-line-annotation "select"
+ "Annotation when displaying part of a folder.
+The string is displayed after the folder's name. NIL for no annotation.")
+
+
+;;; Real constants:
+
+(defvar mh-invisible-headers
+ "^Received: \\|^Message-Id: \\|^Remailed-\\|^Via: \\|^Mail-from: \\|^Return-Path: \\|^In-Reply-To: \\|^Resent-"
+ "Regexp matching lines in a message header that are not to be shown.
+If `mh-visible-headers' is non-nil, it is used instead to specify what
+to keep.")
+
+(defvar mh-rejected-letter-start
+ (concat "^ ----- Unsent message follows -----$" ;from mail system
+ "\\|^------- Unsent Draft$" ;from MH itself
+ "\\|^ --- The unsent message follows ---$") ;from AIX mail system
+ "Regexp specifying the beginning of the wrapper around a returned letter.
+This wrapper is generated by the mail system when rejecting a letter.")
+
+(defvar mh-to-field-choices '((?t . "To:") (?s . "Subject:") (?c . "Cc:")
+ (?b . "Bcc:") (?f . "Fcc:"))
+ "A-list of (character . field name) strings for mh-to-field.")
+
+
+;;; Global variables:
+
+(defvar mh-user-path ""
+ "User's mail folder.")
+
+(defvar mh-last-destination nil
+ "Destination of last refile or write command.")
+
+(defvar mh-folder-mode-map (make-keymap)
+ "Keymap for MH folders.")
+
+(defvar mh-letter-mode-map (copy-keymap text-mode-map)
+ "Keymap for composing mail.")
+
+(defvar mh-pick-mode-map (make-sparse-keymap)
+ "Keymap for searching folder.")
+
+(defvar mh-letter-mode-syntax-table nil
+ "Syntax table used while in mh-e letter mode.")
+
+(if mh-letter-mode-syntax-table
+ ()
+ (setq mh-letter-mode-syntax-table
+ (make-syntax-table text-mode-syntax-table))
+ (set-syntax-table mh-letter-mode-syntax-table)
+ (modify-syntax-entry ?% "." mh-letter-mode-syntax-table))
+
+(defvar mh-folder-list nil
+ "List of folder names for completion.")
+
+(defvar mh-draft-folder nil
+ "Name of folder containing draft messages.
+NIL means do not use draft folder.")
+
+(defvar mh-unseen-seq nil
+ "Name of the unseen sequence.")
+
+(defvar mh-previous-window-config nil
+ "Window configuration before mh-e command.")
+
+(defvar mh-previous-seq nil
+ "Name of the sequence to which a message was last added.")
+
+
+;;; Macros and generic functions:
+
+(defmacro mh-push (v l)
+ (list 'setq l (list 'cons v l)))
+
+
+(defmacro mh-when (pred &rest body)
+ (list 'cond (cons pred body)))
+
+
+(defmacro with-mh-folder-updating (save-modification-flag-p &rest body)
+ ;; Format is (with-mh-folder-updating (SAVE-MODIFICATION-FLAG-P) &body BODY).
+ ;; Execute BODY, which can modify the folder buffer without having to
+ ;; worry about file locking or the read-only flag, and return its result.
+ ;; If SAVE-MODIFICATION-FLAG-P is non-nil, the buffer's modification
+ ;; flag is unchanged, otherwise it is cleared.
+ (setq save-modification-flag-p (car save-modification-flag-p)) ; CL style
+ (` (let ((folder-updating-mod-flag (buffer-modified-p)))
+ (prog1
+ (let ((buffer-read-only nil)
+ (buffer-file-name nil)) ; don't let the buffer get locked
+ (,@ body))
+ (, (if save-modification-flag-p
+ '(mh-set-folder-modified-p folder-updating-mod-flag)
+ '(mh-set-folder-modified-p nil)))))))
+
+
+(defun mh-mapc (func list)
+ (while list
+ (funcall func (car list))
+ (setq list (cdr list))))
+
+
+
+;;; Entry points:
+
+;;;###autoload
+(defun mh-rmail (&optional arg)
+ "Inc(orporate) new mail (no arg) or scan a MH mail box (arg given).
+This front end uses the MH mail system, which uses different conventions
+from the usual mail system."
+ (interactive "P")
+ (mh-find-path)
+ (if arg
+ (call-interactively 'mh-visit-folder)
+ (mh-inc-folder)))
+
+
+;;;###autoload
+(defun mh-smail ()
+ "Compose and send mail with the MH mail system."
+ (interactive)
+ (mh-find-path)
+ (call-interactively 'mh-send))
+
+
+(defun mh-smail-other-window ()
+ "Compose and send mail in other window with the MH mail system."
+ (interactive)
+ (mh-find-path)
+ (call-interactively 'mh-send-other-window))
+
+
+
+;;; User executable mh-e commands:
+
+(defun mh-burst-digest ()
+ "Burst apart the current message, which should be a digest.
+The message is replaced by its table of contents and the letters from the
+digest are inserted into the folder after that message."
+ (interactive)
+ (let ((digest (mh-get-msg-num t)))
+ (mh-process-or-undo-commands mh-current-folder)
+ (mh-set-folder-modified-p t) ; lock folder while bursting
+ (message "Bursting digest...")
+ (mh-exec-cmd "burst" mh-current-folder digest "-inplace")
+ (mh-scan-folder mh-current-folder (format "%d-last" mh-first-msg-num))
+ (message "Bursting digest...done")))
+
+
+(defun mh-copy-msg (prefix-provided msg-or-seq dest)
+ "Copy specified MESSAGE(s) to another FOLDER without deleting them.
+Default is the displayed message. If optional prefix argument is
+provided, then prompt for the message sequence."
+ (interactive (list current-prefix-arg
+ (if current-prefix-arg
+ (mh-read-seq-default "Copy" t)
+ (mh-get-msg-num t))
+ (mh-prompt-for-folder "Copy to" "" t)))
+ (mh-exec-cmd "refile" msg-or-seq "-link" "-src" mh-current-folder dest)
+ (if prefix-provided
+ (mh-notate-seq msg-or-seq ?C mh-cmd-note)
+ (mh-notate msg-or-seq ?C mh-cmd-note)))
+
+
+(defun mh-delete-msg (msg-or-seq)
+ "Mark the specified MESSAGE(s) for subsequent deletion and move to the next.
+Default is the displayed message. If optional prefix argument is
+given then prompt for the message sequence."
+ (interactive (list (if current-prefix-arg
+ (mh-read-seq-default "Delete" t)
+ (mh-get-msg-num t))))
+ (if (numberp msg-or-seq)
+ (mh-delete-a-msg msg-or-seq)
+ (mh-map-to-seq-msgs 'mh-delete-a-msg msg-or-seq))
+ (mh-next-msg))
+
+
+(defun mh-delete-msg-no-motion (msg-or-seq)
+ "Mark the specified MESSAGE(s) for subsequent deletion.
+Default is the displayed message. If optional prefix argument is
+provided, then prompt for the message sequence."
+ (interactive (list (if current-prefix-arg
+ (mh-read-seq-default "Delete" t)
+ (mh-get-msg-num t))))
+ (if (numberp msg-or-seq)
+ (mh-delete-a-msg msg-or-seq)
+ (mh-map-to-seq-msgs 'mh-delete-a-msg msg-or-seq)))
+
+
+(defun mh-delete-msg-from-seq (prefix-provided msg-or-seq &optional from-seq)
+ "Delete MESSAGE (default: displayed message) from SEQUENCE.
+If optional prefix argument provided, then delete all messages
+from a sequence."
+ (interactive (let ((argp current-prefix-arg))
+ (list argp
+ (if argp
+ (mh-read-seq-default "Delete" t)
+ (mh-get-msg-num t))
+ (if (not argp)
+ (mh-read-seq-default "Delete from" t)))))
+ (if prefix-provided
+ (mh-remove-seq msg-or-seq)
+ (mh-remove-msg-from-seq msg-or-seq from-seq)))
+
+
+(defun mh-edit-again (msg)
+ "Clean-up a draft or a message previously sent and make it resendable."
+ (interactive (list (mh-get-msg-num t)))
+ (let* ((from-folder mh-current-folder)
+ (config (current-window-configuration))
+ (draft
+ (cond ((and mh-draft-folder (equal from-folder mh-draft-folder))
+ (pop-to-buffer (find-file-noselect (mh-msg-filename msg)) t)
+ (rename-buffer (format "draft-%d" msg))
+ (buffer-name))
+ (t
+ (mh-read-draft "clean-up" (mh-msg-filename msg) nil)))))
+ (mh-clean-msg-header (point-min)
+ "^Date:\\|^Received:\\|^Message-Id:\\|^From:\\|^Delivery-Date:"
+ nil)
+ (goto-char (point-min))
+ (set-buffer-modified-p nil)
+ (mh-compose-and-send-mail draft "" from-folder nil nil nil nil nil nil
+ config)))
+
+
+(defun mh-execute-commands ()
+ "Process outstanding delete and refile requests."
+ (interactive)
+ (if mh-narrowed-to-seq (mh-widen))
+ (mh-process-commands mh-current-folder)
+ (mh-set-scan-mode)
+ (mh-goto-cur-msg) ; after mh-set-scan-mode for efficiency
+ (mh-make-folder-mode-line)
+ t) ; return t for write-file-hooks
+
+
+(defun mh-extract-rejected-mail (msg)
+ "Extract a letter returned by the mail system and make it resendable.
+Default is the displayed message."
+ (interactive (list (mh-get-msg-num t)))
+ (let ((from-folder mh-current-folder)
+ (config (current-window-configuration))
+ (draft (mh-read-draft "extraction" (mh-msg-filename msg) nil)))
+ (goto-char (point-min))
+ (cond ((re-search-forward mh-rejected-letter-start nil t)
+ (forward-char 1)
+ (delete-region (point-min) (point))
+ (mh-clean-msg-header (point-min)
+ "^Date:\\|^Received:\\|^Message-Id:\\|^From:\\|^Sender:\\|^Return-Path:"
+ nil))
+ (t
+ (message "Does not appear to be a rejected letter.")))
+ (goto-char (point-min))
+ (set-buffer-modified-p nil)
+ (mh-compose-and-send-mail draft "" from-folder msg (mh-get-field "To")
+ (mh-get-field "From") (mh-get-field "cc")
+ nil nil config)))
+
+
+(defun mh-first-msg ()
+ "Move to the first message."
+ (interactive)
+ (goto-char (point-min)))
+
+
+(defun mh-forward (prefix-provided msg-or-seq to cc)
+ "Forward MESSAGE(s) (default: displayed message).
+If optional prefix argument provided, then prompt for the message sequence."
+ (interactive (list current-prefix-arg
+ (if current-prefix-arg
+ (mh-read-seq-default "Forward" t)
+ (mh-get-msg-num t))
+ (read-string "To: ")
+ (read-string "Cc: ")))
+ (let* ((folder mh-current-folder)
+ (config (current-window-configuration))
+ ;; forw always leaves file in "draft" since it doesn't have -draft
+ (draft-name (expand-file-name "draft" mh-user-path))
+ (draft (cond ((or (not (file-exists-p draft-name))
+ (y-or-n-p "The file 'draft' exists. Discard it? "))
+ (mh-exec-cmd "forw"
+ "-build" mh-current-folder msg-or-seq)
+ (prog1
+ (mh-read-draft "" draft-name t)
+ (mh-insert-fields "To:" to "Cc:" cc)
+ (set-buffer-modified-p nil)))
+ (t
+ (mh-read-draft "" draft-name nil)))))
+ (goto-char (point-min))
+ (re-search-forward "^------- Forwarded Message")
+ (forward-line -1)
+ (narrow-to-region (point) (point-max))
+ (let* ((subject (save-excursion (mh-get-field "From:")))
+ (trim (string-match "<" subject))
+ (forw-subject (save-excursion (mh-get-field "Subject:"))))
+ (if trim
+ (setq subject (substring subject 0 (1- trim))))
+ (widen)
+ (save-excursion
+ (mh-insert-fields "Subject:" (format "[%s: %s]" subject forw-subject)))
+ (delete-other-windows)
+ (if prefix-provided
+ (mh-add-msgs-to-seq (mh-seq-to-msgs msg-or-seq) 'forwarded t)
+ (mh-add-msgs-to-seq msg-or-seq 'forwarded t))
+ (mh-compose-and-send-mail draft "" folder msg-or-seq
+ to subject cc
+ mh-note-forw "Forwarded:"
+ config))))
+
+
+(defun mh-goto-msg (number &optional no-error-if-no-message dont-show)
+ "Position the cursor at message NUMBER.
+Non-nil second argument means do not signal an error if message does not exist.
+Non-nil third argument means not to show the message.
+Return non-nil if cursor is at message."
+ (interactive "NGoto message: ")
+ (let ((cur-msg (mh-get-msg-num nil))
+ (starting-place (point))
+ (msg-pattern (mh-msg-search-pat number)))
+ (cond ((cond ((and cur-msg (= cur-msg number)) t)
+ ((and cur-msg
+ (< cur-msg number)
+ (re-search-forward msg-pattern nil t)) t)
+ ((and cur-msg
+ (> cur-msg number)
+ (re-search-backward msg-pattern nil t)) t)
+ (t ; Do thorough search of buffer
+ (goto-char (point-max))
+ (re-search-backward msg-pattern nil t)))
+ (beginning-of-line)
+ (if (not dont-show) (mh-maybe-show number))
+ t)
+ (t
+ (goto-char starting-place)
+ (if (not no-error-if-no-message)
+ (error "No message %d" number))
+ nil))))
+
+
+(defun mh-inc-folder (&optional maildrop-name)
+ "Inc(orporate) new mail into +inbox.
+Optional prefix argument specifies an alternate maildrop from the default.
+If this is given, incorporate mail into the current folder, rather
+than +inbox. Run `mh-inc-folder-hook' after incorporating new mail."
+ (interactive (list (if current-prefix-arg
+ (expand-file-name
+ (read-file-name "inc mail from file: "
+ mh-user-path)))))
+ (let ((config (current-window-configuration)))
+ (if (not maildrop-name)
+ (cond ((not (get-buffer "+inbox"))
+ (mh-make-folder "+inbox")
+ (setq mh-previous-window-config config))
+ ((not (eq (current-buffer) (get-buffer "+inbox")))
+ (switch-to-buffer "+inbox")
+ (setq mh-previous-window-config config)))))
+ (mh-get-new-mail maildrop-name)
+ (run-hooks 'mh-inc-folder-hook))
+
+
+(defun mh-kill-folder ()
+ "Remove the current folder."
+ (interactive)
+ (if (or mh-do-not-confirm
+ (yes-or-no-p (format "Remove folder %s? " mh-current-folder)))
+ (let ((folder mh-current-folder))
+ (mh-set-folder-modified-p t) ; lock folder to kill it
+ (mh-exec-cmd-daemon "rmf" folder)
+ (mh-remove-folder-from-folder-list folder)
+ (message "Folder %s removed" folder)
+ (mh-set-folder-modified-p nil) ; so kill-buffer doesn't complain
+ (if (get-buffer mh-show-buffer)
+ (kill-buffer mh-show-buffer))
+ (kill-buffer folder))
+ (message "Folder not removed")))
+
+
+(defun mh-last-msg ()
+ "Move to the last message."
+ (interactive)
+ (goto-char (point-max))
+ (while (and (not (bobp)) (looking-at "^$"))
+ (forward-line -1)))
+
+
+(defun mh-list-folders ()
+ "List mail folders."
+ (interactive)
+ (with-output-to-temp-buffer " *mh-temp*"
+ (save-excursion
+ (switch-to-buffer " *mh-temp*")
+ (erase-buffer)
+ (message "Listing folders...")
+ (mh-exec-cmd-output "folders" t (if mh-recursive-folders
+ "-recurse"
+ "-norecurse"))
+ (goto-char (point-min))
+ (message "Listing folders...done"))))
+
+
+(defun mh-msg-is-in-seq (msg)
+ "Display the sequences that contain MESSAGE (default: displayed message)."
+ (interactive (list (mh-get-msg-num t)))
+ (message "Message %d is in sequences: %s"
+ msg
+ (mapconcat 'concat
+ (mh-list-to-string (mh-seq-containing-msg msg))
+ " ")))
+
+
+(defun mh-narrow-to-seq (seq)
+ "Restrict display of this folder to just messages in a sequence.
+Reads which sequence. Use \\[mh-widen] to undo this command."
+ (interactive (list (mh-read-seq "Narrow to" t)))
+ (let ((eob (point-max)))
+ (with-mh-folder-updating (t)
+ (cond ((mh-seq-to-msgs seq)
+ (mh-copy-seq-to-point seq eob)
+ (narrow-to-region eob (point-max))
+ (mh-make-folder-mode-line (symbol-name seq))
+ (mh-recenter nil)
+ (setq mh-narrowed-to-seq seq))
+ (t
+ (error "No messages in sequence `%s'" (symbol-name seq)))))))
+
+
+(defun mh-next-undeleted-msg (&optional arg)
+ "Move to next undeleted message in window."
+ (interactive "P")
+ (forward-line (prefix-numeric-value arg))
+ (setq mh-next-direction 'forward)
+ (cond ((re-search-forward mh-good-msg-regexp nil 0 arg)
+ (beginning-of-line)
+ (mh-maybe-show))
+ (t
+ (forward-line -1)
+ (if (get-buffer mh-show-buffer)
+ (delete-windows-on mh-show-buffer)))))
+
+
+(defun mh-pack-folder (range)
+ "Renumber the messages of a folder to be 1..n.
+First, offer to execute any outstanding commands for the current folder.
+If optional prefix argument provided, prompt for the range of messages
+to display after packing. Otherwise, show the entire folder."
+ (interactive (list (if current-prefix-arg
+ (mh-read-msg-range
+ "Range to scan after packing [all]? ")
+ "all")))
+ (mh-pack-folder-1 range)
+ (mh-goto-cur-msg)
+ (message "Packing folder...done"))
+
+
+(defun mh-pipe-msg (prefix-provided command)
+ "Pipe the current message through the given shell COMMAND.
+If optional prefix argument is provided, send the entire message.
+Otherwise just send the message's body."
+ (interactive
+ (list current-prefix-arg (read-string "Shell command on message: ")))
+ (save-excursion
+ (mh-display-msg (mh-get-msg-num t) mh-current-folder) ;update show buffer
+ (goto-char (point-min))
+ (if (not prefix-provided) (search-forward "\n\n"))
+ (shell-command-on-region (point) (point-max) command nil)))
+
+
+(defun mh-refile-msg (prefix-provided msg-or-seq dest)
+ "Refile MESSAGE(s) (default: displayed message) in FOLDER.
+If optional prefix argument provided, then prompt for message sequence."
+ (interactive
+ (list current-prefix-arg
+ (if current-prefix-arg
+ (mh-read-seq-default "Refile" t)
+ (mh-get-msg-num t))
+ (intern
+ (mh-prompt-for-folder "Destination"
+ (if (eq 'refile (car mh-last-destination))
+ (symbol-name (cdr mh-last-destination))
+ "")
+ t))))
+ (setq mh-last-destination (cons 'refile dest))
+ (if prefix-provided
+ (mh-map-to-seq-msgs 'mh-refile-a-msg msg-or-seq dest)
+ (mh-refile-a-msg msg-or-seq dest))
+ (mh-next-msg))
+
+
+(defun mh-refile-or-write-again (msg)
+ "Re-execute the last refile or write command on the given MESSAGE.
+Default is the displayed message. Use the same folder or file as the
+previous refile or write command."
+ (interactive (list (mh-get-msg-num t)))
+ (if (null mh-last-destination)
+ (error "No previous refile or write"))
+ (cond ((eq (car mh-last-destination) 'refile)
+ (mh-refile-a-msg msg (cdr mh-last-destination))
+ (message "Destination folder: %s" (cdr mh-last-destination)))
+ (t
+ (mh-write-msg-to-file msg (cdr mh-last-destination))
+ (message "Destination: %s" (cdr mh-last-destination))))
+ (mh-next-msg))
+
+
+(defun mh-reply (prefix-provided msg)
+ "Reply to a MESSAGE (default: displayed message).
+If optional prefix argument provided, then include the message in the reply
+using filter mhl.reply in your MH directory."
+ (interactive (list current-prefix-arg (mh-get-msg-num t)))
+ (let ((minibuffer-help-form
+ "from => Sender only\nto => Sender and primary recipients\ncc or all => Sender and all recipients"))
+ (let ((reply-to (or mh-reply-default-reply-to
+ (completing-read "Reply to whom: "
+ '(("from") ("to") ("cc") ("all"))
+ nil
+ t)))
+ (folder mh-current-folder)
+ (show-buffer mh-show-buffer)
+ (config (current-window-configuration)))
+ (message "Composing a reply...")
+ (cond ((or (equal reply-to "from") (equal reply-to ""))
+ (apply 'mh-exec-cmd
+ "repl" "-build" "-noquery"
+ "-nodraftfolder" mh-current-folder
+ msg
+ "-nocc" "all"
+ (if prefix-provided
+ (list "-filter" "mhl.reply"))))
+ ((equal reply-to "to")
+ (apply 'mh-exec-cmd
+ "repl" "-build" "-noquery"
+ "-nodraftfolder" mh-current-folder
+ msg
+ "-cc" "to"
+ (if prefix-provided
+ (list "-filter" "mhl.reply"))))
+ ((or (equal reply-to "cc") (equal reply-to "all"))
+ (apply 'mh-exec-cmd
+ "repl" "-build" "-noquery"
+ "-nodraftfolder" mh-current-folder
+ msg
+ "-cc" "all" "-nocc" "me"
+ (if prefix-provided
+ (list "-filter" "mhl.reply")))))
+
+ (let ((draft (mh-read-draft "reply"
+ (expand-file-name "reply" mh-user-path)
+ t)))
+ (delete-other-windows)
+ (set-buffer-modified-p nil)
+
+ (let ((to (mh-get-field "To:"))
+ (subject (mh-get-field "Subject:"))
+ (cc (mh-get-field "Cc:")))
+ (goto-char (point-min))
+ (mh-goto-header-end 1)
+ (if (not prefix-provided)
+ (mh-display-msg msg folder))
+ (mh-add-msgs-to-seq msg 'answered t)
+ (message "Composing a reply...done")
+ (mh-compose-and-send-mail draft "" folder msg to subject cc
+ mh-note-repl "Replied:" config))))))
+
+
+(defun mh-quit ()
+ "Quit mh-e.
+Start by running mh-before-quit-hook. Restore the previous window
+configuration, if one exists. Finish by running mh-quit-hook."
+ (interactive)
+ (run-hooks 'mh-before-quit-hook)
+ (if mh-previous-window-config
+ (set-window-configuration mh-previous-window-config))
+ (run-hooks 'mh-quit-hook))
+
+
+(defun mh-page-digest ()
+ "Advance displayed message to next digested message."
+ (interactive)
+ (save-excursion
+ (mh-show-message-in-other-window)
+ ;; Go to top of screen (in case user moved point).
+ (move-to-window-line 0)
+ (let ((case-fold-search nil))
+ ;; Search for blank line and then for From:
+ (mh-when (not (and (search-forward "\n\n" nil t)
+ (search-forward "From:" nil t)))
+ (other-window -1)
+ (error "No more messages")))
+ ;; Go back to previous blank line, then forward to the first non-blank.
+ (search-backward "\n\n" nil t)
+ (forward-line 2)
+ (mh-recenter 0)
+ (other-window -1)))
+
+
+(defun mh-page-digest-backwards ()
+ "Back up displayed message to previous digested message."
+ (interactive)
+ (save-excursion
+ (mh-show-message-in-other-window)
+ ;; Go to top of screen (in case user moved point).
+ (move-to-window-line 0)
+ (let ((case-fold-search nil))
+ (beginning-of-line)
+ (mh-when (not (and (search-backward "\n\n" nil t)
+ (search-backward "From:" nil t)))
+ (other-window -1)
+ (error "No more messages")))
+ ;; Go back to previous blank line, then forward to the first non-blank.
+ (search-backward "\n\n" nil t)
+ (forward-line 2)
+ (mh-recenter 0)
+ (other-window -1)))
+
+
+(defun mh-page-msg (&optional arg)
+ "Page the displayed message forwards.
+Scrolls ARG lines or a full screen if no argument is supplied."
+ (interactive "P")
+ (scroll-other-window arg))
+
+
+(defun mh-previous-page (&optional arg)
+ "Page the displayed message backwards.
+Scrolls ARG lines or a full screen if no argument is supplied."
+ (interactive "P")
+ (save-excursion
+ (mh-show-message-in-other-window)
+ (unwind-protect
+ (scroll-down arg)
+ (other-window -1))))
+
+
+(defun mh-previous-undeleted-msg (&optional arg)
+ "Move to previous undeleted message in window."
+ (interactive "p")
+ (setq mh-next-direction 'backward)
+ (beginning-of-line)
+ (cond ((re-search-backward mh-good-msg-regexp nil 0 arg)
+ (mh-maybe-show))
+ (t
+ (if (get-buffer mh-show-buffer)
+ (delete-windows-on mh-show-buffer)))))
+
+
+(defun mh-print-msg (prefix-provided msg-or-seq)
+ "Print MESSAGE(s) (default: displayed message) on a line printer.
+If optional prefix argument provided, then prompt for the message sequence."
+ (interactive (list current-prefix-arg
+ (if current-prefix-arg
+ (reverse (mh-seq-to-msgs
+ (mh-read-seq-default "Print" t)))
+ (mh-get-msg-num t))))
+ (if prefix-provided
+ (message "Printing sequence...")
+ (message "Printing message..."))
+ (let ((print-command
+ (if prefix-provided
+ (format "(scan -clear %s ; %s -nobell -clear %s %s) | %s"
+ (mapconcat (function (lambda (msg) msg)) msg-or-seq " ")
+ (expand-file-name "mhl" mh-lib)
+ (if (stringp mhl-formfile)
+ (format "-form %s" mhl-formfile)
+ "")
+ (mh-msg-filenames msg-or-seq)
+ (format mh-lpr-command-format
+ (if prefix-provided
+ (format "Sequence from %s" mh-current-folder)
+ (format "%s/%d" mh-current-folder
+ msg-or-seq))))
+ (format "%s -nobell -clear %s %s | %s"
+ (expand-file-name "mhl" mh-lib)
+ (mh-msg-filename msg-or-seq)
+ (if (stringp mhl-formfile)
+ (format "-form %s" mhl-formfile)
+ "")
+ (format mh-lpr-command-format
+ (if prefix-provided
+ (format "Sequence from %s" mh-current-folder)
+ (format "%s/%d" mh-current-folder
+ msg-or-seq)))))))
+ (if mh-print-background
+ (mh-exec-cmd-daemon shell-file-name "-c" print-command)
+ (call-process shell-file-name nil nil nil "-c" print-command))
+ (if prefix-provided
+ (mh-notate-seq msg-or-seq ?P mh-cmd-note)
+ (mh-notate msg-or-seq ?P mh-cmd-note))
+ (mh-add-msgs-to-seq msg-or-seq 'printed t)
+ (if prefix-provided
+ (message "Printing sequence...done")
+ (message "Printing message...done"))))
+
+
+(defun mh-put-msg-in-seq (prefix-provided from to)
+ "Add MESSAGE(s) (default: displayed message) to SEQUENCE.
+If optional prefix argument provided, then prompt for the message sequence."
+ (interactive (list current-prefix-arg
+ (if current-prefix-arg
+ (mh-seq-to-msgs
+ (mh-read-seq-default "Add messages from" t))
+ (mh-get-msg-num t))
+ (mh-read-seq-default "Add to" nil)))
+ (setq mh-previous-seq to)
+ (mh-add-msgs-to-seq from to))
+
+
+(defun mh-rescan-folder (&optional range)
+ "Rescan a folder after optionally processing the outstanding commands.
+If optional prefix argument is provided, prompt for the range of
+messages to display. Otherwise show the entire folder."
+ (interactive (list (if current-prefix-arg
+ (mh-read-msg-range "Range to scan [all]? ")
+ nil)))
+ (setq mh-next-direction 'forward)
+ (mh-scan-folder mh-current-folder (or range "all")))
+
+
+(defun mh-redistribute (to cc msg)
+ "Redistribute a letter.
+Depending on how your copy of MH was compiled, you may need to change the
+setting of the variable mh-redist-full-contents. See its documentation."
+ (interactive (list (read-string "Redist-To: ")
+ (read-string "Redist-Cc: ")
+ (mh-get-msg-num t)))
+ (save-window-excursion
+ (let ((folder mh-current-folder)
+ (draft (mh-read-draft "redistribution"
+ (if mh-redist-full-contents
+ (mh-msg-filename msg)
+ nil)
+ nil)))
+ (mh-goto-header-end 0)
+ (insert "Resent-To: " to "\n")
+ (if (not (equal cc "")) (insert "Resent-cc: " cc "\n"))
+ (mh-clean-msg-header (point-min)
+ "^Message-Id:\\|^Received:\\|^Return-Path:\\|^Sender:\\|^Date:\\|^From:"
+ nil)
+ (save-buffer)
+ (message "Redistributing...")
+ (if mh-redist-full-contents
+ (call-process "/bin/sh" nil 0 nil "-c"
+ (format "mhdist=1 mhaltmsg=%s %s -push %s"
+ (buffer-file-name)
+ (expand-file-name "send" mh-progs)
+ (buffer-file-name)))
+ (call-process "/bin/sh" nil 0 nil "-c"
+ (format "mhdist=1 mhaltmsg=%s mhannotate=1 %s -push %s"
+ (mh-msg-filename msg folder)
+ (expand-file-name "send" mh-progs)
+ (buffer-file-name))))
+ (mh-annotate-msg msg folder mh-note-dist
+ "-component" "Resent:"
+ "-text" (format "\"%s %s\"" to cc))
+ (kill-buffer draft)
+ (message "Redistributing...done"))))
+
+
+(defun mh-write-msg-to-file (msg file)
+ "Append MESSAGE to the end of a FILE."
+ (interactive
+ (list (mh-get-msg-num t)
+ (let ((default-dir (if (eq 'write (car mh-last-destination))
+ (file-name-directory (cdr mh-last-destination))
+ default-directory)))
+ (read-file-name "Save message in file: " default-dir
+ (expand-file-name "mail.out" default-dir)))))
+ (let ((file-name (mh-msg-filename msg))
+ (output-file (mh-expand-file-name file)))
+ (setq mh-last-destination (cons 'write file))
+ (save-excursion
+ (set-buffer (get-buffer-create " *mh-temp*"))
+ (erase-buffer)
+ (insert-file-contents file-name)
+ (append-to-file (point-min) (point-max) output-file))))
+
+
+(defun mh-search-folder (folder)
+ "Search FOLDER for messages matching a pattern."
+ (interactive (list (mh-prompt-for-folder "Search"
+ mh-current-folder
+ t)))
+ (switch-to-buffer-other-window "pick-pattern")
+ (if (or (zerop (buffer-size))
+ (not (y-or-n-p "Reuse pattern? ")))
+ (mh-make-pick-template)
+ (message ""))
+ (setq mh-searching-folder folder))
+
+
+(defun mh-send (to cc subject)
+ "Compose and send a letter.
+The letter is composed in mh-letter-mode; see its documentation for more
+details. If `mh-compose-letter-function' is defined, it is called on the
+draft and passed three arguments: to, subject, and cc."
+ (interactive "sTo: \nsCc: \nsSubject: ")
+ (let ((config (current-window-configuration)))
+ (delete-other-windows)
+ (mh-send-sub to cc subject config)))
+
+
+(defun mh-send-other-window (to cc subject)
+ "Compose and send a letter in another window.."
+ (interactive "sTo: \nsCc: \nsSubject: ")
+ (let ((pop-up-windows t))
+ (mh-send-sub to cc subject (current-window-configuration))))
+
+
+(defun mh-send-sub (to cc subject config)
+ "Do the real work of composing and sending a letter.
+Expects the TO, CC, and SUBJECT fields as arguments.
+CONFIG is the window configuration before sending mail."
+ (let ((folder mh-current-folder)
+ (msg-num (mh-get-msg-num nil)))
+ (message "Composing a message...")
+ (let ((draft (mh-read-draft
+ "message"
+ (if (file-exists-p
+ (expand-file-name "components" mh-user-path))
+ (expand-file-name "components" mh-user-path)
+ (if (file-exists-p
+ (expand-file-name "components" mh-lib))
+ (expand-file-name "components" mh-lib)
+ (error "Can't find components file")))
+ nil)))
+ (mh-insert-fields "To:" to "Subject:" subject "Cc:" cc)
+ (set-buffer-modified-p nil)
+ (goto-char (point-max))
+ (message "Composing a message...done")
+ (mh-compose-and-send-mail draft "" folder msg-num
+ to subject cc
+ nil nil config))))
+
+
+(defun mh-show (&optional msg)
+ "Show MESSAGE (default: displayed message).
+Forces a two-window display with the folder window on top (size
+mh-summary-height) and the show buffer below it."
+ (interactive)
+ (if (not msg)
+ (setq msg (mh-get-msg-num t)))
+ (setq mh-showing t)
+ (mh-set-mode-name "mh-e show")
+ (if (not (eql (next-window (minibuffer-window)) (selected-window)))
+ (delete-other-windows)) ; force ourself to the top window
+ (let ((folder mh-current-folder))
+ (mh-show-message-in-other-window)
+ (mh-display-msg msg folder))
+ (other-window -1)
+ (if (not (= (1+ (window-height)) (screen-height))) ;not horizontally split
+ (shrink-window (- (window-height) mh-summary-height)))
+ (mh-recenter nil)
+ (if (not (memq msg mh-seen-list)) (mh-push msg mh-seen-list)))
+
+
+(defun mh-sort-folder ()
+ "Sort the messages in the current folder by date."
+ (interactive)
+ (mh-process-or-undo-commands mh-current-folder)
+ (setq mh-next-direction 'forward)
+ (mh-set-folder-modified-p t) ; lock folder while sorting
+ (message "Sorting folder...")
+ (mh-exec-cmd "sortm" mh-current-folder)
+ (message "Sorting folder...done")
+ (mh-scan-folder mh-current-folder "all"))
+
+
+(defun mh-toggle-showing ()
+ "Toggle the scanning mode/showing mode of displaying messages."
+ (interactive)
+ (if mh-showing
+ (mh-set-scan-mode)
+ (mh-show)))
+
+
+(defun mh-undo (prefix-provided msg-or-seq)
+ "Undo the deletion or refile of the specified MESSAGE(s).
+Default is the displayed message. If optional prefix argument is
+provided, then prompt for the message sequence."
+ (interactive (list current-prefix-arg
+ (if current-prefix-arg
+ (mh-read-seq-default "Undo" t)
+ (mh-get-msg-num t))))
+ (cond (prefix-provided
+ (mh-mapc (function mh-undo-msg) (mh-seq-to-msgs msg-or-seq)))
+ (t
+ (let ((original-position (point)))
+ (beginning-of-line)
+ (while (not (or (looking-at mh-deleted-msg-regexp)
+ (looking-at mh-refiled-msg-regexp)
+ (and (eq mh-next-direction 'forward) (bobp))
+ (and (eq mh-next-direction 'backward)
+ (save-excursion (forward-line) (eobp)))))
+ (forward-line (if (eq mh-next-direction 'forward) -1 1)))
+ (if (or (looking-at mh-deleted-msg-regexp)
+ (looking-at mh-refiled-msg-regexp))
+ (progn
+ (mh-undo-msg (mh-get-msg-num t))
+ (mh-maybe-show))
+ (goto-char original-position)
+ (error "Nothing to undo")))))
+ ;; update the mh-refile-list so mh-outstanding-commands-p will work
+ (mh-mapc (function
+ (lambda (elt)
+ (if (not (mh-seq-to-msgs elt))
+ (setq mh-refile-list (delq elt mh-refile-list)))))
+ mh-refile-list)
+ (if (not (mh-outstanding-commands-p))
+ (mh-set-folder-modified-p nil)))
+
+
+(defun mh-undo-msg (msg)
+ ;; Undo the deletion or refile of one MESSAGE.
+ (cond ((memq msg mh-delete-list)
+ (setq mh-delete-list (delq msg mh-delete-list))
+ (mh-remove-msg-from-seq msg 'deleted t))
+ (t
+ (mh-mapc (function (lambda (dest)
+ (mh-remove-msg-from-seq msg dest t)))
+ mh-refile-list)))
+ (mh-notate msg ? mh-cmd-note))
+
+
+(defun mh-undo-folder (&rest ignore)
+ "Undo all commands in current folder."
+ (interactive)
+ (cond ((or mh-do-not-confirm
+ (yes-or-no-p "Undo all commands in folder? "))
+ (setq mh-delete-list nil
+ mh-refile-list nil
+ mh-seq-list nil
+ mh-next-direction 'forward)
+ (with-mh-folder-updating (nil)
+ (mh-unmark-all-headers t)))
+ (t
+ (message "Commands not undone.")
+ (sit-for 2))))
+
+
+(defun mh-unshar-msg (dir)
+ "Unpack the shar file contained in the current message into directory DIR."
+ (interactive (list (read-file-name "Unshar message in directory: "
+ mh-unshar-default-directory
+ mh-unshar-default-directory nil)))
+ (mh-display-msg (mh-get-msg-num t) mh-current-folder) ;update show buffer
+ (mh-unshar-buffer dir))
+
+(defun mh-unshar-buffer (dir)
+ ;; Unpack the shar file contained in the current buffer into directory DIR.
+ (goto-char (point-min))
+ (if (or (re-search-forward "^#![ \t]*/bin/sh" nil t)
+ (and (re-search-forward "^[^a-z0-9\"]*cut here\b" nil t)
+ (forward-line 1))
+ (re-search-forward "^#" nil t)
+ (re-search-forward "^: " nil t))
+ (let ((default-directory (expand-file-name dir))
+ (start (progn (beginning-of-line) (point)))
+ (log-buffer (get-buffer-create "*Unshar Output*")))
+ (save-excursion
+ (set-buffer log-buffer)
+ (setq default-directory (expand-file-name dir))
+ (erase-buffer)
+ (if (file-directory-p default-directory)
+ (insert "cd " dir "\n")
+ (insert "mkdir " dir "\n")
+ (call-process "mkdir" nil log-buffer t default-directory)))
+ (set-window-start (display-buffer log-buffer) 0) ;so can watch progress
+ (call-process-region start (point-max) "sh" nil log-buffer t))
+ (error "Cannot find start of shar.")))
+
+
+(defun mh-visit-folder (folder &optional range)
+ "Visit FOLDER and display RANGE of messages.
+Assumes mh-e has already been initialized."
+ (interactive (list (mh-prompt-for-folder "Visit" "+inbox" t)
+ (mh-read-msg-range "Range [all]? ")))
+ (let ((config (current-window-configuration)))
+ (mh-scan-folder folder (or range "all"))
+ (setq mh-previous-window-config config))
+ nil)
+
+
+(defun mh-widen ()
+ "Remove restrictions from the current folder, thereby showing all messages."
+ (interactive)
+ (if mh-narrowed-to-seq
+ (with-mh-folder-updating (t)
+ (delete-region (point-min) (point-max))
+ (widen)
+ (mh-make-folder-mode-line)))
+ (setq mh-narrowed-to-seq nil))
+
+
+
+;;; Support routines.
+
+(defun mh-delete-a-msg (msg)
+ ;; Delete the MESSAGE.
+ (save-excursion
+ (mh-goto-msg msg nil t)
+ (if (looking-at mh-refiled-msg-regexp)
+ (error "Message %d is refiled. Undo refile before deleting." msg))
+ (if (looking-at mh-deleted-msg-regexp)
+ nil
+ (mh-set-folder-modified-p t)
+ (mh-push msg mh-delete-list)
+ (mh-add-msgs-to-seq msg 'deleted t)
+ (mh-notate msg ?D mh-cmd-note))))
+
+
+(defun mh-refile-a-msg (msg destination)
+ ;; Refile MESSAGE in FOLDER. FOLDER is a symbol, not a string.
+ (save-excursion
+ (mh-goto-msg msg nil t)
+ (cond ((looking-at mh-deleted-msg-regexp)
+ (error "Message %d is deleted. Undo delete before moving." msg))
+ ((looking-at mh-refiled-msg-regexp)
+ (if (y-or-n-p
+ (format "Message %d already refiled. Copy to %s as well? "
+ msg destination))
+ (mh-exec-cmd "refile" (mh-get-msg-num t) "-link"
+ "-src" mh-current-folder
+ (symbol-name destination))
+ (message "Message not copied.")))
+ (t
+ (mh-set-folder-modified-p t)
+ (if (not (memq destination mh-refile-list))
+ (mh-push destination mh-refile-list))
+ (if (not (memq msg (mh-seq-to-msgs destination)))
+ (mh-add-msgs-to-seq msg destination t))
+ (mh-notate msg ?^ mh-cmd-note)))))
+
+
+(defun mh-display-msg (msg-num folder)
+ ;; Display message NUMBER of FOLDER.
+ ;; Sets the current buffer to the show buffer.
+ (set-buffer folder)
+ ;; Bind variables in folder buffer in case they are local
+ (let ((formfile mhl-formfile)
+ (clean-message-header mh-clean-message-header)
+ (invisible-headers mh-invisible-headers)
+ (visible-headers mh-visible-headers)
+ (msg-filename (mh-msg-filename msg-num))
+ (show-buffer mh-show-buffer)
+ (folder mh-current-folder))
+ (if (not (file-exists-p msg-filename))
+ (error "Message %d does not exist" msg-num))
+ (switch-to-buffer show-buffer)
+ (if mh-bury-show-buffer (bury-buffer (current-buffer)))
+ (mh-when (not (equal msg-filename buffer-file-name))
+ ;; Buffer does not yet contain message.
+ (clear-visited-file-modtime)
+ (unlock-buffer)
+ (setq buffer-file-name nil) ; no locking during setup
+ (erase-buffer)
+ (if formfile
+ (if (stringp formfile)
+ (mh-exec-lib-cmd-output "mhl" "-nobell" "-noclear"
+ "-form" formfile msg-filename)
+ (mh-exec-lib-cmd-output "mhl" "-nobell" "-noclear"
+ msg-filename))
+ (insert-file-contents msg-filename))
+ (goto-char (point-min))
+ (cond (clean-message-header
+ (mh-clean-msg-header (point-min)
+ invisible-headers
+ visible-headers)
+ (goto-char (point-min)))
+ (t
+ (let ((case-fold-search t))
+ (re-search-forward
+ "^To:\\|^From:\\|^Subject:\\|^Date:" nil t)
+ (beginning-of-line)
+ (mh-recenter 0))))
+ (set-buffer-modified-p nil)
+ (setq buffer-file-name msg-filename)
+ (set-mark nil)
+ (setq mode-line-buffer-identification
+ (list (format mh-show-buffer-mode-line-buffer-id
+ folder msg-num))))))
+
+
+(defun mh-invalidate-show-buffer ()
+ ;; Invalidate the show buffer so we must update it to use it.
+ (if (get-buffer mh-show-buffer)
+ (save-excursion
+ (set-buffer mh-show-buffer)
+ (setq buffer-file-name nil))))
+
+
+(defun mh-show-message-in-other-window ()
+ (switch-to-buffer-other-window mh-show-buffer)
+ (if mh-bury-show-buffer (bury-buffer (current-buffer))))
+
+
+(defun mh-clean-msg-header (start invisible-headers visible-headers)
+ ;; Flush extraneous lines in a message header, from the given POINT to the
+ ;; end of the message header. If VISIBLE-HEADERS is non-nil, it contains a
+ ;; regular expression specifying the lines to display, otherwise
+ ;; INVISIBLE-HEADERS contains a regular expression specifying lines to
+ ;; delete from the header.
+ (let ((case-fold-search t))
+ (save-restriction
+ (goto-char start)
+ (if (search-forward "\n\n" nil t)
+ (backward-char 1))
+ (narrow-to-region start (point))
+ (goto-char (point-min))
+ (if visible-headers
+ (while (< (point) (point-max))
+ (beginning-of-line)
+ (cond ((looking-at visible-headers)
+ (forward-line 1)
+ (while (looking-at "^[ \t]+") (forward-line 1)))
+ (t
+ (mh-delete-line 1)
+ (while (looking-at "^[ \t]+")
+ (beginning-of-line)
+ (mh-delete-line 1)))))
+ (while (re-search-forward invisible-headers nil t)
+ (beginning-of-line)
+ (mh-delete-line 1)
+ (while (looking-at "^[ \t]+")
+ (beginning-of-line)
+ (mh-delete-line 1))))
+ (unlock-buffer))))
+
+
+(defun mh-delete-line (lines)
+ ;; Delete version of kill-line.
+ (delete-region (point) (save-excursion (forward-line lines) (point))))
+
+
+(defun mh-read-draft (use initial-contents delete-contents-file)
+ ;; Read draft file into a draft buffer and make that buffer the current one.
+ ;; USE is a message used for prompting about the intended use of the message.
+ ;; INITIAL-CONTENTS is filename that is read into an empty buffer, or NIL
+ ;; if buffer should not be modified. Delete the initial-contents file if
+ ;; DELETE-CONTENTS-FILE flag is set.
+ ;; Returns the draft folder's name.
+ ;; If the draft folder facility is enabled in ~/.mh_profile, a new buffer is
+ ;; used each time and saved in the draft folder. The draft file can then be
+ ;; reused.
+ (cond (mh-draft-folder
+ (let ((orig-default-dir default-directory))
+ (pop-to-buffer (find-file-noselect (mh-new-draft-name)) t)
+ (rename-buffer (format "draft-%s" (buffer-name)))
+ (setq default-directory orig-default-dir)))
+ (t
+ (let ((draft-name (expand-file-name "draft" mh-user-path)))
+ (pop-to-buffer "draft") ; Create if necessary
+ (if (buffer-modified-p)
+ (if (y-or-n-p "Draft has been modified; kill anyway? ")
+ (set-buffer-modified-p nil)
+ (error "Draft preserved")))
+ (setq buffer-file-name draft-name)
+ (clear-visited-file-modtime)
+ (unlock-buffer)
+ (mh-when (and (file-exists-p draft-name)
+ (not (equal draft-name initial-contents)))
+ (insert-file-contents draft-name)
+ (delete-file draft-name)))))
+ (mh-when (and initial-contents
+ (or (zerop (buffer-size))
+ (not (y-or-n-p
+ (format "A draft exists. Use for %s? " use)))))
+ (erase-buffer)
+ (insert-file-contents initial-contents)
+ (if delete-contents-file (delete-file initial-contents)))
+ (auto-save-mode 1)
+ (if mh-draft-folder
+ (save-buffer)) ; Do not reuse draft name
+ (buffer-name))
+
+
+(defun mh-new-draft-name ()
+ ;; Returns the pathname of folder for draft messages.
+ (save-excursion
+ (set-buffer (get-buffer-create " *mh-temp*"))
+ (erase-buffer)
+ (mh-exec-cmd-output "mhpath" nil mh-draft-folder "new")
+ (buffer-substring (point) (1- (mark)))))
+
+
+(defun mh-next-msg ()
+ ;; Move backward or forward to the next undeleted message in the buffer.
+ (if (eq mh-next-direction 'forward)
+ (mh-next-undeleted-msg 1)
+ (mh-previous-undeleted-msg 1)))
+
+
+(defun mh-set-scan-mode ()
+ ;; Display the scan listing buffer, but do not show a message.
+ (if (get-buffer mh-show-buffer)
+ (delete-windows-on mh-show-buffer))
+ (mh-set-mode-name "mh-e scan")
+ (setq mh-showing nil)
+ (if mh-recenter-summary-p
+ (mh-recenter nil)))
+
+
+(defun mh-maybe-show (&optional msg)
+ ;; If in showing mode, then display the message pointed to by the cursor.
+ (if mh-showing (mh-show msg)))
+
+
+(defun mh-set-mode-name (mode-name-string)
+ ;; Set the mode-name and ensure that the mode line is updated.
+ (setq mode-name mode-name-string)
+ ;; Force redisplay of all buffers' mode lines to be considered.
+ (save-excursion (set-buffer (other-buffer)))
+ (set-buffer-modified-p (buffer-modified-p)))
+
+
+
+;;; The folder data abstraction.
+
+(defvar mh-current-folder nil "Name of current folder, a string.")
+(defvar mh-show-buffer nil "Buffer that displays mesage for this folder.")
+(defvar mh-folder-filename nil "Full path of directory for this folder.")
+(defvar mh-showing nil "If non-nil, show the message in a separate window.")
+(defvar mh-next-seq-num nil "Index of free sequence id.")
+(defvar mh-delete-list nil "List of msg numbers to delete.")
+(defvar mh-refile-list nil "List of folder names in mh-seq-list.")
+(defvar mh-seq-list nil "Alist of (seq . msgs) numbers.")
+(defvar mh-seen-list nil "List of displayed messages.")
+(defvar mh-next-direction 'forward "Direction to move to next message.")
+(defvar mh-narrowed-to-seq nil "Sequence display is narrowed to.")
+(defvar mh-first-msg-num nil "Number of first msg in buffer.")
+(defvar mh-last-msg-num nil "Number of last msg in buffer.")
+
+
+(defun mh-make-folder (name)
+ ;; Create and initialize a new mail folder called NAME and make it the
+ ;; current folder.
+ (switch-to-buffer name)
+ (setq buffer-read-only nil)
+ (erase-buffer)
+ (setq buffer-read-only t)
+ (mh-folder-mode)
+ (mh-set-folder-modified-p nil)
+ (setq buffer-file-name mh-folder-filename)
+ (mh-set-mode-name "mh-e scan"))
+
+
+;;; Don't use this mode when creating buffers if default-major-mode is nil.
+(put 'mh-folder-mode 'mode-class 'special)
+
+(defun mh-folder-mode ()
+ "Major mode for \"editing\" an MH folder scan listing.
+Messages can be marked for refiling and deletion. However, both actions
+are deferred until you request execution with \\[mh-execute-commands].
+\\{mh-folder-mode-map}
+ A prefix argument (\\[universal-argument]) to delete, refile, list, or undo
+applies the action to a message sequence.
+
+Variables controlling mh-e operation are (defaults in parentheses):
+
+ mh-bury-show-buffer (t)
+ Non-nil means that the buffer used to display message is buried.
+ It will never be offered as the default other buffer.
+
+ mh-clean-message-header (nil)
+ Non-nil means remove header lines matching the regular expression
+ specified in mh-invisible-headers from messages.
+
+ mh-visible-headers (nil)
+ If non-nil, it contains a regexp specifying the headers that are shown in
+ a message if mh-clean-message-header is non-nil. Setting this variable
+ overrides mh-invisible-headers.
+
+ mh-do-not-confirm (nil)
+ Non-nil means do not prompt for confirmation before executing some
+ non-recoverable commands such as mh-kill-folder and mh-undo-folder.
+
+ mhl-formfile (nil)
+ Name of format file to be used by mhl to show messages.
+ A value of T means use the default format file.
+ Nil means don't use mhl to format messages.
+
+ mh-lpr-command-format (\"lpr -p -J '%s'\")
+ Format for command used to print a message on a system printer.
+
+ mh-recenter-summary-p (nil)
+ If non-nil, then the scan listing is recentered when the window displaying
+ a messages is toggled off.
+
+ mh-summary-height (4)
+ Number of lines in the summary window including the mode line.
+
+ mh-ins-buf-prefix (\"> \")
+ String to insert before each non-blank line of a message as it is
+ inserted in a draft letter.
+
+The value of mh-folder-mode-hook is called when a new folder is set up."
+
+ (kill-all-local-variables)
+ (use-local-map mh-folder-mode-map)
+ (setq major-mode 'mh-folder-mode)
+ (mh-set-mode-name "mh-e folder")
+ (make-local-vars
+ 'mh-current-folder (buffer-name) ; Name of folder, a string
+ 'mh-show-buffer (format "show-%s" (buffer-name)) ; Buffer that displays msgs
+ 'mh-folder-filename ; e.g. "/usr/foobar/Mail/inbox/"
+ (file-name-as-directory (mh-expand-file-name (buffer-name)))
+ 'mh-showing nil ; Show message also?
+ 'mh-next-seq-num 0 ; Index of free sequence id
+ 'mh-delete-list nil ; List of msgs nums to delete
+ 'mh-refile-list nil ; List of folder names in mh-seq-list
+ 'mh-seq-list nil ; Alist of (seq . msgs) nums
+ 'mh-seen-list nil ; List of displayed messages
+ 'mh-next-direction 'forward ; Direction to move to next message
+ 'mh-narrowed-to-seq nil ; Sequence display is narrowed to
+ 'mh-first-msg-num nil ; Number of first msg in buffer
+ 'mh-last-msg-num nil ; Number of last msg in buffer
+ 'mh-previous-window-config nil) ; Previous window configuration
+ (setq truncate-lines t)
+ (auto-save-mode -1)
+ (setq buffer-offer-save t)
+ (make-local-variable 'write-file-hooks)
+ (setq write-file-hooks '(mh-execute-commands))
+ (make-local-variable 'revert-buffer-function)
+ (setq revert-buffer-function 'mh-undo-folder)
+ (run-hooks 'mh-folder-mode-hook))
+
+
+(defun make-local-vars (&rest pairs)
+ ;; Take VARIABLE-VALUE pairs and makes local variables initialized to the
+ ;; value.
+ (while pairs
+ (make-variable-buffer-local (car pairs))
+ (set (car pairs) (car (cdr pairs)))
+ (setq pairs (cdr (cdr pairs)))))
+
+
+(defun mh-scan-folder (folder range)
+ ;; Scan the FOLDER over the RANGE. Return in the folder's buffer.
+ (cond ((null (get-buffer folder))
+ (mh-make-folder folder))
+ (t
+ (mh-process-or-undo-commands folder)
+ (switch-to-buffer folder)))
+ (mh-regenerate-headers range)
+ (mh-when (zerop (buffer-size))
+ (if (equal range "all")
+ (message "Folder %s is empty" folder)
+ (message "No messages in %s, range %s" folder range))
+ (sit-for 5))
+ (mh-goto-cur-msg))
+
+
+(defun mh-regenerate-headers (range)
+ ;; Replace buffer with scan of its contents over range RANGE.
+ (let ((folder mh-current-folder))
+ (message "Scanning %s..." folder)
+ (with-mh-folder-updating (nil)
+ (erase-buffer)
+ (mh-exec-cmd-output "scan" nil
+ "-noclear" "-noheader"
+ "-width" (window-width)
+ folder range)
+ (goto-char (point-min))
+ (cond ((looking-at "scan: no messages in")
+ (keep-lines mh-valid-scan-line)) ; Flush random scan lines
+ ((looking-at "scan: ")) ; Keep error messages
+ (t
+ (keep-lines mh-valid-scan-line))) ; Flush random scan lines
+ (mh-delete-seq-locally 'cur) ; To pick up new one
+ (setq mh-seq-list (mh-read-folder-sequences folder nil))
+ (mh-notate-user-sequences)
+ (mh-make-folder-mode-line (if (equal range "all")
+ nil
+ mh-partial-folder-mode-line-annotation)))
+ (message "Scanning %s...done" folder)))
+
+
+(defun mh-get-new-mail (maildrop-name)
+ ;; Read new mail from a maildrop into the current buffer.
+ ;; Return T if there was new mail, NIL otherwise. Return in the current
+ ;; buffer.
+ (let ((point-before-inc (point))
+ (folder mh-current-folder)
+ (return-value t))
+ (with-mh-folder-updating (t)
+ (message (if maildrop-name
+ (format "inc %s -file %s..." folder maildrop-name)
+ (format "inc %s..." folder)))
+ (mh-unmark-all-headers nil)
+ (setq mh-next-direction 'forward)
+ (goto-char (point-max))
+ (let ((start-of-inc (point)))
+ (if maildrop-name
+ (mh-exec-cmd-output "inc" nil folder
+ "-file" (expand-file-name maildrop-name)
+ "-width" (window-width)
+ "-truncate")
+ (mh-exec-cmd-output "inc" nil
+ "-width" (window-width)))
+ (message
+ (if maildrop-name
+ (format "inc %s -file %s...done" folder maildrop-name)
+ (format "inc %s...done" folder)))
+ (goto-char start-of-inc)
+ (cond ((looking-at "inc: no mail")
+ (keep-lines mh-valid-scan-line) ; Flush random scan lines
+ (goto-char point-before-inc)
+ (message "No new mail%s%s" (if maildrop-name " in " "")
+ (if maildrop-name maildrop-name "")))
+ ((re-search-forward "^inc:" nil t) ; Error messages
+ (error "inc error"))
+ (t
+ (mh-delete-seq-locally 'cur) ; To pick up new one
+ (setq mh-seq-list (mh-read-folder-sequences folder t))
+ (mh-notate-user-sequences)
+ (keep-lines mh-valid-scan-line)
+ (mh-make-folder-mode-line)
+ (mh-goto-cur-msg)
+ (setq return-value t))))
+ return-value)))
+
+
+(defun mh-make-folder-mode-line (&optional annotation)
+ ;; Set the fields of the mode line for a folder buffer.
+ ;; The optional ANNOTATION string is displayed after the folder's name.
+ (save-excursion
+ (mh-first-msg)
+ (setq mh-first-msg-num (mh-get-msg-num nil))
+ (mh-last-msg)
+ (setq mh-last-msg-num (mh-get-msg-num nil))
+ (let ((lines (count-lines (point-min) (point-max))))
+ (setq mode-line-buffer-identification
+ (list (format "{%%b%s} %d msg%s"
+ (if annotation (format "/%s" annotation) "")
+ lines
+ (if (zerop lines)
+ "s"
+ (if (> lines 1)
+ (format "s (%d-%d)" mh-first-msg-num
+ mh-last-msg-num)
+ (format " (%d)" mh-first-msg-num)))))))))
+
+
+(defun mh-unmark-all-headers (remove-all-flags)
+ ;; Remove all '+' flags from the headers, and if called with a non-nil
+ ;; argument, remove all 'D', '^' and '%' flags too.
+ ;; Optimized for speed (i.e., no regular expressions).
+ (save-excursion
+ (let ((case-fold-search nil)
+ (last-line (- (point-max) mh-cmd-note))
+ char)
+ (mh-first-msg)
+ (while (<= (point) last-line)
+ (forward-char mh-cmd-note)
+ (setq char (following-char))
+ (if (or (and remove-all-flags
+ (or (eql char ?D)
+ (eql char ?^)
+ (eql char ?%)))
+ (eql char ?+))
+ (progn
+ (delete-char 1)
+ (insert " ")))
+ (forward-line)))))
+
+
+(defun mh-goto-cur-msg ()
+ ;; Position the cursor at the current message.
+ (let ((cur-msg (car (mh-seq-to-msgs 'cur))))
+ (cond ((and cur-msg
+ (mh-goto-msg cur-msg t nil))
+ (mh-notate nil ?+ mh-cmd-note)
+ (mh-recenter 0)
+ (mh-maybe-show cur-msg))
+ (t
+ (mh-last-msg)
+ (message "No current message")))))
+
+
+(defun mh-pack-folder-1 (range)
+ ;; Close and pack the current folder.
+ (mh-process-or-undo-commands mh-current-folder)
+ (message "Packing folder...")
+ (mh-set-folder-modified-p t) ; lock folder while packing
+ (save-excursion
+ (mh-exec-cmd-quiet " *mh-temp*" "folder" mh-current-folder "-pack"))
+ (mh-regenerate-headers range))
+
+
+(defun mh-process-or-undo-commands (folder)
+ ;; If FOLDER has outstanding commands, then either process or discard them.
+ (set-buffer folder)
+ (if (mh-outstanding-commands-p)
+ (if (or mh-do-not-confirm
+ (y-or-n-p
+ "Process outstanding deletes and refiles (or lose them)? "))
+ (mh-process-commands folder)
+ (mh-undo-folder))
+ (mh-invalidate-show-buffer)))
+
+
+(defun mh-process-commands (folder)
+ ;; Process outstanding commands for the folder FOLDER.
+ (message "Processing deletes and refiles for %s..." folder)
+ (set-buffer folder)
+ (with-mh-folder-updating (nil)
+ ;; Update the unseen sequence if it exists
+ (if (and mh-seen-list (mh-seq-to-msgs mh-unseen-seq))
+ (mh-undefine-sequence mh-unseen-seq mh-seen-list))
+
+ ;; Then refile messages
+ (mh-mapc
+ (function
+ (lambda (dest)
+ (let ((msgs (mh-seq-to-msgs dest)))
+ (mh-when msgs
+ (apply 'mh-exec-cmd "refile"
+ "-src" folder (symbol-name dest) msgs)
+ (mh-delete-scan-msgs msgs)))))
+ mh-refile-list)
+
+ ;; Now delete messages
+ (mh-when mh-delete-list
+ (apply 'mh-exec-cmd "rmm" folder mh-delete-list)
+ (mh-delete-scan-msgs mh-delete-list))
+
+ ;; Don't need to remove sequences since delete and refile do so.
+
+ ;; Mark cur message
+ (if (> (buffer-size) 0)
+ (mh-define-sequence 'cur (list (or (mh-get-msg-num nil) "last"))))
+
+ (mh-invalidate-show-buffer)
+
+ (setq mh-delete-list nil
+ mh-refile-list nil
+ mh-seq-list (mh-read-folder-sequences mh-current-folder nil)
+ mh-seen-list nil)
+ (mh-unmark-all-headers t)
+ (mh-notate-user-sequences)
+ (message "Processing deletes and refiles for %s...done" folder)))
+
+
+(defun mh-delete-scan-msgs (msgs)
+ ;; Delete the scan listing lines for each of the msgs in the LIST.
+ ;; Optimized for speed (i.e., no regular expressions).
+ (setq msgs (sort msgs (function <))) ;okay to clobber msgs
+ (save-excursion
+ (mh-first-msg)
+ (while (and msgs (< (point) (point-max)))
+ (cond ((equal (mh-get-msg-num nil) (car msgs))
+ (delete-region (point) (save-excursion (forward-line) (point)))
+ (setq msgs (cdr msgs)))
+ (t
+ (forward-line))))))
+
+
+(defun mh-set-folder-modified-p (flag)
+ "Mark current folder as modified or unmodified according to FLAG."
+ (set-buffer-modified-p flag))
+
+
+(defun mh-outstanding-commands-p ()
+ ;; Returns non-nil if there are outstanding deletes or refiles.
+ (or mh-delete-list mh-refile-list))
+
+
+
+;;; Mode for composing and sending a draft message.
+
+(defvar mh-sent-from-folder nil
+ "Folder of msg associated with this letter.")
+
+(defvar mh-sent-from-msg nil
+ "Number of msg associated with this letter.")
+
+(defvar mh-send-args nil
+ "Extra arguments to pass to \"send\" command.")
+
+(defvar mh-annotate-char nil
+ "Character to use to annotate mh-sent-from-msg.")
+
+(defvar mh-annotate-field nil
+ "Field name for message annotation.")
+
+(defun mh-letter-mode ()
+ "Mode for composing letters in mh-e.
+When you have finished composing, type \\[mh-send-letter] to send the letter.
+
+Variables controlling this mode (defaults in parentheses):
+
+ mh-delete-yanked-msg-window (nil)
+ If non-nil, \\[mh-yank-cur-msg] will delete any windows displaying
+ the yanked message.
+
+ mh-yank-from-start-of-msg (t)
+ If non-nil, \\[mh-yank-cur-msg] will include the entire message.
+ If `body', just yank the body (no header).
+ If nil, only the portion of the message following the point will be yanked.
+ If there is a region, this variable is ignored.
+
+Upon invoking mh-letter-mode, text-mode-hook and mh-letter-mode-hook are
+invoked with no args, if those values are non-nil.
+
+\\{mh-letter-mode-map}"
+ (interactive)
+ (kill-all-local-variables)
+ (make-local-variable 'paragraph-start)
+ (setq paragraph-start (concat "^[ \t]*[-_][-_][-_]+$\\|" paragraph-start))
+ (make-local-variable 'paragraph-separate)
+ (setq paragraph-separate
+ (concat "^[ \t]*[-_][-_][-_]+$\\|" paragraph-separate))
+ (make-local-variable 'mh-send-args)
+ (make-local-variable 'mh-annotate-char)
+ (make-local-variable 'mh-annotate-field)
+ (make-local-variable 'mh-previous-window-config)
+ (make-local-variable 'mh-sent-from-folder)
+ (make-local-variable 'mh-sent-from-msg)
+ (use-local-map mh-letter-mode-map)
+ (setq major-mode 'mh-letter-mode)
+ (mh-set-mode-name "mh-e letter")
+ (set-syntax-table mh-letter-mode-syntax-table)
+ (run-hooks 'text-mode-hook 'mh-letter-mode-hook)
+ (mh-when auto-fill-hook
+ (make-local-variable 'auto-fill-hook)
+ (setq auto-fill-hook 'mh-auto-fill-for-letter)))
+
+
+(defun mh-auto-fill-for-letter ()
+ ;; Auto-fill in letters treats the header specially by inserting a tab
+ ;; before continuation line.
+ (do-auto-fill)
+ (if (mh-in-header-p)
+ (save-excursion
+ (beginning-of-line nil)
+ (insert-char ?\t 1))))
+
+
+(defun mh-in-header-p ()
+ ;; Return non-nil if the point is in the header of a draft message.
+ (save-excursion
+ (let ((cur-point (point)))
+ (goto-char (dot-min))
+ (re-search-forward "^--------" nil t)
+ (< cur-point (point)))))
+
+
+(defun mh-to-field ()
+ "Move point to the end of a specified header field.
+The field is indicated by the previous keystroke. Create the field if
+it does not exist. Set the mark to point before moving."
+ (interactive)
+ (expand-abbrev)
+ (let ((target (cdr (assoc (logior last-input-char ?`) mh-to-field-choices)))
+ (case-fold-search t))
+ (cond ((mh-position-on-field target t)
+ (let ((eol (point)))
+ (skip-chars-backward " \t")
+ (delete-region (point) eol))
+ (if (and (not (eq (logior last-input-char ?`) ?s))
+ (save-excursion
+ (backward-char 1)
+ (not (looking-at "[:,]"))))
+ (insert ", ")
+ (insert " ")))
+ (t
+ (goto-char (dot-min))
+ (re-search-forward "^To:")
+ (forward-line 1)
+ (while (looking-at "^[ \t]") (forward-line 1))
+ (insert (format "%s \n" target))
+ (backward-char 1)))))
+
+
+(defun mh-to-fcc ()
+ "Insert an Fcc: field in the current message.
+Prompt for the field name with a completion list of the current folders."
+ (interactive)
+ (let ((last-input-char ?\C-f)
+ (folder (mh-prompt-for-folder "Fcc" "" t)))
+ (expand-abbrev)
+ (save-excursion
+ (mh-to-field)
+ (insert (substring folder 1 nil)))))
+
+
+(defun mh-insert-signature ()
+ "Insert the file ~/.signature at the current point."
+ (interactive)
+ (insert-file-contents "~/.signature")
+ (set-buffer-modified-p (buffer-modified-p))) ; force mode line update
+
+
+(defun mh-check-whom ()
+ "Verify recipients of the current letter."
+ (interactive)
+ (let ((file-name (buffer-file-name)))
+ (set-buffer-modified-p t) ; Force writing of contents
+ (save-buffer)
+ (message "Checking recipients...")
+ (switch-to-buffer-other-window "*Mail Recipients*")
+ (bury-buffer (current-buffer))
+ (erase-buffer)
+ (mh-exec-cmd-output "whom" t file-name)
+ (other-window -1)
+ (message "Checking recipients...done")))
+
+
+
+;;; Routines to make a search pattern and search for a message.
+
+(defvar mh-searching-folder nil "Folder this pick is searching.")
+
+
+(defun mh-make-pick-template ()
+ ;; Initialize the current buffer with a template for a pick pattern.
+ (erase-buffer)
+ (kill-all-local-variables)
+ (make-local-variable 'mh-searching-folder)
+ (insert "From: \n"
+ "To: \n"
+ "Cc: \n"
+ "Date: \n"
+ "Subject: \n"
+ "---------\n")
+ (mh-letter-mode)
+ (use-local-map mh-pick-mode-map)
+ (goto-char (point-min))
+ (end-of-line))
+
+
+(defun mh-do-pick-search ()
+ "Find messages that match the qualifications in the current pattern buffer.
+Messages are searched for in the folder named in mh-searching-folder.
+Put messages found in a sequence named `search'."
+ (interactive)
+ (let ((pattern-buffer (buffer-name))
+ (searching-buffer mh-searching-folder)
+ (range)
+ (pattern nil)
+ (new-buffer nil))
+ (save-excursion
+ (cond ((get-buffer searching-buffer)
+ (set-buffer searching-buffer)
+ (setq range (format "%d-%d" mh-first-msg-num mh-last-msg-num)))
+ (t
+ (mh-make-folder searching-buffer)
+ (setq range "all")
+ (setq new-buffer t))))
+ (message "Searching...")
+ (goto-char (point-min))
+ (while (setq pattern (mh-next-pick-field pattern-buffer))
+ (setq msgs (mh-seq-from-command searching-buffer
+ 'search
+ (nconc (cons "pick" pattern)
+ (list searching-buffer
+ range
+ "-sequence" "search"
+ "-list"))))
+ (setq range "search"))
+ (message "Searching...done")
+ (if new-buffer
+ (mh-scan-folder searching-buffer msgs)
+ (switch-to-buffer searching-buffer))
+ (delete-other-windows)
+ (mh-notate-seq 'search ?% (1+ mh-cmd-note))))
+
+
+(defun mh-next-pick-field (buffer)
+ ;; Return the next piece of a pick argument that can be extracted from the
+ ;; BUFFER. Returns nil if no pieces remain.
+ (set-buffer buffer)
+ (let ((case-fold-search t))
+ (cond ((eobp)
+ nil)
+ ((re-search-forward "^\\([a-z].*\\):[ \t]*\\([a-z0-9].*\\)$" nil t)
+ (let* ((component
+ (format "--%s"
+ (downcase (buffer-substring (match-beginning 1)
+ (match-end 1)))))
+ (pat (buffer-substring (match-beginning 2) (match-end 2))))
+ (forward-line 1)
+ (list component pat)))
+ ((re-search-forward "^-*$" nil t)
+ (forward-char 1)
+ (let ((body (buffer-substring (point) (point-max))))
+ (if (and (> (length body) 0) (not (equal body "\n")))
+ (list "-search" body)
+ nil)))
+ (t
+ nil))))
+
+
+
+;;; Routines to compose and send a letter.
+
+(defun mh-compose-and-send-mail (draft send-args
+ sent-from-folder sent-from-msg
+ to subject cc
+ annotate-char annotate-field
+ config)
+ ;; Edit and compose a draft message in buffer DRAFT and send or save it.
+ ;; SENT-FROM-FOLDER is buffer containing scan listing of current folder, or
+ ;; nil if none exists.
+ ;; SENT-FROM-MSG is the message number or sequence name or nil.
+ ;; SEND-ARGS is an optional argument passed to the send command.
+ ;; The TO, SUBJECT, and CC fields are passed to the
+ ;; mh-compose-letter-function.
+ ;; If ANNOTATE-CHAR is non-null, it is used to notate the scan listing of the
+ ;; message. In that case, the ANNOTATE-FIELD is used to build a string
+ ;; for mh-annotate-msg.
+ ;; CONFIG is the window configuration to restore after sending the letter.
+ (pop-to-buffer draft)
+ (mh-letter-mode)
+ (setq mh-sent-from-folder sent-from-folder)
+ (setq mh-sent-from-msg sent-from-msg)
+ (setq mh-send-args send-args)
+ (setq mh-annotate-char annotate-char)
+ (setq mh-annotate-field annotate-field)
+ (setq mh-previous-window-config config)
+ (setq mode-line-buffer-identification (list "{%b}"))
+ (if (and (boundp 'mh-compose-letter-function)
+ (symbol-value 'mh-compose-letter-function))
+ ;; run-hooks will not pass arguments.
+ (let ((value (symbol-value 'mh-compose-letter-function)))
+ (if (and (listp value) (not (eq (car value) 'lambda)))
+ (while value
+ (funcall (car value) to subject cc)
+ (setq value (cdr value)))
+ (funcall mh-compose-letter-function to subject cc)))))
+
+
+(defun mh-send-letter (&optional arg)
+ "Send the draft letter in the current buffer.
+If optional prefix argument is provided, monitor delivery.
+Run mh-before-send-letter-hook before doing anything."
+ (interactive "P")
+ (run-hooks 'mh-before-send-letter-hook)
+ (set-buffer-modified-p t) ; Make sure buffer is written
+ (save-buffer)
+ (message "Sending...")
+ (let ((draft-buffer (current-buffer))
+ (file-name (buffer-file-name))
+ (config mh-previous-window-config))
+ (cond (arg
+ (pop-to-buffer "MH mail delivery")
+ (erase-buffer)
+ (if mh-send-args
+ (mh-exec-cmd-output "send" t "-watch" "-nopush"
+ "-nodraftfolder" mh-send-args file-name)
+ (mh-exec-cmd-output "send" t "-watch" "-nopush"
+ "-nodraftfolder" file-name))
+ (goto-char (point-max)) ; show the interesting part
+ (recenter -1)
+ (set-buffer draft-buffer)) ; for annotation below
+ (mh-send-args
+ (mh-exec-cmd-daemon "send" "-nodraftfolder" "-noverbose"
+ mh-send-args file-name))
+ (t
+ (mh-exec-cmd-daemon "send" "-nodraftfolder" "-noverbose"
+ file-name)))
+
+ (if mh-annotate-char
+ (mh-annotate-msg mh-sent-from-msg
+ mh-sent-from-folder
+ mh-annotate-char
+ "-component" mh-annotate-field
+ "-text" (format "\"%s %s\""
+ (mh-get-field "To:")
+ (mh-get-field "Cc:"))))
+
+ (mh-when (or (not arg)
+ (y-or-n-p "Kill draft buffer? "))
+ (kill-buffer draft-buffer)
+ (if config
+ (set-window-configuration config)))
+ (message "Sending...done")))
+
+
+(defun mh-insert-letter (prefix-provided folder msg)
+ "Insert a message from any folder into the current letter.
+Removes the message's headers using mh-invisible-headers.
+Prefixes each non-blank line with mh-ins-buf-prefix (default \">> \").
+If optional prefix argument provided, do not indent and do not delete
+headers. Leaves the mark before the letter and point after it."
+ (interactive
+ (list current-prefix-arg
+ (mh-prompt-for-folder "Message from" mh-sent-from-folder nil)
+ (read-input (format "Message number%s: "
+ (if mh-sent-from-msg
+ (format " [%d]" mh-sent-from-msg)
+ "")))))
+ (save-restriction
+ (narrow-to-region (point) (point))
+ (let ((start (point-min)))
+ (if (equal msg "") (setq msg (int-to-string mh-sent-from-msg)))
+ (mh-exec-lib-cmd-output "mhl" "-nobell" "-noclear"
+ (expand-file-name msg
+ (mh-expand-file-name folder)))
+ (mh-when (not prefix-provided)
+ (mh-clean-msg-header start mh-invisible-headers mh-visible-headers)
+ (set-mark start) ; since mh-clean-msg-header moves it
+ (mh-insert-prefix-string mh-ins-buf-prefix)))))
+
+
+(defun mh-yank-cur-msg ()
+ "Insert the current message into the draft buffer.
+Prefix each non-blank line in the message with the string in
+`mh-ins-buf-prefix'. If a region is set in the message's buffer, then
+only the region will be inserted. Otherwise, the entire message will
+be inserted if `mh-yank-from-start-of-msg' is non-nil. If this variable
+is nil, the portion of the message following the point will be yanked.
+If `mh-delete-yanked-msg-window' is non-nil, any window displaying the
+yanked message will be deleted."
+ (interactive)
+ (if (and mh-sent-from-folder mh-sent-from-msg)
+ (let ((to-point (point))
+ (to-buffer (current-buffer)))
+ (set-buffer mh-sent-from-folder)
+ (if mh-delete-yanked-msg-window
+ (delete-windows-on mh-show-buffer))
+ (set-buffer mh-show-buffer) ; Find displayed message
+ (let ((mh-ins-str (cond ((mark)
+ (buffer-substring (region-beginning)
+ (region-end)))
+ ((eq 'body mh-yank-from-start-of-msg)
+ (buffer-substring
+ (save-excursion
+ (goto-char (point-min))
+ (mh-goto-header-end 1)
+ (point))
+ (point-max)))
+ (mh-yank-from-start-of-msg
+ (buffer-substring (point-min) (point-max)))
+ (t
+ (buffer-substring (point) (point-max))))))
+ (set-buffer to-buffer)
+ (narrow-to-region to-point to-point)
+ (push-mark)
+ (insert mh-ins-str)
+ (mh-insert-prefix-string mh-ins-buf-prefix)
+ (insert "\n")
+ (widen)))
+ (error "There is no current message")))
+
+
+(defun mh-insert-prefix-string (mh-ins-string)
+ ;; Run MH-YANK-HOOK to insert a prefix string before each line in the buffer.
+ ;; Generality for supercite users.
+ (save-excursion
+ (set-mark (point-max))
+ (goto-char (point-min))
+ (run-hooks 'mh-yank-hooks)))
+
+
+(defun mh-fully-kill-draft ()
+ "Kill the draft message file and the draft message buffer.
+Use \\[kill-buffer] if you don't want to delete the draft message file."
+ (interactive)
+ (if (y-or-n-p "Kill draft message? ")
+ (let ((config mh-previous-window-config))
+ (if (file-exists-p (buffer-file-name))
+ (delete-file (buffer-file-name)))
+ (set-buffer-modified-p nil)
+ (kill-buffer (buffer-name))
+ (message "")
+ (if config
+ (set-window-configuration config)))
+ (error "Message not killed")))
+
+
+(defun mh-recenter (arg)
+ ;; Like recenter but with two improvements: nil arg means recenter,
+ ;; and only does anything if the current buffer is in the selected
+ ;; window. (Commands like save-some-buffers can make this false.)
+ (if (eql (get-buffer-window (current-buffer))
+ (selected-window))
+ (recenter (if arg arg '(t)))))
+
+
+
+;;; Commands to manipulate sequences. Sequences are stored in an alist
+;;; of the form:
+;;; ((seq-name msgs ...) (seq-name msgs ...) ...)
+
+(defun mh-make-seq (name msgs) (cons name msgs))
+
+(defmacro mh-seq-name (pair) (list 'car pair))
+
+(defmacro mh-seq-msgs (pair) (list 'cdr pair))
+
+(defun mh-find-seq (name) (assoc name mh-seq-list))
+
+
+(defun mh-seq-to-msgs (seq)
+ "Return a list of the messages in SEQUENCE."
+ (mh-seq-msgs (mh-find-seq seq)))
+
+
+(defun mh-seq-containing-msg (msg)
+ ;; Return a list of the sequences containing MESSAGE.
+ (let ((l mh-seq-list)
+ (seqs ()))
+ (while l
+ (if (memq msg (mh-seq-msgs (car l)))
+ (mh-push (mh-seq-name (car l)) seqs))
+ (setq l (cdr l)))
+ seqs))
+
+
+(defun mh-msg-to-seq (msg)
+ ;; Given a MESSAGE number, return the first sequence in which it occurs.
+ (car (mh-seq-containing-msg msg)))
+
+
+(defun mh-read-seq-default (prompt not-empty)
+ ;; Read and return sequence name with default narrowed or previous sequence.
+ (mh-read-seq prompt not-empty (or mh-narrowed-to-seq mh-previous-seq)))
+
+
+(defun mh-read-seq (prompt not-empty &optional default)
+ ;; Read and return a sequence name. Prompt with PROMPT, raise an error
+ ;; if the sequence is empty and the NOT-EMPTY flag is non-nil, and supply
+ ;; an optional DEFAULT sequence.
+ ;; A reply of '%' defaults to the first sequence containing the current
+ ;; message.
+ (let* ((input (completing-read (format "%s %s %s" prompt "sequence:"
+ (if default
+ (format "[%s] " default)
+ ""))
+ (mh-seq-names mh-seq-list)))
+ (seq (cond ((equal input "%") (mh-msg-to-seq (mh-get-msg-num t)))
+ ((equal input "") default)
+ (t (intern input))))
+ (msgs (mh-seq-to-msgs seq)))
+ (if (and (null msgs) not-empty)
+ (error (format "No messages in sequence `%s'" seq)))
+ seq))
+
+
+(defun mh-read-folder-sequences (folder define-sequences)
+ ;; Read and return the predefined sequences for a FOLDER. If
+ ;; DEFINE-SEQUENCES is non-nil, then define mh-e's sequences before
+ ;; reading MH's sequences.
+ (let ((seqs ()))
+ (mh-when define-sequences
+ (mh-define-sequences mh-seq-list)
+ (mh-mapc (function (lambda (seq) ; Save the internal sequences
+ (if (mh-folder-name-p (mh-seq-name seq))
+ (mh-push seq seqs))))
+ mh-seq-list))
+ (save-excursion
+ (mh-exec-cmd-quiet " *mh-temp*" "mark" folder "-list")
+ (goto-char (point-min))
+ ;; look for name in line of form "cur: 4" or "myseq (private): 23"
+ (while (re-search-forward "^[^: ]+" nil t)
+ (mh-push (mh-make-seq (intern (buffer-substring (match-beginning 0)
+ (match-end 0)))
+ (mh-read-msg-list))
+ seqs))
+ (delete-region (point-min) (point))) ; avoid race with mh-process-daemon
+ seqs))
+
+
+(defun mh-seq-names (seq-list)
+ ;; Return an alist containing the names of the SEQUENCES.
+ (mapcar (function (lambda (entry) (list (symbol-name (mh-seq-name entry)))))
+ seq-list))
+
+
+(defun mh-seq-from-command (folder seq seq-command)
+ ;; In FOLDER, make a sequence named SEQ by executing COMMAND.
+ ;; COMMAND is a list. The first element is a program name
+ ;; and the subsequent elements are its arguments, all strings.
+ (let ((msg)
+ (msgs ())
+ (case-fold-search t))
+ (save-excursion
+ (save-window-excursion
+ (apply 'mh-exec-cmd-quiet " *mh-temp*" seq-command)
+ (goto-char (point-min))
+ (while (setq msg (car (mh-read-msg-list)))
+ (mh-push msg msgs)
+ (forward-line 1)))
+ (set-buffer folder)
+ (setq msgs (nreverse msgs)) ; Put in ascending order
+ (mh-push (mh-make-seq seq msgs) mh-seq-list)
+ msgs)))
+
+
+(defun mh-read-msg-list ()
+ ;; Return a list of message numbers from the current point to the end of
+ ;; the line.
+ (let ((msgs ())
+ (end-of-line (save-excursion (end-of-line) (point)))
+ num)
+ (while (re-search-forward "[0-9]+" end-of-line t)
+ (setq num (string-to-int (buffer-substring (match-beginning 0)
+ (match-end 0))))
+ (cond ((looking-at "-") ; Message range
+ (forward-char 1)
+ (re-search-forward "[0-9]+" end-of-line t)
+ (let ((num2 (string-to-int (buffer-substring (match-beginning 0)
+ (match-end 0)))))
+ (if (< num2 num)
+ (error "Bad message range: %d-%d" num num2))
+ (while (<= num num2)
+ (mh-push num msgs)
+ (setq num (1+ num)))))
+ ((not (zerop num)) (mh-push num msgs))))
+ msgs))
+
+
+(defun mh-remove-seq (seq)
+ ;; Delete the SEQUENCE.
+ (mh-map-to-seq-msgs 'mh-notate-if-in-one-seq seq ? (1+ mh-cmd-note) seq)
+ (mh-undefine-sequence seq (list "all"))
+ (mh-delete-seq-locally seq))
+
+
+(defun mh-delete-seq-locally (seq)
+ ;; Remove mh-e's record of SEQUENCE.
+ (let ((entry (mh-find-seq seq)))
+ (setq mh-seq-list (delq entry mh-seq-list))))
+
+
+(defun mh-remove-msg-from-seq (msg seq &optional internal-flag)
+ ;; Remove MESSAGE from the SEQUENCE. If optional FLAG is non-nil, do not
+ ;; inform MH of the change.
+ (let ((entry (mh-find-seq seq)))
+ (mh-when entry
+ (mh-notate-if-in-one-seq msg ? (1+ mh-cmd-note) (mh-seq-name entry))
+ (if (not internal-flag)
+ (mh-undefine-sequence seq (list msg)))
+ (setcdr entry (delq msg (mh-seq-msgs entry))))))
+
+
+(defun mh-add-msgs-to-seq (msgs seq &optional internal-flag)
+ ;; Add MESSAGE(s) to the SEQUENCE. If optional FLAG is non-nil, do not mark
+ ;; the message in the scan listing or inform MH of the addition.
+ (let ((entry (mh-find-seq seq)))
+ (if (and msgs (atom msgs)) (setq msgs (list msgs)))
+ (if (null entry)
+ (mh-push (mh-make-seq seq msgs) mh-seq-list)
+ (if msgs (setcdr entry (append msgs (cdr entry)))))
+ (mh-when (not internal-flag)
+ (mh-add-to-sequence seq msgs)
+ (mh-notate-seq seq ?% (1+ mh-cmd-note)))))
+
+
+(defun mh-rename-seq (seq new-name)
+ "Rename a SEQUENCE to have a new NAME."
+ (interactive "SOld sequence name: \nSNew name: ")
+ (let ((old-seq (mh-find-seq seq)))
+ (if old-seq
+ (rplaca old-seq new-name)
+ (error "Sequence %s does not exists" seq))
+ (mh-undefine-sequence seq (mh-seq-msgs old-seq))
+ (mh-define-sequence new-name (mh-seq-msgs old-seq))))
+
+
+(defun mh-notate-user-sequences ()
+ ;; Mark the scan listing of all messages in user-defined sequences.
+ (let ((seqs mh-seq-list)
+ name)
+ (while seqs
+ (setq name (mh-seq-name (car seqs)))
+ (if (not (mh-internal-seq name))
+ (mh-notate-seq name ?% (1+ mh-cmd-note)))
+ (setq seqs (cdr seqs)))))
+
+
+(defun mh-internal-seq (name)
+ ;; Return non-NIL if NAME is the name of an internal mh-e sequence.
+ (or (memq name '(answered cur deleted forwarded printed))
+ (eq name mh-unseen-seq)
+ (mh-folder-name-p name)))
+
+
+(defun mh-folder-name-p (name)
+ ;; Return non-NIL if NAME is possibly the name of a folder.
+ ;; A name (a string or symbol) can be a folder name if it begins with "+".
+ (if (symbolp name)
+ (eql (aref (symbol-name name) 0) ?+)
+ (eql (aref name 0) ?+)))
+
+
+(defun mh-notate-seq (seq notation offset)
+ ;; Mark the scan listing of all messages in the SEQUENCE with the CHARACTER
+ ;; at the given OFFSET from the beginning of the listing line.
+ (mh-map-to-seq-msgs 'mh-notate seq notation offset))
+
+
+(defun mh-notate-if-in-one-seq (msg notation offset seq)
+ ;; If the MESSAGE is in only the SEQUENCE, then mark the scan listing of the
+ ;; message with the CHARACTER at the given OFFSET from the beginning of the
+ ;; listing line.
+ (let ((in-seqs (mh-seq-containing-msg msg)))
+ (if (and (eq seq (car in-seqs)) (null (cdr in-seqs)))
+ (mh-notate msg notation offset))))
+
+
+(defun mh-map-to-seq-msgs (func seq &rest args)
+ ;; Invoke the FUNCTION at each message in the SEQUENCE, passing the
+ ;; remaining ARGS as arguments.
+ (save-excursion
+ (let ((msgs (mh-seq-to-msgs seq)))
+ (while msgs
+ (if (mh-goto-msg (car msgs) t t)
+ (apply func (car msgs) args))
+ (setq msgs (cdr msgs))))))
+
+
+(defun mh-map-over-seqs (func seq-list)
+ ;; Apply the FUNCTION to each element in the list of SEQUENCES,
+ ;; passing the sequence name and the list of messages as arguments.
+ (while seq-list
+ (funcall func (mh-seq-name (car seq-list)) (mh-seq-msgs (car seq-list)))
+ (setq seq-list (cdr seq-list))))
+
+
+(defun mh-define-sequences (seq-list)
+ ;; Define the sequences in SEQ-LIST.
+ (mh-map-over-seqs 'mh-define-sequence seq-list))
+
+
+(defun mh-add-to-sequence (seq msgs)
+ ;; Add to a SEQUENCE each message the list of MSGS.
+ (if (not (mh-folder-name-p seq))
+ (if msgs
+ (apply 'mh-exec-cmd "mark" mh-current-folder
+ "-sequence" (symbol-name seq)
+ "-add" msgs))))
+
+
+(defun mh-define-sequence (seq msgs)
+ ;; Define the SEQUENCE to contain the list of MSGS. Do not mark
+ ;; pseudo-sequences or empty sequences.
+ (if (and msgs
+ (not (mh-folder-name-p seq)))
+ (save-excursion
+ (apply 'mh-exec-cmd "mark" mh-current-folder
+ "-sequence" (symbol-name seq)
+ "-add" "-zero" (mh-list-to-string msgs)))))
+
+
+(defun mh-undefine-sequence (seq msgs)
+ ;; Remove from the SEQUENCE the list of MSGS.
+ (apply 'mh-exec-cmd "mark" mh-current-folder
+ "-sequence" (symbol-name seq)
+ "-delete" msgs))
+
+
+(defun mh-copy-seq-to-point (seq location)
+ ;; Copy the scan listing of the messages in SEQUENCE to after the point
+ ;; LOCATION in the current buffer.
+ (mh-map-to-seq-msgs 'mh-copy-line-to-point seq location))
+
+
+(defun mh-copy-line-to-point (msg location)
+ ;; Copy the current line to the LOCATION in the current buffer.
+ (beginning-of-line)
+ (let ((beginning-of-line (point)))
+ (forward-line 1)
+ (copy-region-as-kill beginning-of-line (point))
+ (goto-char location)
+ (yank)
+ (goto-char beginning-of-line)))
+
+
+
+;;; Issue commands to MH.
+
+(defun mh-exec-cmd (command &rest args)
+ ;; Execute MH command COMMAND with ARGS.
+ ;; Any output is assumed to be an error and is shown to the user.
+ (save-excursion
+ (set-buffer " *mh-temp*")
+ (erase-buffer)
+ (apply 'call-process
+ (expand-file-name command mh-progs) nil t nil
+ (mh-list-to-string args))
+ (if (> (buffer-size) 0)
+ (save-window-excursion
+ (switch-to-buffer-other-window " *mh-temp*")
+ (sit-for 5)))))
+
+
+(defun mh-exec-cmd-quiet (buffer command &rest args)
+ ;; In BUFFER, execute MH command COMMAND with ARGS.
+ ;; ARGS is a list of strings. Return in BUFFER, if one exists.
+ (mh-when (stringp buffer)
+ (set-buffer buffer)
+ (erase-buffer))
+ (apply 'call-process
+ (expand-file-name command mh-progs) nil buffer nil
+ args))
+
+
+(defun mh-exec-cmd-output (command display &rest args)
+ ;; Execute MH command COMMAND with DISPLAY flag and ARGS putting the output
+ ;; into buffer after point. Set mark after inserted text.
+ (push-mark (point) t)
+ (apply 'call-process
+ (expand-file-name command mh-progs) nil t display
+ (mh-list-to-string args))
+ (exchange-point-and-mark))
+
+
+(defun mh-exec-cmd-daemon (command &rest args)
+ ;; Execute MH command COMMAND with ARGS. Any output from command is
+ ;; displayed in an asynchronous pop-up window.
+ (save-excursion
+ (set-buffer (get-buffer-create " *mh-temp*"))
+ (erase-buffer))
+ (let* ((process-connection-type nil)
+ (process (apply 'start-process
+ command nil
+ (expand-file-name command mh-progs)
+ (mh-list-to-string args))))
+ (set-process-filter process 'mh-process-daemon)))
+
+
+(defun mh-process-daemon (process output)
+ ;; Process daemon that puts output into a temporary buffer.
+ (set-buffer (get-buffer-create " *mh-temp*"))
+ (insert-before-markers output)
+ (display-buffer " *mh-temp*"))
+
+
+(defun mh-exec-lib-cmd-output (command &rest args)
+ ;; Execute MH library command COMMAND with ARGS.
+ ;; Put the output into buffer after point. Set mark after inserted text.
+ (push-mark (point) t)
+ (apply 'call-process
+ (expand-file-name command mh-lib) nil t nil
+ (mh-list-to-string args))
+ (exchange-point-and-mark))
+
+
+(defun mh-list-to-string (l)
+ ;; Flattens the list L and makes every element of the new list into a string.
+ (let ((new-list nil))
+ (while l
+ (cond ((null (car l)))
+ ((symbolp (car l)) (mh-push (symbol-name (car l)) new-list))
+ ((numberp (car l)) (mh-push (int-to-string (car l)) new-list))
+ ((equal (car l) ""))
+ ((stringp (car l)) (mh-push (car l) new-list))
+ ((listp (car l))
+ (setq new-list (nconc (nreverse (mh-list-to-string (car l)))
+ new-list)))
+ (t (error "Bad element in mh-list-to-string: %s" (car l))))
+ (setq l (cdr l)))
+ (nreverse new-list)))
+
+
+
+;;; Commands to annotate a message.
+
+(defun mh-annotate-msg (msg buffer note &rest args)
+ ;; Mark the MESSAGE in BUFFER listing with the character NOTE and annotate
+ ;; the saved message with ARGS.
+ (apply 'mh-exec-cmd "anno" buffer msg args)
+ (save-excursion
+ (cond ((get-buffer buffer) ; Buffer may be deleted
+ (set-buffer buffer)
+ (if (symbolp msg)
+ (mh-notate-seq msg note (1+ mh-cmd-note))
+ (mh-notate msg note (1+ mh-cmd-note)))))))
+
+
+(defun mh-notate (msg notation offset)
+ ;; Marks MESSAGE with the character NOTATION at position OFFSET.
+ ;; Null MESSAGE means the message that the cursor points to.
+ (save-excursion
+ (if (or (null msg)
+ (mh-goto-msg msg t t))
+ (with-mh-folder-updating (t)
+ (beginning-of-line)
+ (forward-char offset)
+ (delete-char 1)
+ (insert notation)))))
+
+
+
+;;; User prompting commands.
+
+(defun mh-prompt-for-folder (prompt default can-create)
+ ;; Prompt for a folder name with PROMPT. Returns the folder's name as a
+ ;; string. DEFAULT is used if the folder exists and the user types return.
+ ;; If the CAN-CREATE flag is t, then a non-existent folder is made.
+ (let* ((prompt (format "%s folder%s" prompt
+ (if (equal "" default)
+ "? "
+ (format " [%s]? " default))))
+ name)
+ (if (null mh-folder-list)
+ (mh-set-folder-list))
+ (while (and (setq name (completing-read prompt mh-folder-list
+ nil nil "+"))
+ (equal name "")
+ (equal default "")))
+ (cond ((or (equal name "") (equal name "+"))
+ (setq name default))
+ ((not (mh-folder-name-p name))
+ (setq name (format "+%s" name))))
+ (let ((new-file-p (not (file-exists-p (mh-expand-file-name name)))))
+ (cond ((and new-file-p
+ (y-or-n-p
+ (format "Folder %s does not exist. Create it? " name)))
+ (message "Creating %s" name)
+ (call-process "mkdir" nil nil nil (mh-expand-file-name name))
+ (message "Creating %s...done" name)
+ (mh-push (list name) mh-folder-list))
+ (new-file-p
+ (error "Folder %s is not created" name))
+ (t
+ (mh-when (null (assoc name mh-folder-list))
+ (mh-push (list name) mh-folder-list)))))
+ name))
+
+
+(defun mh-set-folder-list ()
+ "Sets mh-folder-list correctly.
+A useful function for the command line or for when you need to sync by hand."
+ (setq mh-folder-list (mh-make-folder-list)))
+
+
+(defun mh-make-folder-list ()
+ "Return a list of the user's folders.
+Result is in a form suitable for completing read."
+ (interactive)
+ (message "Collecting folder names...")
+ (save-window-excursion
+ (mh-exec-cmd-quiet " *mh-temp*" "folders" "-fast"
+ (if mh-recursive-folders
+ "-recurse"
+ "-norecurse"))
+ (goto-char (point-min))
+ (let ((list nil)
+ start)
+ (while (not (eobp))
+ (setq start (point))
+ (forward-line 1)
+ (mh-push (list (format "+%s" (buffer-substring start (1- (point)))))
+ list))
+ (message "Collecting folder names...done")
+ list)))
+
+
+(defun mh-remove-folder-from-folder-list (folder)
+ ;; Remove FOLDER from the list of folders.
+ (setq mh-folder-list
+ (delq (assoc folder mh-folder-list) mh-folder-list)))
+
+
+(defun mh-read-msg-range (prompt)
+ ;; Read a list of blank-separated items.
+ (let* ((buf (read-string prompt))
+ (buf-size (length buf))
+ (start 0)
+ (input ()))
+ (while (< start buf-size)
+ (let ((next (read-from-string buf start buf-size)))
+ (mh-push (car next) input)
+ (setq start (cdr next))))
+ (nreverse input)))
+
+
+
+;;; Misc. functions.
+
+(defun mh-get-msg-num (error-if-no-message)
+ ;; Return the message number of the displayed message. If the argument
+ ;; ERROR-IF-NO-MESSAGE is non-nil, then complain if the cursor is not
+ ;; pointing to a message.
+ (save-excursion
+ (beginning-of-line)
+ (cond ((looking-at mh-msg-number-regexp)
+ (string-to-int (buffer-substring (match-beginning 1)
+ (match-end 1))))
+ (error-if-no-message
+ (error "Cursor not pointing to message"))
+ (t nil))))
+
+
+(defun mh-msg-search-pat (n)
+ ;; Return a search pattern for message N in the scan listing.
+ (format mh-msg-search-regexp n))
+
+
+(defun mh-msg-filename (msg &optional folder)
+ ;; Return the file name of MESSAGE in FOLDER (default current folder).
+ (expand-file-name (int-to-string msg)
+ (if folder
+ (mh-expand-file-name folder)
+ mh-folder-filename)))
+
+
+(defun mh-msg-filenames (msgs &optional folder)
+ ;; Return a list of file names for MSGS in FOLDER (default current folder).
+ (mapconcat (function (lambda (msg) (mh-msg-filename msg folder))) msgs " "))
+
+
+(defun mh-expand-file-name (filename &optional default)
+ "Just like `expand-file-name', but also handles MH folder names.
+Assumes that any filename that starts with '+' is a folder name."
+ (if (mh-folder-name-p filename)
+ (expand-file-name (substring filename 1) mh-user-path)
+ (expand-file-name filename default)))
+
+
+(defun mh-find-path ()
+ ;; Set mh-user-path, mh-draft-folder, and mh-unseen-seq from profile file.
+ (save-excursion
+ ;; Be sure profile is fully expanded before switching buffers
+ (let ((profile (expand-file-name (or (getenv "MH") "~/.mh_profile"))))
+ (if (not (file-exists-p profile))
+ (error "Cannot find MH profile %s" profile))
+ (set-buffer (get-buffer-create " *mh-temp*"))
+ (erase-buffer)
+ (insert-file-contents profile)
+ (setq mh-draft-folder (mh-get-field "Draft-Folder:"))
+ (cond ((equal mh-draft-folder "")
+ (setq mh-draft-folder nil))
+ ((not (mh-folder-name-p mh-draft-folder))
+ (setq mh-draft-folder (format "+%s" mh-draft-folder))))
+ (setq mh-user-path (mh-get-field "Path:"))
+ (if (equal mh-user-path "")
+ (setq mh-user-path "Mail"))
+ (setq mh-user-path
+ (file-name-as-directory
+ (expand-file-name mh-user-path (expand-file-name "~"))))
+ (if (and mh-draft-folder
+ (not (file-exists-p (mh-expand-file-name mh-draft-folder))))
+ (error "Draft folder %s does not exist. Create it and try again."
+ mh-draft-folder))
+ (setq mh-unseen-seq (mh-get-field "Unseen-Sequence:"))
+ (if (equal mh-unseen-seq "")
+ (setq mh-unseen-seq 'unseen)
+ (setq mh-unseen-seq (intern mh-unseen-seq))))))
+
+
+(defun mh-get-field (field)
+ ;; Find and return the value of field FIELD in the current buffer.
+ ;; Returns the empty string if the field is not in the message.
+ (let ((case-fold-search t))
+ (goto-char (point-min))
+ (cond ((not (re-search-forward (format "^%s" field) nil t)) "")
+ ((looking-at "[\t ]*$") "")
+ (t
+ (re-search-forward "[\t ]*\\([^\t \n].*\\)$" nil t)
+ (let ((start (match-beginning 1)))
+ (forward-line 1)
+ (while (looking-at "[ \t]")
+ (forward-line 1))
+ (buffer-substring start (1- (point))))))))
+
+
+(defun mh-insert-fields (&rest name-values)
+ ;; Insert the NAME-VALUE pairs in the current buffer.
+ ;; Do not insert any pairs whose value is the empty string.
+ (let ((case-fold-search t))
+ (while name-values
+ (let ((field-name (car name-values))
+ (value (car (cdr name-values))))
+ (mh-when (not (equal value ""))
+ (goto-char (point-min))
+ (cond ((not (re-search-forward (format "^%s" field-name) nil t))
+ (mh-goto-header-end 0)
+ (insert field-name " " value "\n"))
+ (t
+ (end-of-line)
+ (insert " " value))))
+ (setq name-values (cdr (cdr name-values)))))))
+
+
+(defun mh-position-on-field (field set-mark)
+ ;; Set point to the end of the line beginning with FIELD.
+ ;; Set the mark to the old value of point, if SET-MARK is non-nil.
+ ;; Returns non-nil iff the field was found.
+ (let ((case-fold-search t))
+ (if set-mark (push-mark))
+ (goto-char (point-min))
+ (mh-goto-header-end 0)
+ (if (re-search-backward (format "^%s" field) nil t)
+ (progn (end-of-line) t)
+ nil)))
+
+
+(defun mh-goto-header-end (arg)
+ ;; Find the end of the message header in the current buffer and position
+ ;; the cursor at the ARG'th newline after the header.
+ (if (re-search-forward "^$\\|^-+$" nil nil)
+ (forward-line arg)))
+
+
+
+;;; Build the folder-mode keymap:
+
+(suppress-keymap mh-folder-mode-map)
+(define-key mh-folder-mode-map "q" 'mh-quit)
+(define-key mh-folder-mode-map "b" 'mh-quit)
+(define-key mh-folder-mode-map "?" 'mh-msg-is-in-seq)
+(define-key mh-folder-mode-map "%" 'mh-put-msg-in-seq)
+(define-key mh-folder-mode-map "|" 'mh-pipe-msg)
+(define-key mh-folder-mode-map "\ea" 'mh-edit-again)
+(define-key mh-folder-mode-map "\e%" 'mh-delete-msg-from-seq)
+(define-key mh-folder-mode-map "\C-xn" 'mh-narrow-to-seq)
+(define-key mh-folder-mode-map "\C-xw" 'mh-widen)
+(define-key mh-folder-mode-map "\eb" 'mh-burst-digest)
+(define-key mh-folder-mode-map "\eu" 'mh-undo-folder)
+(define-key mh-folder-mode-map "\e " 'mh-page-digest)
+(define-key mh-folder-mode-map "\e\177" 'mh-page-digest-backwards)
+(define-key mh-folder-mode-map "\ee" 'mh-extract-rejected-mail)
+(define-key mh-folder-mode-map "\ef" 'mh-visit-folder)
+(define-key mh-folder-mode-map "\ek" 'mh-kill-folder)
+(define-key mh-folder-mode-map "\el" 'mh-list-folders)
+(define-key mh-folder-mode-map "\eo" 'mh-write-msg-to-file)
+(define-key mh-folder-mode-map "\ep" 'mh-pack-folder)
+(define-key mh-folder-mode-map "\es" 'mh-search-folder)
+(define-key mh-folder-mode-map "\er" 'mh-rescan-folder)
+(define-key mh-folder-mode-map "l" 'mh-print-msg)
+(define-key mh-folder-mode-map "t" 'mh-toggle-showing)
+(define-key mh-folder-mode-map "c" 'mh-copy-msg)
+(define-key mh-folder-mode-map ">" 'mh-write-msg-to-file)
+(define-key mh-folder-mode-map "i" 'mh-inc-folder)
+(define-key mh-folder-mode-map "x" 'mh-execute-commands)
+(define-key mh-folder-mode-map "e" 'mh-execute-commands)
+(define-key mh-folder-mode-map "r" 'mh-redistribute)
+(define-key mh-folder-mode-map "f" 'mh-forward)
+(define-key mh-folder-mode-map "s" 'mh-send)
+(define-key mh-folder-mode-map "m" 'mh-send)
+(define-key mh-folder-mode-map "a" 'mh-reply)
+(define-key mh-folder-mode-map "j" 'mh-goto-msg)
+(define-key mh-folder-mode-map "<" 'mh-first-msg)
+(define-key mh-folder-mode-map "g" 'mh-goto-msg)
+(define-key mh-folder-mode-map "\177" 'mh-previous-page)
+(define-key mh-folder-mode-map " " 'mh-page-msg)
+(define-key mh-folder-mode-map "." 'mh-show)
+(define-key mh-folder-mode-map "u" 'mh-undo)
+(define-key mh-folder-mode-map "!" 'mh-refile-or-write-again)
+(define-key mh-folder-mode-map "^" 'mh-refile-msg)
+(define-key mh-folder-mode-map "d" 'mh-delete-msg)
+(define-key mh-folder-mode-map "\C-d" 'mh-delete-msg-no-motion)
+(define-key mh-folder-mode-map "p" 'mh-previous-undeleted-msg)
+(define-key mh-folder-mode-map "n" 'mh-next-undeleted-msg)
+(define-key mh-folder-mode-map "o" 'mh-refile-msg)
+
+
+;;; Build the letter-mode keymap:
+
+(define-key mh-letter-mode-map "\C-c\C-f\C-b" 'mh-to-field)
+(define-key mh-letter-mode-map "\C-c\C-f\C-c" 'mh-to-field)
+(define-key mh-letter-mode-map "\C-c\C-f\C-f" 'mh-to-fcc)
+(define-key mh-letter-mode-map "\C-c\C-f\C-s" 'mh-to-field)
+(define-key mh-letter-mode-map "\C-c\C-f\C-t" 'mh-to-field)
+(define-key mh-letter-mode-map "\C-c\C-fb" 'mh-to-field)
+(define-key mh-letter-mode-map "\C-c\C-fc" 'mh-to-field)
+(define-key mh-letter-mode-map "\C-c\C-ff" 'mh-to-fcc)
+(define-key mh-letter-mode-map "\C-c\C-fs" 'mh-to-field)
+(define-key mh-letter-mode-map "\C-c\C-ft" 'mh-to-field)
+(define-key mh-letter-mode-map "\C-c\C-q" 'mh-fully-kill-draft)
+(define-key mh-letter-mode-map "\C-c\C-w" 'mh-check-whom)
+(define-key mh-letter-mode-map "\C-c\C-i" 'mh-insert-letter)
+(define-key mh-letter-mode-map "\C-c\C-y" 'mh-yank-cur-msg)
+(define-key mh-letter-mode-map "\C-c\C-s" 'mh-insert-signature)
+(define-key mh-letter-mode-map "\C-c\C-c" 'mh-send-letter)
+
+
+;;; Build the pick-mode keymap:
+
+(define-key mh-pick-mode-map "\C-c\C-c" 'mh-do-pick-search)
+(define-key mh-pick-mode-map "\C-c\C-f\C-b" 'mh-to-field)
+(define-key mh-pick-mode-map "\C-c\C-f\C-c" 'mh-to-field)
+(define-key mh-pick-mode-map "\C-c\C-f\C-f" 'mh-to-field)
+(define-key mh-pick-mode-map "\C-c\C-f\C-s" 'mh-to-field)
+(define-key mh-pick-mode-map "\C-c\C-f\C-t" 'mh-to-field)
+(define-key mh-pick-mode-map "\C-c\C-fb" 'mh-to-field)
+(define-key mh-pick-mode-map "\C-c\C-fc" 'mh-to-field)
+(define-key mh-pick-mode-map "\C-c\C-ff" 'mh-to-field)
+(define-key mh-pick-mode-map "\C-c\C-fs" 'mh-to-field)
+(define-key mh-pick-mode-map "\C-c\C-ft" 'mh-to-field)
+(define-key mh-pick-mode-map "\C-c\C-w" 'mh-check-whom)
+
+
+
+;;; For Gnu Emacs.
+;;; Local Variables: ***
+;;; eval: (put 'mh-when 'lisp-indent-hook 1) ***
+;;; eval: (put 'with-mh-folder-updating 'lisp-indent-hook 1) ***
+;;; End: ***
diff --git a/lisp/mh-e.elc b/lisp/mh-e.elc
new file mode 100644
index 00000000000..bc1a244d6ed
--- /dev/null
+++ b/lisp/mh-e.elc
@@ -0,0 +1,1128 @@
+
+(defvar mh-e-RCS-id)
+
+(setq mh-e-RCS-id "$Header: mh-e.el,v 3.5 92/01/21 11:21:59 gildea Exp $")
+
+(setq mh-e-time-stamp "92/01/21 10:59:18 gildea")
+
+(provide (quote mh-e))
+
+(defvar mh-redist-full-contents nil "\
+Non-nil if the `dist' command needs whole letter for redistribution.
+This is the case when `send' is compiled with the BERK option.")
+
+(defvar mh-folder-mode-hook nil "\
+Invoked in `mh-folder mode' on a new folder.")
+
+(defvar mh-letter-mode-hook nil "\
+Invoked in `mh-letter-mode' on a new letter.")
+
+(defvar mh-compose-letter-function nil "\
+Invoked in `mh-compose-and-send-mail' on a draft letter.
+It is passed three arguments: TO recipients, SUBJECT, and CC recipients.")
+
+(defvar mh-before-send-letter-hook nil "\
+Invoked at the beginning of the \\[mh-send-letter] command.")
+
+(defvar mh-inc-folder-hook nil "\
+Invoked after incorporating mail into a folder with \\[mh-inc-folder].")
+
+(defvar mh-before-quit-hook nil "\
+Invoked by \\[mh-quit] before quitting mh-e. See also mh-quit-hook")
+
+(defvar mh-quit-hook nil "\
+Invoked after quitting mh-e by \\[mh-quit]. See also mh-before-quit-hook")
+
+(defvar mh-ins-string nil "\
+Temporarily set by `mh-insert-prefix' prior to running `mh-yank-hooks'.")
+
+(defvar mh-yank-hooks (quote (lambda nil (save-excursion (goto-char (point)) (or (bolp) (forward-line 1)) (while (< (point) (mark)) (insert mh-ins-string) (forward-line 1))))) "\
+Hook to run citation function.
+Expects POINT and MARK to be set to the region to cite.")
+
+(defvar mh-clean-message-header nil "\
+*Non-nil means clean headers of messages that are displayed or inserted.
+The variables `mh-visible-headers' and `mh-invisible-headers' control what
+is removed.")
+
+(defvar mh-visible-headers nil "\
+*If non-nil, contains a regexp specifying the headers to keep when cleaning.
+Only used if `mh-clean-message-header' is non-nil. Setting this variable
+overrides `mh-invisible-headers'.")
+
+(defvar mhl-formfile nil "\
+*Name of format file to be used by mhl to show messages.
+A value of T means use the default format file.
+Nil means don't use mhl to format messages.")
+
+(defvar mh-lpr-command-format "lpr -p -J '%s'" "\
+*Format for Unix command that prints a message.
+The string should be a Unix command line, with the string '%s' where
+the job's name (folder and message number) should appear. The message text
+is piped to this command.")
+
+(defvar mh-print-background nil "\
+*Print messages in the background if non-nil.
+WARNING: do not delete the messages until printing is finished;
+otherwise, your output may be truncated.")
+
+(defvar mh-summary-height 4 "\
+*Number of lines in summary window (including the mode line).")
+
+(defvar mh-recenter-summary-p nil "\
+*Recenter summary window when the show window is toggled off if non-nil.")
+
+(defvar mh-ins-buf-prefix "> " "\
+*String to put before each non-blank line of a yanked or inserted message.
+Used when the message is inserted in an outgoing letter.")
+
+(defvar mh-do-not-confirm nil "\
+*Non-nil means do not prompt for confirmation before some commands.
+Only affects certain innocuous commands.")
+
+(defvar mh-bury-show-buffer t "\
+*Non-nil means that the displayed show buffer for a folder is buried.")
+
+(defvar mh-delete-yanked-msg-window nil "\
+*Controls window display when a message is yanked by \\[mh-yank-cur-msg].
+If non-nil, yanking the current message into a draft letter deletes any
+windows displaying the message.")
+
+(defvar mh-yank-from-start-of-msg t "\
+*Controls which part of a message is yanked by \\[mh-yank-cur-msg].
+If non-nil, include the entire message. If the symbol `body', then yank the
+message minus the header. If nil, yank only the portion of the message
+following the point. If the show buffer has a region, this variable is
+ignored.")
+
+(defvar mh-reply-default-reply-to nil "\
+*Sets the person or persons to whom a reply will be sent.
+If nil, prompt for recipient. If non-nil, then \\[mh-reply] will use this
+value and it should be one of \"from\", \"to\", or \"cc\".")
+
+(defvar mh-recursive-folders nil "\
+*If non-nil, then commands which operate on folders do so recursively.")
+
+(defvar mh-unshar-default-directory "" "\
+*Default for directory name prompted for by mh-unshar-msg.")
+
+(defvar mh-cmd-note 4 "\
+Offset to insert notation.")
+
+(defvar mh-note-repl "-" "\
+String whose first character is used to notate replied to messages.")
+
+(defvar mh-note-forw "F" "\
+String whose first character is used to notate forwarded messages.")
+
+(defvar mh-note-dist "R" "\
+String whose first character is used to notate redistributed messages.")
+
+(defvar mh-good-msg-regexp "^....[^D^]" "\
+Regexp specifiying the scan lines that are 'good' messages.")
+
+(defvar mh-deleted-msg-regexp "^....D" "\
+Regexp matching scan lines of deleted messages.")
+
+(defvar mh-refiled-msg-regexp "^....\\^" "\
+Regexp matching scan lines of refiled messages.")
+
+(defvar mh-valid-scan-line "^ *[0-9]" "\
+Regexp matching scan lines for messages (not error messages).")
+
+(defvar mh-msg-number-regexp "^ *\\([0-9]+\\)" "\
+Regexp to find the number of a message in a scan line.
+The message's number must be surrounded with \\( \\)")
+
+(defvar mh-msg-search-regexp "^[^0-9]*%d[^0-9]" "\
+Format string containing a regexp matching the scan listing for a message.
+The desired message's number will be an argument to format.")
+
+(defvar mh-flagged-scan-msg-regexp "^....\\D\\|^....\\^\\|^....\\+\\|^.....%" "\
+Regexp matching flagged scan lines.
+Matches lines marked as deleted, refiled, in a sequence, or the cur message.")
+
+(defvar mh-cur-scan-msg-regexp "^....\\+" "\
+Regexp matching scan line for the cur message.")
+
+(defvar mh-show-buffer-mode-line-buffer-id "{%%b} %s/%d" "\
+Format string to produce `mode-line-buffer-id' for show buffers.
+First argument is folder name. Second is message number.")
+
+(defvar mh-partial-folder-mode-line-annotation "select" "\
+Annotation when displaying part of a folder.
+The string is displayed after the folder's name. NIL for no annotation.")
+
+(defvar mh-invisible-headers "^Received: \\|^Message-Id: \\|^Remailed-\\|^Via: \\|^Mail-from: \\|^Return-Path: \\|^In-Reply-To: \\|^Resent-" "\
+Regexp matching lines in a message header that are not to be shown.
+If `mh-visible-headers' is non-nil, it is used instead to specify what
+to keep.")
+
+(defvar mh-rejected-letter-start (concat "^ ----- Unsent message follows -----$" "\\|^------- Unsent Draft$" "\\|^ --- The unsent message follows ---$") "\
+Regexp specifying the beginning of the wrapper around a returned letter.
+This wrapper is generated by the mail system when rejecting a letter.")
+
+(defvar mh-to-field-choices (quote ((116 . "To:") (115 . "Subject:") (99 . "Cc:") (98 . "Bcc:") (102 . "Fcc:"))) "\
+A-list of (character . field name) strings for mh-to-field.")
+
+(defvar mh-user-path "" "\
+User's mail folder.")
+
+(defvar mh-last-destination nil "\
+Destination of last refile or write command.")
+
+(defvar mh-folder-mode-map (make-keymap) "\
+Keymap for MH folders.")
+
+(defvar mh-letter-mode-map (copy-keymap text-mode-map) "\
+Keymap for composing mail.")
+
+(defvar mh-pick-mode-map (make-sparse-keymap) "\
+Keymap for searching folder.")
+
+(defvar mh-letter-mode-syntax-table nil "\
+Syntax table used while in mh-e letter mode.")
+
+(if mh-letter-mode-syntax-table nil (setq mh-letter-mode-syntax-table (make-syntax-table text-mode-syntax-table)) (set-syntax-table mh-letter-mode-syntax-table) (modify-syntax-entry 37 "." mh-letter-mode-syntax-table))
+
+(defvar mh-folder-list nil "\
+List of folder names for completion.")
+
+(defvar mh-draft-folder nil "\
+Name of folder containing draft messages.
+NIL means do not use draft folder.")
+
+(defvar mh-unseen-seq nil "\
+Name of the unseen sequence.")
+
+(defvar mh-previous-window-config nil "\
+Window configuration before mh-e command.")
+
+(defvar mh-previous-seq nil "\
+Name of the sequence to which a message was last added.")
+
+(defmacro mh-push (v l) (byte-code "ÂÃ EE‡" [l v setq cons] 5))
+
+(defmacro mh-when (pred &rest body) (byte-code "Â BD‡" [pred body cond] 3))
+
+(defmacro with-mh-folder-updating (save-modification-flag-p &rest body) (byte-code "@‰ˆÂÃÄÅÆ \"ƒ
+
+(defun mh-mapc (func list) (byte-code "…
+
+(defun mh-rmail (&optional arg) "\
+Inc(orporate) new mail (no arg) or scan a MH mail box (arg given).
+This front end uses the MH mail system, which uses different conventions
+from the usual mail system." (interactive "P") (byte-code "ÁˆÂ ˆƒ
+
+(defun mh-smail nil "\
+Compose and send mail with the MH mail system." (interactive) (byte-code "ÀˆÁ ˆÂÃ!‡" [nil mh-find-path call-interactively mh-send] 3))
+
+(defun mh-smail-other-window nil "\
+Compose and send mail in other window with the MH mail system." (interactive) (byte-code "ÀˆÁ ˆÂÃ!‡" [nil mh-find-path call-interactively mh-send-other-window] 3))
+
+(defun mh-burst-digest nil "\
+Burst apart the current message, which should be a digest.
+The message is replaced by its table of contents and the letters from the
+digest are inserted into the folder after that message." (interactive) (byte-code "ĈÅÁ!Æ
+!ˆÇÁ!ˆÈÉ!ˆÊË
+Ì$ˆÍ
+ÎÏ \"\"ˆÈÐ!)‡" [digest t mh-current-folder mh-first-msg-num nil mh-get-msg-num mh-process-or-undo-commands mh-set-folder-modified-p message "Bursting digest..." mh-exec-cmd "burst" "-inplace" mh-scan-folder format "%d-last" "Bursting digest...done"] 10))
+
+(defun mh-copy-msg (prefix-provided msg-or-seq dest) "\
+Copy specified MESSAGE(s) to another FOLDER without deleting them.
+Default is the displayed message. If optional prefix argument is
+provided, then prompt for the message sequence." (interactive (byte-code "ƒ
+ÊË &ˆ ƒ
+Í#‚
+Í#‡" [current-prefix-arg t msg-or-seq mh-current-folder dest prefix-provided mh-cmd-note nil mh-exec-cmd "refile" "-link" "-src" mh-notate-seq 67 mh-notate] 7))
+
+(defun mh-delete-msg (msg-or-seq) "\
+Mark the specified MESSAGE(s) for subsequent deletion and move to the next.
+Default is the displayed message. If optional prefix argument is
+given then prompt for the message sequence." (interactive (byte-code "ƒ
+!ƒ
+!‚
+\"ˆÇ ‡" [current-prefix-arg t msg-or-seq nil numberp mh-delete-a-msg mh-map-to-seq-msgs mh-next-msg] 5))
+
+(defun mh-delete-msg-no-motion (msg-or-seq) "\
+Mark the specified MESSAGE(s) for subsequent deletion.
+Default is the displayed message. If optional prefix argument is
+provided, then prompt for the message sequence." (interactive (byte-code "ƒ
+!ƒ
+!‚
+\"‡" [current-prefix-arg t msg-or-seq nil numberp mh-delete-a-msg mh-map-to-seq-msgs] 5))
+
+(defun mh-delete-msg-from-seq (prefix-provided msg-or-seq &optional from-seq) "\
+Delete MESSAGE (default: displayed message) from SEQUENCE.
+If optional prefix argument provided, then delete all messages
+from a sequence." (interactive (byte-code " ƒ
+
+(defun mh-edit-again (msg) "\
+Clean-up a draft or a message previously sent and make it resendable." (interactive (byte-code "ÁÀ!C‡" [t mh-get-msg-num] 2)) (byte-code "Lj
+È  …
++‡" [t from-folder mh-current-folder config draft mh-draft-folder msg nil current-window-configuration equal pop-to-buffer find-file-noselect mh-msg-filename rename-buffer format "draft-%d" buffer-name mh-read-draft "clean-up" mh-clean-msg-header "^Date:\\|^Received:\\|^Message-Id:\\|^From:\\|^Delivery-Date:" set-buffer-modified-p mh-compose-and-send-mail ""] 23))
+
+(defun mh-execute-commands nil "\
+Process outstanding delete and refile requests." (interactive) (byte-code "È…
+
+(defun mh-extract-rejected-mail (msg) "\
+Extract a letter returned by the mail system and make it resendable.
+Default is the displayed message." (interactive (byte-code "ÁÀ!C‡" [t mh-get-msg-num] 2)) (byte-code "ƈ
+È ÉÊË !Æ#ebˆÌÆÀ#ƒ,
++‡" [t from-folder mh-current-folder config draft msg nil mh-rejected-letter-start current-window-configuration mh-read-draft "extraction" mh-msg-filename re-search-forward forward-char 1 delete-region mh-clean-msg-header "^Date:\\|^Received:\\|^Message-Id:\\|^From:\\|^Sender:\\|^Return-Path:" message "Does not appear to be a rejected letter." set-buffer-modified-p mh-compose-and-send-mail "" mh-get-field "To" "From" "cc"] 23))
+
+(defun mh-first-msg nil "\
+Move to the first message." (interactive) (byte-code "Àˆeb‡" [nil] 1))
+
+(defun mh-forward (prefix-provided msg-or-seq to cc) "\
+Forward MESSAGE(s) (default: displayed message).
+If optional prefix argument provided, then prompt for the message sequence." (interactive (byte-code "ƒ
+$ˆßË!ˆ‚<
+  
+ó &
++,‡" [current-prefix-arg t folder mh-current-folder config draft-name mh-user-path draft msg-or-seq to cc nil subject trim forw-subject prefix-provided mh-note-forw current-window-configuration expand-file-name "draft" file-exists-p y-or-n-p "The file 'draft' exists. Discard it? " mh-exec-cmd "forw" "-build" mh-read-draft "" mh-insert-fields "To:" "Cc:" set-buffer-modified-p re-search-forward "^------- Forwarded Message" forward-line -1 narrow-to-region mh-get-field "From:" string-match "<" "Subject:" 0 widen format "[%s: %s]" delete-other-windows mh-add-msgs-to-seq mh-seq-to-msgs forwarded mh-compose-and-send-mail "Forwarded:"] 33))
+
+(defun mh-goto-msg (number &optional no-error-if-no-message dont-show) "\
+Position the cursor at message NUMBER.
+Non-nil second argument means do not signal an error if message does not exist.
+Non-nil third argument means not to show the message.
+Return non-nil if cursor is at message." (interactive "NGoto message: ") (byte-code "ÁˆÈÁ!`É !…
+bˆ?…o
+
+(defun mh-inc-folder (&optional maildrop-name) "\
+Inc(orporate) new mail into +inbox.
+Optional prefix argument specifies an alternate maildrop from the default.
+If this is given, incorporate mail into the current folder, rather
+than +inbox. Run `mh-inc-folder-hook' after incorporating new mail." (interactive (byte-code "…
+
+‰‚+
+‰)ˆË !ˆÌÍ!‡" [current-prefix-arg mh-user-path config maildrop-name mh-previous-window-config nil current-window-configuration get-buffer "+inbox" mh-make-folder switch-to-buffer mh-get-new-mail run-hooks mh-inc-folder-hook] 8))
+
+(defun mh-kill-folder nil "\
+Remove the current folder." (interactive) (byte-code "Ĉ†
+\"ˆÌ
+!ˆÍÎ
+\"ˆÉÄ!ˆÏ !…0
+!)‚;
+
+(defun mh-last-msg nil "\
+Move to the last message." (interactive) (byte-code "Àˆdbˆo?…
+
+(defun mh-list-folders nil "\
+List mail folders." (interactive) (byte-code "ˆÊÄÃ!ˆÅ ˆÆÇ!ˆÈÉÀ ƒ
+
+(defun mh-msg-is-in-seq (msg) "\
+Display the sequences that contain MESSAGE (default: displayed message)." (interactive (byte-code "ÁÀ!C‡" [t mh-get-msg-num] 2)) (byte-code "ˆÃÄ ÅÆÇÈ !!É##‡" [t msg nil message "Message %d is in sequences: %s" mapconcat concat mh-list-to-string mh-seq-containing-msg " "] 9))
+
+(defun mh-narrow-to-seq (seq) "\
+Restrict display of this folder to just messages in a sequence.
+Reads which sequence. Use \\[mh-widen] to undo this command." (interactive (byte-code "ÁÂÀ\"C‡" [t mh-read-seq "Narrow to"] 3)) (byte-code "ĈdÈ ÄÄÉ!ƒ0
+!ˆ))‡" [t eob folder-updating-mod-flag buffer-read-only nil buffer-file-name seq mh-narrowed-to-seq buffer-modified-p mh-seq-to-msgs mh-copy-seq-to-point narrow-to-region mh-make-folder-mode-line symbol-name mh-recenter error "No messages in sequence `%s'" mh-set-folder-modified-p] 12))
+
+(defun mh-next-undeleted-msg (&optional arg) "\
+Move to next undeleted message in window." (interactive "P") (byte-code "ÈÆÇ!!ˆÈ‰ˆÉ
+ÃÊ$ƒ
+
+(defun mh-pack-folder (range) "\
+Renumber the messages of a folder to be 1..n.
+First, offer to execute any outstanding commands for the current folder.
+If optional prefix argument provided, prompt for the range of messages
+to display after packing. Otherwise, show the entire folder." (interactive (byte-code "ƒ
+
+
+(defun mh-pipe-msg (prefix-provided command) "\
+Pipe the current message through the given shell COMMAND.
+If optional prefix argument is provided, send the entire message.
+Otherwise just send the message's body." (interactive (byte-code "ÁÂ!D‡" [current-prefix-arg read-string "Shell command on message: "] 3)) (byte-code "ňŠÆÇÁ!
+\"ˆebˆ ?…
+
+" shell-command-on-region] 8))
+
+(defun mh-refile-msg (prefix-provided msg-or-seq dest) "\
+Refile MESSAGE(s) (default: displayed message) in FOLDER.
+If optional prefix argument provided, then prompt for message sequence." (interactive (byte-code "ƒ
+@=ƒ
+A!‚!
+
+(defun mh-refile-or-write-again (msg) "\
+Re-execute the last refile or write command on the given MESSAGE.
+Default is the displayed message. Use the same folder or file as the
+previous refile or write command." (interactive (byte-code "ÁÀ!C‡" [t mh-get-msg-num] 2)) (byte-code "È ?…
+
+ A\"ˆÈÉ A\"‚+
+ A\"ˆÈË A\"ˆÌ ‡" [t mh-last-destination msg nil error "No previous refile or write" refile mh-refile-a-msg message "Destination folder: %s" mh-write-msg-to-file "Destination: %s" mh-next-msg] 7))
+
+(defun mh-reply (prefix-provided msg) "\
+Reply to a MESSAGE (default: displayed message).
+If optional prefix argument provided, then include the message in the reply
+using filter mhl.reply in your MH directory." (interactive (byte-code "ÂÁ!D‡" [current-prefix-arg t mh-get-msg-num] 3)) (byte-code "ňÓ †
+ØÙ!ˆÚ Û\"†*
+‚Œ
+‚Œ
+&
++),)‡" [current-prefix-arg t minibuffer-help-form reply-to mh-reply-default-reply-to nil folder mh-current-folder show-buffer mh-show-buffer config msg prefix-provided draft mh-user-path to subject cc mh-note-repl "from => Sender only
+to => Sender and primary recipients
+cc or all => Sender and all recipients" completing-read "Reply to whom: " (("from") ("to") ("cc") ("all")) current-window-configuration message "Composing a reply..." equal "from" "" apply mh-exec-cmd "repl" "-build" "-noquery" "-nodraftfolder" "-nocc" "all" "-filter" "mhl.reply" "to" "-cc" "cc" "me" mh-read-draft "reply" expand-file-name delete-other-windows set-buffer-modified-p mh-get-field "To:" "Subject:" "Cc:" mh-goto-header-end 1 mh-display-msg mh-add-msgs-to-seq answered "Composing a reply...done" mh-compose-and-send-mail "Replied:"] 33))
+
+(defun mh-quit nil "\
+Quit mh-e.
+Start by running mh-before-quit-hook. Restore the previous window
+configuration, if one exists. Finish by running mh-quit-hook." (interactive) (byte-code "ÁˆÂÃ!ˆ…
+
+(defun mh-page-digest nil "\
+Advance displayed message to next digested message." (interactive) (byte-code "ÁˆŠÃ ˆÄÅ!ˆÁÆÇÁÂ#…
+
+" "From:" other-window -1 error "No more messages" search-backward forward-line 2 mh-recenter] 11))
+
+(defun mh-page-digest-backwards nil "\
+Back up displayed message to previous digested message." (interactive) (byte-code "ÁˆŠÃ ˆÄÅ!ˆÁÆ ˆÇÈÁÂ#…
+
+" "From:" other-window -1 error "No more messages" forward-line 2 mh-recenter] 12))
+
+(defun mh-page-msg (&optional arg) "\
+Page the displayed message forwards.
+Scrolls ARG lines or a full screen if no argument is supplied." (interactive "P") (byte-code "ÁˆÂ!‡" [arg nil scroll-other-window] 2))
+
+(defun mh-previous-page (&optional arg) "\
+Page the displayed message backwards.
+Scrolls ARG lines or a full screen if no argument is supplied." (interactive "P") (byte-code "ÁˆŠÂ ˆÃŽÄ!))‡" [arg nil mh-show-message-in-other-window ((byte-code "ÀÁ!‡" [other-window -1] 2)) scroll-down] 3))
+
+(defun mh-previous-undeleted-msg (&optional arg) "\
+Move to previous undeleted message in window." (interactive "p") (byte-code "ˆƉˆÇ ˆÈ ÂÉ $ƒ
+
+(defun mh-print-msg (prefix-provided msg-or-seq) "\
+Print MESSAGE(s) (default: displayed message) on a line printer.
+If optional prefix argument provided, then prompt for the message sequence." (interactive (byte-code "ƒ
+ƒL
+ƒ@
+ƒs
+ß #‚”
+ËËËß &ˆ
+Ģ
+ƒ¹
+
+(defun mh-put-msg-in-seq (prefix-provided from to) "\
+Add MESSAGE(s) (default: displayed message) to SEQUENCE.
+If optional prefix argument provided, then prompt for the message sequence." (interactive (byte-code "ƒ
+
+(defun mh-rescan-folder (&optional range) "\
+Rescan a folder after optionally processing the outstanding commands.
+If optional prefix argument is provided, prompt for the range of
+messages to display. Otherwise show the entire folder." (interactive (byte-code "ƒ
+
+
+(defun mh-redistribute (to cc msg) "\
+Redistribute a letter.
+Depending on how your copy of MH was compiled, you may need to change the
+setting of the variable mh-redist-full-contents. See its documentation." (interactive (byte-code "ÁÂ!ÁÃ!ÄÀ!E‡" [t read-string "Redist-To: " "Redist-Cc: " mh-get-msg-num] 6)) (byte-code "ƈˋ‡" [t folder mh-current-folder draft mh-redist-full-contents msg nil to cc mh-progs mh-note-dist ((byte-code " ÊË ƒ
+!ˆØé!*‡" [folder mh-current-folder draft mh-redist-full-contents msg nil to cc mh-progs mh-note-dist mh-read-draft "redistribution" mh-msg-filename mh-goto-header-end 0 insert "Resent-To: " "
+" equal "" "Resent-cc: " mh-clean-msg-header "^Message-Id:\\|^Received:\\|^Return-Path:\\|^Sender:\\|^Date:\\|^From:" save-buffer message "Redistributing..." call-process "/bin/sh" "-c" format "mhdist=1 mhaltmsg=%s %s -push %s" buffer-file-name expand-file-name "send" "mhdist=1 mhaltmsg=%s mhannotate=1 %s -push %s" mh-annotate-msg "-component" "Resent:" "-text" "\"%s %s\"" kill-buffer "Redistributing...done"] 30))] 1))
+
+(defun mh-write-msg-to-file (msg file) "\
+Append MESSAGE to the end of a FILE." (interactive (byte-code "ÄÀ!Å
+@=ƒ
+A!‚
+
+(defun mh-search-folder (folder) "\
+Search FOLDER for messages matching a pattern." (interactive (byte-code "ÂÃÁ#C‡" [mh-current-folder t mh-prompt-for-folder "Search"] 4)) (byte-code "ĈÅÆ!ˆÇÈ !†
+
+(defun mh-send (to cc subject) "\
+Compose and send a letter.
+The letter is composed in mh-letter-mode; see its documentation for more
+details. If `mh-compose-letter-function' is defined, it is called on the
+draft and passed three arguments: to, subject, and cc." (interactive "sTo:
+sCc:
+sSubject: ") (byte-code "ĈŠÆ ˆÇ
+ $)‡" [config to cc subject nil current-window-configuration delete-other-windows mh-send-sub] 7))
+
+(defun mh-send-other-window (to cc subject) "\
+Compose and send a letter in another window.." (interactive "sTo:
+sCc:
+sSubject: ") (byte-code "ňÁÆ
+ Ç $)‡" [pop-up-windows t to cc subject nil mh-send-sub current-window-configuration] 6))
+
+(defun mh-send-sub (to cc subject config) "\
+Do the real work of composing and sending a letter.
+Expects the TO, CC, and SUBJECT fields as arguments.
+CONFIG is the window configuration before sending mail." (byte-code " ËÃ!ÌÍ!ˆÎÏÐÑÒ \"!ƒ
+ ÃÃ
+&
+)*‡" [folder mh-current-folder msg-num nil draft mh-user-path mh-lib to subject cc config mh-get-msg-num message "Composing a message..." mh-read-draft "message" file-exists-p expand-file-name "components" error "Can't find components file" mh-insert-fields "To:" "Subject:" "Cc:" set-buffer-modified-p "Composing a message...done" mh-compose-and-send-mail ""] 24))
+
+(defun mh-show (&optional msg) "\
+Show MESSAGE (default: displayed message).
+Forces a two-window display with the folder window on top (size
+mh-summary-height) and the show buffer below it." (interactive) (byte-code "ƈ?…
+
+(defun mh-sort-folder nil "\
+Sort the messages in the current folder by date." (interactive) (byte-code "ÈÄ!ˆÅ‰ˆÆÂ!ˆÇÈ!ˆÉÊ\"ˆÇË!ˆÌÍ\"‡" [mh-current-folder mh-next-direction t nil mh-process-or-undo-commands forward mh-set-folder-modified-p message "Sorting folder..." mh-exec-cmd "sortm" "Sorting folder...done" mh-scan-folder "all"] 8))
+
+(defun mh-toggle-showing nil "\
+Toggle the scanning mode/showing mode of displaying messages." (interactive) (byte-code "Áˆƒ
+
+(defun mh-undo (prefix-provided msg-or-seq) "\
+Undo the deletion or refile of the specified MESSAGE(s).
+Default is the displayed message. If optional prefix argument is
+provided, then prompt for the message sequence." (interactive (byte-code "ƒ
+ƒ
+
+(defun mh-undo-msg (msg) (byte-code " >ƒ
+
+(defun mh-undo-folder (&rest ignore) "\
+Undo all commands in current folder." (interactive) (byte-code "ˆ†
+
+(defun mh-unshar-msg (dir) "\
+Unpack the shar file contained in the current message into directory DIR." (interactive (byte-code "ÂÃÁ$C‡" [mh-unshar-default-directory nil read-file-name "Unshar message in directory: "] 5)) (byte-code "ÁˆÅÆÂ! \"ˆÇ !‡" [mh-unshar-default-directory nil t mh-current-folder dir mh-display-msg mh-get-msg-num mh-unshar-buffer] 4))
+
+(defun mh-unshar-buffer (dir) (byte-code "ebˆÆÇÀÁ#†&
+!ƒQ
+%)ˆÙÚ !Û\"ˆÜ dÝÀ Á&+‚w
+" "mkdir " call-process "mkdir" set-window-start display-buffer 0 call-process-region "sh" error "Cannot find start of shar."] 23))
+
+(defun mh-visit-folder (folder &optional range) "\
+Visit FOLDER and display RANGE of messages.
+Assumes mh-e has already been initialized." (interactive (byte-code "ÁÂÃÀ#ÄÅ!D‡" [t mh-prompt-for-folder "Visit" "+inbox" mh-read-msg-range "Range [all]? "] 4)) (byte-code "ÅˆÆ Ç
+ †
+
+(defun mh-widen nil "\
+Remove restrictions from the current folder, thereby showing all messages." (interactive) (byte-code "È…
+
+(defun mh-delete-a-msg (msg) (byte-code "ŠÇÁÂ#ˆÈ !…
+
+(defun mh-refile-a-msg (msg destination) (byte-code "ŠÉÁÂ#ˆÊ !ƒ
+
+(defun mh-display-msg (msg-num folder) (byte-code "qˆ
+ Õ
+!    Ö !?…(
+\"ˆÙ !ˆ…6
+#C‰.‡" [folder formfile mhl-formfile clean-message-header mh-clean-message-header invisible-headers mh-invisible-headers visible-headers mh-visible-headers msg-filename msg-num show-buffer mh-show-buffer mh-current-folder mh-bury-show-buffer buffer-file-name nil t case-fold-search mode-line-buffer-identification mh-show-buffer-mode-line-buffer-id mh-msg-filename file-exists-p error "Message %d does not exist" switch-to-buffer bury-buffer equal clear-visited-file-modtime unlock-buffer erase-buffer mh-exec-lib-cmd-output "mhl" "-nobell" "-noclear" "-form" insert-file-contents mh-clean-msg-header re-search-forward "^To:\\|^From:\\|^Subject:\\|^Date:" beginning-of-line mh-recenter 0 set-buffer-modified-p set-mark format] 22))
+
+(defun mh-invalidate-show-buffer nil (byte-code "Ã!…
+
+(defun mh-show-message-in-other-window nil (byte-code "Â!ˆ …
+
+(defun mh-clean-msg-header (start invisible-headers visible-headers) (byte-code "ÁŒ
+bˆÆÇÃÁ#…
+`\"ˆebˆ ƒ\\
+
+" backward-char 1 narrow-to-region beginning-of-line looking-at forward-line "^[ ]+" mh-delete-line re-search-forward unlock-buffer] 21))
+
+(defun mh-delete-line (lines) (byte-code "Á`ŠÂ!ˆ`)\"‡" [lines delete-region forward-line] 4))
+
+(defun mh-read-draft (use initial-contents delete-contents-file) (byte-code "ƒ
+ËÌÍ !Ã\"ˆÎÏÐÑ \"!ˆ ‰)‚]
+…†
+
+(defun mh-new-draft-name nil (byte-code "ŠÂÃ!qˆÄ ˆÅÆÀ Ç$ˆÈ`É S\")‡" [nil mh-draft-folder get-buffer-create " *mh-temp*" erase-buffer mh-exec-cmd-output "mhpath" "new" buffer-substring mark] 7))
+
+(defun mh-next-msg nil (byte-code "Á=ƒ
+
+(defun mh-set-scan-mode nil (byte-code "Ä!…
+
+(defun mh-maybe-show (&optional msg) (byte-code "…
+
+(defun mh-set-mode-name (mode-name-string) (byte-code " ‰ˆŠÂ q)ˆÃÄ !‡" [mode-name mode-name-string other-buffer set-buffer-modified-p buffer-modified-p] 4))
+
+(defvar mh-current-folder nil "\
+Name of current folder, a string.")
+
+(defvar mh-show-buffer nil "\
+Buffer that displays mesage for this folder.")
+
+(defvar mh-folder-filename nil "\
+Full path of directory for this folder.")
+
+(defvar mh-showing nil "\
+If non-nil, show the message in a separate window.")
+
+(defvar mh-next-seq-num nil "\
+Index of free sequence id.")
+
+(defvar mh-delete-list nil "\
+List of msg numbers to delete.")
+
+(defvar mh-refile-list nil "\
+List of folder names in mh-seq-list.")
+
+(defvar mh-seq-list nil "\
+Alist of (seq . msgs) numbers.")
+
+(defvar mh-seen-list nil "\
+List of displayed messages.")
+
+(defvar mh-next-direction (quote forward) "\
+Direction to move to next message.")
+
+(defvar mh-narrowed-to-seq nil "\
+Sequence display is narrowed to.")
+
+(defvar mh-first-msg-num nil "\
+Number of first msg in buffer.")
+
+(defvar mh-last-msg-num nil "\
+Number of last msg in buffer.")
+
+(defun mh-make-folder (name) (byte-code "Æ!ˆÂ‰ˆÇ ˆÃ‰ˆÈ ˆÉÂ!ˆ ‰ˆÊË!‡" [name buffer-read-only nil t buffer-file-name mh-folder-filename switch-to-buffer erase-buffer mh-folder-mode mh-set-folder-modified-p mh-set-mode-name "mh-e scan"] 6))
+
+(put (quote mh-folder-mode) (quote mode-class) (quote special))
+
+(defun mh-folder-mode nil "\
+Major mode for \"editing\" an MH folder scan listing.
+Messages can be marked for refiling and deletion. However, both actions
+are deferred until you request execution with \\[mh-execute-commands].
+\\{mh-folder-mode-map}
+ A prefix argument (\\[universal-argument]) to delete, refile, list, or undo
+applies the action to a message sequence.
+
+Variables controlling mh-e operation are (defaults in parentheses):
+
+ mh-bury-show-buffer (t)
+ Non-nil means that the buffer used to display message is buried.
+ It will never be offered as the default other buffer.
+
+ mh-clean-message-header (nil)
+ Non-nil means remove header lines matching the regular expression
+ specified in mh-invisible-headers from messages.
+
+ mh-visible-headers (nil)
+ If non-nil, it contains a regexp specifying the headers that are shown in
+ a message if mh-clean-message-header is non-nil. Setting this variable
+ overrides mh-invisible-headers.
+
+ mh-do-not-confirm (nil)
+ Non-nil means do not prompt for confirmation before executing some
+ non-recoverable commands such as mh-kill-folder and mh-undo-folder.
+
+ mhl-formfile (nil)
+ Name of format file to be used by mhl to show messages.
+ A value of T means use the default format file.
+ Nil means don't use mhl to format messages.
+
+ mh-lpr-command-format (\"lpr -p -J '%s'\")
+ Format for command used to print a message on a system printer.
+
+ mh-recenter-summary-p (nil)
+ If non-nil, then the scan listing is recentered when the window displaying
+ a messages is toggled off.
+
+ mh-summary-height (4)
+ Number of lines in the summary window including the mode line.
+
+ mh-ins-buf-prefix (\"> \")
+ String to insert before each non-blank line of a message as it is
+ inserted in a draft letter.
+
+The value of mh-folder-mode-hook is called when a new folder is set up." (byte-code "È ˆÉ!ˆÊ‰ˆËÌ!ˆÍÎÏ ÐÑÒÏ \"ÓÔÕÏ !!ÖÂ×ØÙÂÚÂÛÂÜÂÝÞßÂàÂáÂâÂ&ˆÄ‰ˆãä!ˆÄ‰ˆåÆ!ˆæ‰ˆåÇ!ˆç‰ˆèé!‡" [mh-folder-mode-map major-mode nil truncate-lines t buffer-offer-save write-file-hooks revert-buffer-function kill-all-local-variables use-local-map mh-folder-mode mh-set-mode-name "mh-e folder" make-local-vars mh-current-folder buffer-name mh-show-buffer format "show-%s" mh-folder-filename file-name-as-directory mh-expand-file-name mh-showing mh-next-seq-num 0 mh-delete-list mh-refile-list mh-seq-list mh-seen-list mh-next-direction forward mh-narrowed-to-seq mh-first-msg-num mh-last-msg-num mh-previous-window-config auto-save-mode -1 make-local-variable (mh-execute-commands) mh-undo-folder run-hooks mh-folder-mode-hook] 38))
+
+(defun make-local-vars (&rest pairs) (byte-code "…
+
+(defun mh-scan-folder (folder range) (byte-code "Ã!?ƒ
+!ˆÈÉ !…7
+Ë\"ƒ.
+#ˆÏÐ!ˆÑ ‡" [folder t range get-buffer mh-make-folder mh-process-or-undo-commands switch-to-buffer mh-regenerate-headers zerop buffer-size equal "all" message "Folder %s is empty" "No messages in %s, range %s" sit-for 5 mh-goto-cur-msg] 13))
+
+(defun mh-regenerate-headers (range) (byte-code " ËÌ\"ˆÍ ÄÄÎ ˆÏÐÄÑÒÓÔ &ˆebˆÕÖ!ƒ/
+!*àÄ!ˆ)ˆËá\")‡" [folder mh-current-folder folder-updating-mod-flag buffer-read-only nil buffer-file-name range mh-valid-scan-line t mh-seq-list mh-partial-folder-mode-line-annotation message "Scanning %s..." buffer-modified-p erase-buffer mh-exec-cmd-output "scan" "-noclear" "-noheader" "-width" window-width looking-at "scan: no messages in" keep-lines "scan: " mh-delete-seq-locally cur mh-read-folder-sequences mh-notate-user-sequences mh-make-folder-mode-line equal "all" mh-set-folder-modified-p "Scanning %s...done"] 18))
+
+(defun mh-get-new-mail (maildrop-name) (byte-code "`
+ÄÎ ÇÇÏ ƒ
+ˆdbˆ`  ƒJ
+
+(defun mh-make-folder-mode-line (&optional annotation) (byte-code "ŠÆ ˆÇÁ!‰ˆÈ ˆÇÁ!‰ˆÉed\"ÊË ƒ%
+#‚C
+
+(defun mh-unmark-all-headers (remove-all-flags) (byte-code "ŠÁd ZÁÆ ˆ`
+X…C
+
+(defun mh-goto-cur-msg nil (byte-code "ÄÅ!@…
+
+(defun mh-pack-folder-1 (range) (byte-code "Ã!ˆÄÅ!ˆÆÁ!ˆŠÇÈÉÊ$)ˆË
+!‡" [mh-current-folder t range mh-process-or-undo-commands message "Packing folder..." mh-set-folder-modified-p mh-exec-cmd-quiet " *mh-temp*" "folder" "-pack" mh-regenerate-headers] 8))
+
+(defun mh-process-or-undo-commands (folder) (byte-code "qˆÂ ƒ
+
+(defun mh-process-commands (folder) (byte-code "ÌÍ\"ˆqˆÎ Ãà …
+Ã\" ɈßË!ˆà ˆÌá\"*âÃ!ˆ)‡" [folder folder-updating-mod-flag buffer-read-only nil buffer-file-name mh-seen-list mh-unseen-seq mh-refile-list mh-delete-list mh-seq-list mh-current-folder t message "Processing deletes and refiles for %s..." buffer-modified-p mh-seq-to-msgs mh-undefine-sequence mh-mapc (lambda (dest) (byte-code "à !…
+È !&ˆÉ!)‡" [msgs dest folder mh-seq-to-msgs apply mh-exec-cmd "refile" "-src" symbol-name mh-delete-scan-msgs] 9)) apply mh-exec-cmd "rmm" mh-delete-scan-msgs buffer-size 0 mh-define-sequence cur mh-get-msg-num "last" mh-invalidate-show-buffer mh-read-folder-sequences mh-unmark-all-headers mh-notate-user-sequences "Processing deletes and refiles for %s...done" mh-set-folder-modified-p] 18))
+
+(defun mh-delete-scan-msgs (msgs) (byte-code "ÃÄK\"‰ˆŠÅ ˆ…
+
+(defun mh-set-folder-modified-p (flag) "\
+Mark current folder as modified or unmodified according to FLAG." (byte-code "Á!‡" [flag set-buffer-modified-p] 2))
+
+(defun mh-outstanding-commands-p nil (byte-code "†
+
+(defvar mh-sent-from-folder nil "\
+Folder of msg associated with this letter.")
+
+(defvar mh-sent-from-msg nil "\
+Number of msg associated with this letter.")
+
+(defvar mh-send-args nil "\
+Extra arguments to pass to \"send\" command.")
+
+(defvar mh-annotate-char nil "\
+Character to use to annotate mh-sent-from-msg.")
+
+(defvar mh-annotate-field nil "\
+Field name for message annotation.")
+
+(defun mh-letter-mode nil "\
+Mode for composing letters in mh-e.
+When you have finished composing, type \\[mh-send-letter] to send the letter.
+
+Variables controlling this mode (defaults in parentheses):
+
+ mh-delete-yanked-msg-window (nil)
+ If non-nil, \\[mh-yank-cur-msg] will delete any windows displaying
+ the yanked message.
+
+ mh-yank-from-start-of-msg (t)
+ If non-nil, \\[mh-yank-cur-msg] will include the entire message.
+ If `body', just yank the body (no header).
+ If nil, only the portion of the message following the point will be yanked.
+ If there is a region, this variable is ignored.
+
+Upon invoking mh-letter-mode, text-mode-hook and mh-letter-mode-hook are
+invoked with no args, if those values are non-nil.
+
+\\{mh-letter-mode-map}" (interactive) (byte-code "ÆˆÇ ˆÈÀ!ˆÉP‰ˆÈÁ!ˆÉ P‰ˆÈÊ!ˆÈË!ˆÈÌ!ˆÈÍ!ˆÈÎ!ˆÈÏ!ˆÐ
+!ˆÑ‰ˆÒÓ!ˆÔ !ˆÕÖ×\"ˆ …Q
+
+(defun mh-auto-fill-for-letter nil (byte-code "Á ˆÂ …
+
+(defun mh-in-header-p nil (byte-code "Š`ebˆÃÄÁÂ#ˆ`W))‡" [cur-point nil t re-search-forward "^--------"] 4))
+
+(defun mh-to-field nil "\
+Move point to the end of a specified header field.
+The field is indicated by the previous keystroke. Create the field if
+it does not exist. Set the mark to point before moving." (interactive) (byte-code "ÆˆÇ ˆÈÉ Ê\"
+\"AÄËÄ\"ƒD
+"] 16))
+
+(defun mh-to-fcc nil "\
+Insert an Fcc: field in the current message.
+Prompt for the field name with a completion list of the current folders." (interactive) (byte-code "ÈÄÅÆÇÂ#È ˆŠÉ ˆ ÊÃOc)*‡" [last-input-char folder t nil 6 mh-prompt-for-folder "Fcc" "" expand-abbrev mh-to-field 1] 6))
+
+(defun mh-insert-signature nil "\
+Insert the file ~/.signature at the current point." (interactive) (byte-code "ÀˆÁÂ!ˆÃÄ !‡" [nil insert-file-contents "~/.signature" set-buffer-modified-p buffer-modified-p] 4))
+
+(defun mh-check-whom nil "\
+Verify recipients of the current letter." (interactive) (byte-code "ˆà ÄÁ!ˆÅ ˆÆÇ!ˆÈÉ!ˆÊp!ˆË ˆÌÍÁ#ˆÎÏ!ˆÆÐ!)‡" [file-name t nil buffer-file-name set-buffer-modified-p save-buffer message "Checking recipients..." switch-to-buffer-other-window "*Mail Recipients*" bury-buffer erase-buffer mh-exec-cmd-output "whom" other-window -1 "Checking recipients...done"] 11))
+
+(defvar mh-searching-folder nil "\
+Folder this pick is searching.")
+
+(defun mh-make-pick-template nil (byte-code "Á ˆÂ ˆÃÄ!ˆÅÆÇÈÉÊË&ˆÌ ˆÍ!ˆebˆÎ ‡" [mh-pick-mode-map erase-buffer kill-all-local-variables make-local-variable mh-searching-folder insert "From:
+" "To:
+" "Cc:
+" "Date:
+" "Subject:
+" "---------
+" mh-letter-mode use-local-map end-of-line] 10))
+
+(defun mh-do-pick-search nil "\
+Find messages that match the qualifications in the current pattern buffer.
+Messages are searched for in the folder named in mh-searching-folder.
+Put messages found in a sequence named `search'." (interactive) (byte-code "ĈÌ
+ÄÄÄŠÍ !ƒ$
+ˆÛ‰ˆ‚9
+\"‚q
+
+(defun mh-next-pick-field (buffer) (byte-code "qˆÂmƒ
+" "-search"] 16))
+
+(defun mh-compose-and-send-mail (draft send-args sent-from-folder sent-from-msg to subject cc annotate-char annotate-field config) (byte-code "Ó!ˆÔ ˆ
+‰ˆ ‰ˆ‰ˆ‰ˆ
+‰ ˆ ‰ ˆÕC‰ ˆÖÒ!…4
+
+(defun mh-send-letter (&optional arg) "\
+Send the draft letter in the current buffer.
+If optional prefix argument is provided, monitor delivery.
+Run mh-before-send-letter-hook before doing anything." (interactive "P") (byte-code "ˈÌÍ!ˆÎÀ!ˆÏ ˆÐÑ!ˆpÒ  ƒL
+&‚?
+&ˆdbˆÛÜ!ˆ q‚b
+%‚b
+$ˆ…~
+áâãäå!äæ!#&ˆ ?†‡
+
+(defun mh-insert-letter (prefix-provided folder msg) "\
+Insert a message from any folder into the current letter.
+Removes the message's headers using mh-invisible-headers.
+Prefixes each non-blank line with mh-ins-buf-prefix (default \">> \").
+If optional prefix argument provided, do not indent and do not delete
+headers. Leaves the mark before the letter and point after it." (interactive (byte-code "ÄÅ Â#ÆÇÈ ƒ
+!))‡" [current-prefix-arg mh-sent-from-folder nil mh-sent-from-msg start msg folder prefix-provided mh-invisible-headers mh-visible-headers mh-ins-buf-prefix narrow-to-region equal "" int-to-string mh-exec-lib-cmd-output "mhl" "-nobell" "-noclear" expand-file-name mh-expand-file-name mh-clean-msg-header set-mark mh-insert-prefix-string] 11))
+
+(defun mh-yank-cur-msg nil "\
+Insert the current message into the draft buffer.
+Prefix each non-blank line in the message with the string in
+`mh-ins-buf-prefix'. If a region is set in the message's buffer, then
+only the region will be inserted. Otherwise, the entire message will
+be inserted if `mh-yank-from-start-of-msg' is non-nil. If this variable
+is nil, the portion of the message following the point will be yanked.
+If `mh-delete-yanked-msg-window' is non-nil, any window displaying the
+yanked message will be deleted." (interactive) (byte-code "ʈ…
+
+\"ˆÔ ˆcˆÕ !ˆÖcˆ× )*‚t
+" widen error "There is no current message"] 15))
+
+(defun mh-insert-prefix-string (mh-ins-string) (byte-code "ŠÀd!ˆebˆÁÂ!)‡" [set-mark run-hooks mh-yank-hooks] 3))
+
+(defun mh-fully-kill-draft nil "\
+Kill the draft message file and the draft message buffer.
+Use \\[kill-buffer] if you don't want to delete the draft message file." (interactive) (byte-code "ˆÃÄ!ƒ.
+
+(defun mh-recenter (arg) (byte-code "Áp! =…
+
+(defun mh-make-seq (name msgs) (byte-code " B‡" [name msgs] 2))
+
+(defmacro mh-seq-name (pair) (byte-code "ÁD‡" [pair car] 2))
+
+(defmacro mh-seq-msgs (pair) (byte-code "ÁD‡" [pair cdr] 2))
+
+(defun mh-find-seq (name) (byte-code "Â \"‡" [name mh-seq-list assoc] 3))
+
+(defun mh-seq-to-msgs (seq) "\
+Return a list of the messages in SEQUENCE." (byte-code "Á!A‡" [seq mh-find-seq] 2))
+
+(defun mh-seq-containing-msg (msg) (byte-code " Ã…
+B‰ˆA‰ˆ‚
+*‡" [l mh-seq-list seqs nil msg] 3))
+
+(defun mh-msg-to-seq (msg) (byte-code "Á!@‡" [msg mh-seq-containing-msg] 2))
+
+(defun mh-read-seq-default (prompt not-empty) (byte-code "Ä
+†
+
+(defun mh-read-seq (prompt not-empty &optional default) (byte-code "ÈÉÊ Ë
+ƒ
+\"‚
+‚4
+
+(defun mh-read-folder-sequences (folder define-sequences) (byte-code "Á
+…
+
+(defun mh-seq-names (seq-list) (byte-code "ÁÂ\"‡" [seq-list mapcar (lambda (entry) (byte-code "Á@!C‡" [entry symbol-name] 2))] 3))
+
+(defun mh-seq-from-command (folder seq seq-command) (byte-code "ÁÁÄŠÉ‹ˆqˆÊ
+!‰ˆË
+\"B‰ˆ
+)+‡" [msg nil msgs case-fold-search t seq-command folder mh-seq-list seq ((byte-code "ÃÄÅ#ˆebˆÆ @‰…
+B‰ˆÇÈ!ˆ‚
+
+(defun mh-read-msg-list nil (byte-code "ÁŠÂ ˆ`)ÁÆÇ
+Ä#…o
+Ä#ˆÈÉÊË!ÌË!\"! W…F
+
+(defun mh-remove-seq (seq) (byte-code "ÂÃÄ T%ˆÅÆC\"ˆÇ!‡" [seq mh-cmd-note mh-map-to-seq-msgs mh-notate-if-in-one-seq 32 mh-undefine-sequence "all" mh-delete-seq-locally] 6))
+
+(defun mh-delete-seq-locally (seq) (byte-code "Ã !Ä
+\"‰)‡" [entry seq mh-seq-list mh-find-seq delq] 4))
+
+(defun mh-remove-msg-from-seq (msg seq &optional internal-flag) (byte-code "Å !…$
+Ç T@$ˆ ?…
+C\"ˆÉÊ
+A\"\")‡" [entry seq msg mh-cmd-note internal-flag mh-find-seq mh-notate-if-in-one-seq 32 mh-undefine-sequence setcdr delq] 8))
+
+(defun mh-add-msgs-to-seq (msgs seq &optional internal-flag) (byte-code "Æ !
+…
+!…
+C‰ˆ?ƒ#
+\" B‰‚/
+…/
+A\"\"ˆ ?…@
+\"ˆÌ Í T#)‡" [entry seq msgs mh-seq-list internal-flag mh-cmd-note mh-find-seq atom mh-make-seq setcdr append mh-add-to-sequence mh-notate-seq 37] 10))
+
+(defun mh-rename-seq (seq new-name) "\
+Rename a SEQUENCE to have a new NAME." (interactive "SOld sequence name:
+SNew name: ") (byte-code "ÃˆÄ !ƒ
+\"‚
+A\")‡" [old-seq seq new-name nil mh-find-seq rplaca error "Sequence %s does not exists" mh-undefine-sequence mh-define-sequence] 7))
+
+(defun mh-notate-user-sequences nil (byte-code " Ä…$
+!?…
+Ç T#ˆA‰ˆ‚
+
+(defun mh-internal-seq (name) (byte-code "Â>†
+
+(defun mh-folder-name-p (name) (byte-code "9ƒ
+
+(defun mh-notate-seq (seq notation offset) (byte-code "ÃÄ
+$‡" [seq notation offset mh-map-to-seq-msgs mh-notate] 5))
+
+(defun mh-notate-if-in-one-seq (msg notation offset seq) (byte-code "Å !
+@=…
+
+(defun mh-map-to-seq-msgs (func seq &rest args) (byte-code "ŠÅ !…!
+
+(defun mh-map-over-seqs (func seq-list) (byte-code "…
+
+(defun mh-define-sequences (seq-list) (byte-code "ÁÂ\"‡" [seq-list mh-map-over-seqs mh-define-sequence] 3))
+
+(defun mh-add-to-sequence (seq msgs) (byte-code "Ã!?…
+ÇÈ!É &‡" [seq msgs mh-current-folder mh-folder-name-p apply mh-exec-cmd "mark" "-sequence" symbol-name "-add"] 10))
+
+(defun mh-define-sequence (seq msgs) (byte-code "…
+ÇÈ !ÉÊË!&)‡" [msgs seq mh-current-folder mh-folder-name-p apply mh-exec-cmd "mark" "-sequence" symbol-name "-add" "-zero" mh-list-to-string] 12))
+
+(defun mh-undefine-sequence (seq msgs) (byte-code "ÃÄÅÆÇ !È
+&‡" [mh-current-folder seq msgs apply mh-exec-cmd "mark" "-sequence" symbol-name "-delete"] 9))
+
+(defun mh-copy-seq-to-point (seq location) (byte-code "ÂÃ #‡" [seq location mh-map-to-seq-msgs mh-copy-line-to-point] 4))
+
+(defun mh-copy-line-to-point (msg location) (byte-code "À ˆ`ÂÃ!ˆÄ`\"ˆ bˆÅ ˆb)‡" [beginning-of-line location forward-line 1 copy-region-as-kill yank] 5))
+
+(defun mh-exec-cmd (command &rest args) (byte-code "ŠÅqˆÆ ˆÇÈÉ \"ÂÃÂÊ !&ˆË ÌV…
+
+(defun mh-exec-cmd-quiet (buffer command &rest args) (byte-code ";…
+
+\"ÃÃ &‡" [buffer command mh-progs nil args erase-buffer apply call-process expand-file-name] 9))
+
+(defun mh-exec-cmd-output (command display &rest args) (byte-code "Æ`À\"ˆÇÈÉ
+\"ÃÀ Ê !&ˆË ‡" [t command mh-progs nil display args push-mark apply call-process expand-file-name mh-list-to-string exchange-point-and-mark] 10))
+
+(defun mh-exec-cmd-daemon (command &rest args) (byte-code "ŠÆÇ!qˆÈ )ˆÁÉÊ ÁË \"Ì !%Í
+Î\"*‡" [process-connection-type nil process command mh-progs args get-buffer-create " *mh-temp*" erase-buffer apply start-process expand-file-name mh-list-to-string set-process-filter mh-process-daemon] 10))
+
+(defun mh-process-daemon (process output) (byte-code "ÁÂ!qˆÃ!ˆÄÂ!‡" [output get-buffer-create " *mh-temp*" insert-before-markers display-buffer] 4))
+
+(defun mh-exec-lib-cmd-output (command &rest args) (byte-code "Å`À\"ˆÆÇÈ
+\"ÃÀÃÉ !&ˆÊ ‡" [t command mh-lib nil args push-mark apply call-process expand-file-name mh-list-to-string exchange-point-and-mark] 10))
+
+(defun mh-list-to-string (l) (byte-code "Á
+…h
+@?†_
+@9ƒ
+@!B‰‚_
+@!ƒ/
+@!B‰‚_
+@È\"†_
+@;ƒF
+@B‰‚_
+@<ƒZ
+@!!\"‰‚_
+@\"ˆ
+A‰ˆ‚
+
+(defun mh-annotate-msg (msg buffer note &rest args) (byte-code "ÅÆÇ
+%ˆŠÈ!…&
+
+(defun mh-notate (msg notation offset) (byte-code "Š?†
+!ˆ))‡" [msg t folder-updating-mod-flag buffer-read-only nil buffer-file-name offset notation mh-goto-msg buffer-modified-p beginning-of-line forward-char delete-char 1 mh-set-folder-modified-p] 8))
+
+(defun mh-prompt-for-folder (prompt default can-create) (byte-code "ÇÈÉÊ \"ƒ
+Ê\"…5
+Ê\"†I
+Ï\"ƒR
+!?…_
+\"‰ˆÒÓ
+!!? …q
+\"!ƒ‘
+\"ˆØÙÄÄÄÓ
+!%ˆÖÚ
+\"ˆ
+C B‰‚ª
+\"‚ª
+ \"?…ª
+C B‰)ˆ
+*‡" [prompt default name mh-folder-list nil new-file-p t format "%s folder%s" equal "" "? " " [%s]? " mh-set-folder-list completing-read "+" mh-folder-name-p "+%s" file-exists-p mh-expand-file-name y-or-n-p "Folder %s does not exist. Create it? " message "Creating %s" call-process "mkdir" "Creating %s...done" error "Folder %s is not created" assoc] 23))
+
+(defun mh-set-folder-list nil "\
+Sets mh-folder-list correctly.
+A useful function for the command line or for when you need to sync by hand." (byte-code "Á ‰‡" [mh-folder-list mh-make-folder-list] 3))
+
+(defun mh-make-folder-list nil "\
+Return a list of the user's folders.
+Result is in a form suitable for completing read." (interactive) (byte-code "ˆÄÅ!ˆÆ‹‡" [mh-recursive-folders list nil start message "Collecting folder names..." ((byte-code "ÄÅÆǃ
+
+(defun mh-remove-folder-from-folder-list (folder) (byte-code "Âà \"\"‰‡" [mh-folder-list folder delq assoc] 4))
+
+(defun mh-read-msg-range (prompt) (byte-code "Ç !GÈÅ
+W…*
+#@ B‰ˆA‰)ˆ‚
+
+(defun mh-get-msg-num (error-if-no-message) (byte-code "ŠÄ ˆÅ!ƒ
+
+(defun mh-msg-search-pat (n) (byte-code "Â \"‡" [mh-msg-search-regexp n format] 3))
+
+(defun mh-msg-filename (msg &optional folder) (byte-code "ÃÄ! ƒ
+\"‡" [msg folder mh-folder-filename expand-file-name int-to-string mh-expand-file-name] 5))
+
+(defun mh-msg-filenames (msgs &optional folder) (byte-code "ÁÂÃ#‡" [msgs mapconcat (lambda (msg) (byte-code "Â \"‡" [msg folder mh-msg-filename] 3)) " "] 4))
+
+(defun mh-expand-file-name (filename &optional default) "\
+Just like `expand-file-name', but also handles MH folder names.
+Assumes that any filename that starts with '+' is a folder name." (byte-code "Ã!ƒ
+\"‡" [filename mh-user-path default mh-folder-name-p expand-file-name 1 nil] 5))
+
+(defun mh-find-path nil (byte-code "ŠÅÆÇ!†
+
+(defun mh-get-field (field) (byte-code "ÁebˆÅÆÇ
+\"ÃÁ#?ƒ
+].*\\)$" match-beginning 1 forward-line "[ ]" buffer-substring] 11))
+
+(defun mh-insert-fields (&rest name-values) (byte-code "Á
+…C
+@
+A@Æ Ç\"?…8
+AA‰*ˆ‚
+" end-of-line] 10))
+
+(defun mh-position-on-field (field set-mark) (byte-code "Á
+…
+
+(defun mh-goto-header-end (arg) (byte-code "ÂÃÀÀ#…
+
+(suppress-keymap mh-folder-mode-map)
+
+(define-key mh-folder-mode-map "q" (quote mh-quit))
+
+(define-key mh-folder-mode-map "b" (quote mh-quit))
+
+(define-key mh-folder-mode-map "?" (quote mh-msg-is-in-seq))
+
+(define-key mh-folder-mode-map "%" (quote mh-put-msg-in-seq))
+
+(define-key mh-folder-mode-map "|" (quote mh-pipe-msg))
+
+(define-key mh-folder-mode-map "a" (quote mh-edit-again))
+
+(define-key mh-folder-mode-map "%" (quote mh-delete-msg-from-seq))
+
+(define-key mh-folder-mode-map "n" (quote mh-narrow-to-seq))
+
+(define-key mh-folder-mode-map "w" (quote mh-widen))
+
+(define-key mh-folder-mode-map "b" (quote mh-burst-digest))
+
+(define-key mh-folder-mode-map "u" (quote mh-undo-folder))
+
+(define-key mh-folder-mode-map " " (quote mh-page-digest))
+
+(define-key mh-folder-mode-map "" (quote mh-page-digest-backwards))
+
+(define-key mh-folder-mode-map "e" (quote mh-extract-rejected-mail))
+
+(define-key mh-folder-mode-map "f" (quote mh-visit-folder))
+
+(define-key mh-folder-mode-map "k" (quote mh-kill-folder))
+
+(define-key mh-folder-mode-map "l" (quote mh-list-folders))
+
+(define-key mh-folder-mode-map "o" (quote mh-write-msg-to-file))
+
+(define-key mh-folder-mode-map "p" (quote mh-pack-folder))
+
+(define-key mh-folder-mode-map "s" (quote mh-search-folder))
+
+(define-key mh-folder-mode-map "r" (quote mh-rescan-folder))
+
+(define-key mh-folder-mode-map "l" (quote mh-print-msg))
+
+(define-key mh-folder-mode-map "t" (quote mh-toggle-showing))
+
+(define-key mh-folder-mode-map "c" (quote mh-copy-msg))
+
+(define-key mh-folder-mode-map ">" (quote mh-write-msg-to-file))
+
+(define-key mh-folder-mode-map "i" (quote mh-inc-folder))
+
+(define-key mh-folder-mode-map "x" (quote mh-execute-commands))
+
+(define-key mh-folder-mode-map "e" (quote mh-execute-commands))
+
+(define-key mh-folder-mode-map "r" (quote mh-redistribute))
+
+(define-key mh-folder-mode-map "f" (quote mh-forward))
+
+(define-key mh-folder-mode-map "s" (quote mh-send))
+
+(define-key mh-folder-mode-map "m" (quote mh-send))
+
+(define-key mh-folder-mode-map "a" (quote mh-reply))
+
+(define-key mh-folder-mode-map "j" (quote mh-goto-msg))
+
+(define-key mh-folder-mode-map "<" (quote mh-first-msg))
+
+(define-key mh-folder-mode-map "g" (quote mh-goto-msg))
+
+(define-key mh-folder-mode-map "" (quote mh-previous-page))
+
+(define-key mh-folder-mode-map " " (quote mh-page-msg))
+
+(define-key mh-folder-mode-map "." (quote mh-show))
+
+(define-key mh-folder-mode-map "u" (quote mh-undo))
+
+(define-key mh-folder-mode-map "!" (quote mh-refile-or-write-again))
+
+(define-key mh-folder-mode-map "^" (quote mh-refile-msg))
+
+(define-key mh-folder-mode-map "d" (quote mh-delete-msg))
+
+(define-key mh-folder-mode-map "" (quote mh-delete-msg-no-motion))
+
+(define-key mh-folder-mode-map "p" (quote mh-previous-undeleted-msg))
+
+(define-key mh-folder-mode-map "n" (quote mh-next-undeleted-msg))
+
+(define-key mh-folder-mode-map "o" (quote mh-refile-msg))
+
+(define-key mh-letter-mode-map "" (quote mh-to-field))
+
+(define-key mh-letter-mode-map "" (quote mh-to-field))
+
+(define-key mh-letter-mode-map "" (quote mh-to-fcc))
+
+(define-key mh-letter-mode-map "" (quote mh-to-field))
+
+(define-key mh-letter-mode-map "" (quote mh-to-field))
+
+(define-key mh-letter-mode-map "b" (quote mh-to-field))
+
+(define-key mh-letter-mode-map "c" (quote mh-to-field))
+
+(define-key mh-letter-mode-map "f" (quote mh-to-fcc))
+
+(define-key mh-letter-mode-map "s" (quote mh-to-field))
+
+(define-key mh-letter-mode-map "t" (quote mh-to-field))
+
+(define-key mh-letter-mode-map "" (quote mh-fully-kill-draft))
+
+(define-key mh-letter-mode-map "" (quote mh-check-whom))
+
+(define-key mh-letter-mode-map " " (quote mh-insert-letter))
+
+(define-key mh-letter-mode-map "" (quote mh-yank-cur-msg))
+
+(define-key mh-letter-mode-map "" (quote mh-insert-signature))
+
+(define-key mh-letter-mode-map "" (quote mh-send-letter))
+
+(define-key mh-pick-mode-map "" (quote mh-do-pick-search))
+
+(define-key mh-pick-mode-map "" (quote mh-to-field))
+
+(define-key mh-pick-mode-map "" (quote mh-to-field))
+
+(define-key mh-pick-mode-map "" (quote mh-to-field))
+
+(define-key mh-pick-mode-map "" (quote mh-to-field))
+
+(define-key mh-pick-mode-map "" (quote mh-to-field))
+
+(define-key mh-pick-mode-map "b" (quote mh-to-field))
+
+(define-key mh-pick-mode-map "c" (quote mh-to-field))
+
+(define-key mh-pick-mode-map "f" (quote mh-to-field))
+
+(define-key mh-pick-mode-map "s" (quote mh-to-field))
+
+(define-key mh-pick-mode-map "t" (quote mh-to-field))
+
+(define-key mh-pick-mode-map "" (quote mh-check-whom))
diff --git a/lisp/mhspool.el b/lisp/mhspool.el
deleted file mode 100644
index 4801579ecf7..00000000000
--- a/lisp/mhspool.el
+++ /dev/null
@@ -1,404 +0,0 @@
-;;; MH folder access using NNTP for GNU Emacs
-;; Copyright (C) 1988, 1989 Fujitsu Laboratories LTD.
-;; Copyright (C) 1988, 1989, 1990 Masanobu UMEDA
-;; $Header: mhspool.el,v 1.5 90/03/23 13:25:23 umerin Locked $
-
-;; This file is part of GNU Emacs.
-
-;; 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.
-
-(provide 'mhspool)
-(require 'nntp)
-
-;; This package enables you to read mail or articles in MH folders, or
-;; articles saved by GNUS. In any case, the file names of mail or
-;; articles must consist of only numeric letters.
-
-;; Before using this package, you have to create a server specific
-;; startup file according to the directory which you want to read. For
-;; example, if you want to read mail under the directory named
-;; `~/Mail', the file must be a file named `.newsrc-:Mail'. (There is
-;; no way to specify hierarchical directory now.) In this case, the
-;; name of the NNTP server passed to GNUS must be `:Mail'.
-
-(defvar mhspool-list-directory-switches '("-R")
- "*Switches for `nntp-request-list' to pass to `ls' for gettting file lists.
-One entry should appear on one line. You may need to add `-1' option.")
-
-
-
-(defconst mhspool-version "MHSPOOL 1.5"
- "Version numbers of this version of MHSPOOL.")
-
-(defvar mhspool-spool-directory "~/Mail"
- "Private mail directory.")
-
-(defvar mhspool-current-directory nil
- "Current news group directory.")
-
-;;;
-;;; Replacement of Extended Command for retrieving many headers.
-;;;
-
-(defun mhspool-retrieve-headers (sequence)
- "Return list of article headers specified by SEQUENCE of article id.
-The format of list is
- `([NUMBER SUBJECT FROM XREF LINES DATE MESSAGE-ID REFERENCES] ...)'.
-Reader macros for the vector are defined as `nntp-header-FIELD'.
-Writer macros for the vector are defined as `nntp-set-header-FIELD'.
-News group must be selected before calling me."
- (save-excursion
- (set-buffer nntp-server-buffer)
- ;;(erase-buffer)
- (let ((file nil)
- (number (length sequence))
- (count 0)
- (headers nil) ;Result list.
- (article 0)
- (subject nil)
- (message-id nil)
- (from nil)
- (xref nil)
- (lines 0)
- (date nil)
- (references nil))
- (while sequence
- ;;(nntp-send-strings-to-server "HEAD" (car sequence))
- (setq article (car sequence))
- (setq file
- (concat mhspool-current-directory (prin1-to-string article)))
- (if (and (file-exists-p file)
- (not (file-directory-p file)))
- (progn
- (erase-buffer)
- (insert-file-contents file)
- ;; Make message body invisible.
- (goto-char (point-min))
- (search-forward "\n\n" nil 'move)
- (narrow-to-region (point-min) (point))
- ;; Fold continuation lines.
- (goto-char (point-min))
- (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
- (replace-match " " t t))
- ;; Make it possible to search for `\nFIELD'.
- (goto-char (point-min))
- (insert "\n")
- ;; Extract From:
- (goto-char (point-min))
- (if (search-forward "\nFrom: " nil t)
- (setq from (buffer-substring
- (point)
- (save-excursion (end-of-line) (point))))
- (setq from "(Unknown User)"))
- ;; Extract Subject:
- (goto-char (point-min))
- (if (search-forward "\nSubject: " nil t)
- (setq subject (buffer-substring
- (point)
- (save-excursion (end-of-line) (point))))
- (setq subject "(None)"))
- ;; Extract Message-ID:
- (goto-char (point-min))
- (if (search-forward "\nMessage-ID: " nil t)
- (setq message-id (buffer-substring
- (point)
- (save-excursion (end-of-line) (point))))
- (setq message-id nil))
- ;; Extract Date:
- (goto-char (point-min))
- (if (search-forward "\nDate: " nil t)
- (setq date (buffer-substring
- (point)
- (save-excursion (end-of-line) (point))))
- (setq date nil))
- ;; Extract Lines:
- (goto-char (point-min))
- (if (search-forward "\nLines: " nil t)
- (setq lines (string-to-int
- (buffer-substring
- (point)
- (save-excursion (end-of-line) (point)))))
- (setq lines 0))
- ;; Extract Xref:
- (goto-char (point-min))
- (if (search-forward "\nXref: " nil t)
- (setq xref (buffer-substring
- (point)
- (save-excursion (end-of-line) (point))))
- (setq xref nil))
- ;; Extract References:
- ;; If no References: field, use In-Reply-To: field instead.
- ;; Suggested by tanaka@flab.fujitsu.co.jp (Hiroshi TANAKA).
- (goto-char (point-min))
- (if (or (search-forward "\nReferences: " nil t)
- (search-forward "\nIn-Reply-To: " nil t))
- (setq references (buffer-substring
- (point)
- (save-excursion (end-of-line) (point))))
- (setq references nil))
- (setq headers
- (cons (vector article subject from
- xref lines date
- message-id references) headers))
- ))
- (setq sequence (cdr sequence))
- (setq count (1+ count))
- (and (numberp nntp-large-newsgroup)
- (> number nntp-large-newsgroup)
- (zerop (% count 20))
- (message "MHSPOOL: %d%% of headers received."
- (/ (* count 100) number)))
- )
- (and (numberp nntp-large-newsgroup)
- (> number nntp-large-newsgroup)
- (message "MHSPOOL: 100%% of headers received."))
- (nreverse headers)
- )))
-
-
-;;;
-;;; Replacement of NNTP Raw Interface.
-;;;
-
-(defun mhspool-open-server (host &optional service)
- "Open news server on HOST.
-If HOST is nil, use value of environment variable `NNTPSERVER'.
-If optional argument SERVICE is non-nil, open by the service name."
- (let ((host (or host (getenv "NNTPSERVER")))
- (status nil))
- ;; Get directory name from HOST name.
- (if (string-match ":\\(.+\\)$" host)
- (progn
- (setq mhspool-spool-directory
- (file-name-as-directory
- (expand-file-name
- (substring host (match-beginning 1) (match-end 1))
- (expand-file-name "~/" nil))))
- (setq host (system-name)))
- (setq mhspool-spool-directory nil))
- (setq nntp-status-message-string "")
- (cond ((and (stringp host)
- (stringp mhspool-spool-directory)
- (file-directory-p mhspool-spool-directory)
- (string-equal host (system-name)))
- (setq status (mhspool-open-server-internal host service)))
- ((string-equal host (system-name))
- (setq nntp-status-message-string
- (format "No such directory: %s. Goodbye."
- mhspool-spool-directory)))
- ((null host)
- (setq nntp-status-message-string "NNTP server is not specified."))
- (t
- (setq nntp-status-message-string
- (format "MHSPOOL: cannot talk to %s." host)))
- )
- status
- ))
-
-(defun mhspool-close-server ()
- "Close news server."
- (mhspool-close-server-internal))
-
-(fset 'mhspool-request-quit (symbol-function 'mhspool-close-server))
-
-(defun mhspool-server-opened ()
- "Return server process status, T or NIL.
-If the stream is opened, return T, otherwise return NIL."
- (and nntp-server-buffer
- (get-buffer nntp-server-buffer)))
-
-(defun mhspool-status-message ()
- "Return server status response as string."
- nntp-status-message-string
- )
-
-(defun mhspool-request-article (id)
- "Select article by message ID (or number)."
- (let ((file (concat mhspool-current-directory (prin1-to-string id))))
- (if (and (stringp file)
- (file-exists-p file)
- (not (file-directory-p file)))
- (save-excursion
- (mhspool-find-file file)))
- ))
-
-(defun mhspool-request-body (id)
- "Select article body by message ID (or number)."
- (if (mhspool-request-article id)
- (save-excursion
- (set-buffer nntp-server-buffer)
- (goto-char (point-min))
- (if (search-forward "\n\n" nil t)
- (delete-region (point-min) (point)))
- t
- )
- ))
-
-(defun mhspool-request-head (id)
- "Select article head by message ID (or number)."
- (if (mhspool-request-article id)
- (save-excursion
- (set-buffer nntp-server-buffer)
- (goto-char (point-min))
- (if (search-forward "\n\n" nil t)
- (delete-region (1- (point)) (point-max)))
- t
- )
- ))
-
-(defun mhspool-request-stat (id)
- "Select article by message ID (or number)."
- (error "MHSPOOL: STAT is not implemented."))
-
-(defun mhspool-request-group (group)
- "Select news GROUP."
- (cond ((file-directory-p
- (mhspool-article-pathname group))
- ;; Mail/NEWS.GROUP/N
- (setq mhspool-current-directory
- (mhspool-article-pathname group)))
- ((file-directory-p
- (mhspool-article-pathname
- (mhspool-replace-chars-in-string group ?. ?/)))
- ;; Mail/NEWS/GROUP/N
- (setq mhspool-current-directory
- (mhspool-article-pathname
- (mhspool-replace-chars-in-string group ?. ?/))))
- ))
-
-(defun mhspool-request-list ()
- "List valid newsgoups."
- (save-excursion
- (let* ((newsgroup nil)
- (articles nil)
- (directory (file-name-as-directory
- (expand-file-name mhspool-spool-directory nil)))
- (folder-regexp (concat "^" (regexp-quote directory) "\\(.+\\):$"))
- (buffer (get-buffer-create " *GNUS file listing*")))
- (set-buffer nntp-server-buffer)
- (erase-buffer)
- (set-buffer buffer)
- (erase-buffer)
- (apply 'call-process
- "ls" nil t nil
- (append mhspool-list-directory-switches (list directory)))
- (goto-char (point-min))
- (while (re-search-forward folder-regexp nil t)
- (setq newsgroup
- (mhspool-replace-chars-in-string
- (buffer-substring (match-beginning 1) (match-end 1)) ?/ ?.))
- (setq articles nil)
- (forward-line 1) ;(beginning-of-line)
- ;; Thank nobu@flab.fujitsu.junet for his bug fixes.
- (while (and (not (eobp))
- (not (looking-at "^$")))
- (if (looking-at "^[0-9]+$")
- (setq articles
- (cons (string-to-int
- (buffer-substring
- (match-beginning 0) (match-end 0)))
- articles)))
- (forward-line 1))
- (if articles
- (princ (format "%s %d %d n\n" newsgroup
- (apply (function max) articles)
- (apply (function min) articles))
- nntp-server-buffer))
- )
- (kill-buffer buffer)
- (set-buffer nntp-server-buffer)
- (buffer-size)
- )))
-
-(defun mhspool-request-last ()
- "Set current article pointer to the previous article in the current newsgroup."
- (error "MHSPOOL: LAST is not implemented."))
-
-(defun mhspool-request-next ()
- "Advance current article pointer."
- (error "MHSPOOL: NEXT is not implemented."))
-
-(defun mhspool-request-post ()
- "Post a new news in current buffer."
- (setq nntp-status-message-string "MHSPOOL: what do you mean post?")
- nil
- )
-
-
-;;;
-;;; Replacement of Low-Level Interface to NNTP Server.
-;;;
-
-(defun mhspool-open-server-internal (host &optional service)
- "Open connection to news server on HOST by SERVICE (default is nntp)."
- (save-excursion
- (if (not (string-equal host (system-name)))
- (error "MHSPOOL: cannot talk to %s." host))
- ;; Initialize communication buffer.
- (setq nntp-server-buffer (get-buffer-create " *nntpd*"))
- (set-buffer nntp-server-buffer)
- (buffer-flush-undo (current-buffer))
- (erase-buffer)
- (kill-all-local-variables)
- (setq case-fold-search t) ;Should ignore case.
- (setq nntp-server-process nil)
- (setq nntp-server-name host)
- ;; It is possible to change kanji-fileio-code in this hook.
- (run-hooks 'nntp-server-hook)
- t
- ))
-
-(defun mhspool-close-server-internal ()
- "Close connection to news server."
- (if nntp-server-buffer
- (kill-buffer nntp-server-buffer))
- (setq nntp-server-buffer nil)
- (setq nntp-server-process nil))
-
-(defun mhspool-find-file (file)
- "Insert FILE in server buffer safely."
- (set-buffer nntp-server-buffer)
- (erase-buffer)
- (condition-case ()
- (progn
- (insert-file-contents file)
- (goto-char (point-min))
- ;; If there is no body, `^L' appears at end of file. Special
- ;; hack for MH folder.
- (and (search-forward "\n\n" nil t)
- (string-equal (buffer-substring (point) (point-max)) "\^L")
- (delete-char 1))
- t
- )
- (file-error nil)
- ))
-
-(defun mhspool-article-pathname (group)
- "Make pathname for GROUP."
- (concat (file-name-as-directory mhspool-spool-directory) group "/"))
-
-(defun mhspool-replace-chars-in-string (string from to)
- "Replace characters in STRING from FROM to TO."
- (let ((string (substring string 0)) ;Copy string.
- (len (length string))
- (idx 0))
- ;; Replace all occurence of FROM with TO.
- (while (< idx len)
- (if (= (aref string idx) from)
- (aset string idx to))
- (setq idx (1+ idx)))
- string
- ))
diff --git a/lisp/mim-mode.el b/lisp/mim-mode.el
index 43e0c0118b4..ca222b918b6 100644
--- a/lisp/mim-mode.el
+++ b/lisp/mim-mode.el
@@ -86,18 +86,18 @@ are bound.")
(define-abbrev-table 'mim-mode-abbrev-table nil)
-(defconst indent-mim-function 'indent-mim-function
+(defconst indent-mim-hook 'indent-mim-hook
"Controls (via properties) indenting of special forms.
-\(put 'FOO 'indent-mim-function n\), integer n, means lines inside
+\(put 'FOO 'indent-mim-hook n\), integer n, means lines inside
<FOO ...> will be indented n spaces from start of form.
-\(put 'FOO 'indent-mim-function 'DEFINE\) is like above but means use
+\(put 'FOO 'indent-mim-hook 'DEFINE\) is like above but means use
value of mim-body-indent as offset from start of form.
-\(put 'FOO 'indent-mim-function <cons>\) where <cons> is a list or pointted list
+\(put 'FOO 'indent-mim-hook <cons>\) where <cons> is a list or pointted list
of integers, means indent each form in <FOO ...> by the amount specified
in <cons>. When <cons> is exhausted, indent remaining forms by
-`mim-body-indent' unless <cons> is a pointed list, in which case the last
-cdr is used. Confused? Here is an example:
-\(put 'FROBIT 'indent-mim-function '\(4 2 . 1\)\)
+mim-body-indent unless <cons> is a pointted list, in which case the last
+cdr is used. Confused? Here is an example:
+\(put 'FROBIT 'indent-mim-hook '\(4 2 . 1\)\)
<FROBIT
<CHOMP-IT>
<CHOMP-SOME-MORE>
@@ -111,7 +111,7 @@ Finally, the property can be a function name (read the code).")
(defvar mim-body-indent 2
"*Amount to indent in special forms which have DEFINE property on
-`indent-mim-function'.")
+indent-mim-hook.")
(defvar indent-mim-arglist t
"*nil means indent arglists like ordinary lists.
@@ -125,16 +125,16 @@ Examples (for values 'stack, t, nil):
\"AUX\" \"AUX\" \"AUX\"
BLETCH ... BLETCH ... BLETCH ...")
-(put 'DEFINE 'indent-mim-function 'DEFINE)
-(put 'DEFMAC 'indent-mim-function 'DEFINE)
-(put 'BIND 'indent-mim-function 'DEFINE)
-(put 'PROG 'indent-mim-function 'DEFINE)
-(put 'REPEAT 'indent-mim-function 'DEFINE)
-(put 'CASE 'indent-mim-function 'DEFINE)
-(put 'FUNCTION 'indent-mim-function 'DEFINE)
-(put 'MAPF 'indent-mim-function 'DEFINE)
-(put 'MAPR 'indent-mim-function 'DEFINE)
-(put 'UNWIND 'indent-mim-function (cons (* 2 mim-body-indent) mim-body-indent))
+(put 'DEFINE 'indent-mim-hook 'DEFINE)
+(put 'DEFMAC 'indent-mim-hook 'DEFINE)
+(put 'BIND 'indent-mim-hook 'DEFINE)
+(put 'PROG 'indent-mim-hook 'DEFINE)
+(put 'REPEAT 'indent-mim-hook 'DEFINE)
+(put 'CASE 'indent-mim-hook 'DEFINE)
+(put 'FUNCTION 'indent-mim-hook 'DEFINE)
+(put 'MAPF 'indent-mim-hook 'DEFINE)
+(put 'MAPR 'indent-mim-hook 'DEFINE)
+(put 'UNWIND 'indent-mim-hook (cons (* 2 mim-body-indent) mim-body-indent))
(defvar mim-down-parens-only t
"*nil means treat ADECLs and ATOM trailers like structures when
@@ -150,17 +150,35 @@ only open paren syntax characters will be considered.")
(defun mim-mode ()
"Major mode for editing Mim (MDL in MDL) code.
Commands:
- If value of `mim-mode-hysterical-bindings' is non-nil, then following
-commands are assigned to escape keys as well (e.g. ESC f = ESC C-f).
+ If value of mim-mode-hysterical-bindings is non-nil, then following
+commands are assigned to escape keys as well (e.g. M-f = M-C-f).
The default action is bind the escape keys.
-\\{mim-mode-map}
+ Tab Indents the current line as MDL code.
+ Delete Converts tabs to spaces as it moves back.
+ M-C-f Move forward over next mim object.
+ M-C-b Move backward over previous mim object.
+ M-C-p Move to beginning of previous toplevel mim object.
+ M-C-n Move to the beginning of the next toplevel mim object.
+ M-C-a Move to the top of surrounding toplevel mim form.
+ M-C-e Move to the end of surrounding toplevel mim form.
+ M-C-u Move up a level of mim structure backwards.
+ M-C-d Move down a level of mim structure forwards.
+ M-C-t Transpose mim objects on either side of point.
+ M-C-k Kill next mim object.
+ M-C-h Place mark at end of next mim object.
+ M-C-o Insert a newline before current line and indent.
+ M-Delete Kill previous mim object.
+ M-^ Join current line to previous line.
+ M-\\ Delete whitespace around point.
+ M-; Move to existing comment or insert empty comment if none.
+ M-Tab Indent following mim object and all contained lines.
Other Commands:
Use \\[describe-function] to obtain documentation.
replace-in-mim-object find-mim-definition fast-syntax-check-mim
slow-syntax-check-mim backward-down-mim-object forward-up-mim-object
Variables:
Use \\[describe-variable] to obtain documentation.
- mim-mode-hook indent-mim-comment indent-mim-arglist indent-mim-function
+ mim-mode-hook indent-mim-comment indent-mim-arglist indent-mim-hook
mim-body-indent mim-down-parens-only mim-stop-for-slop
mim-mode-hysterical-bindings
Entry to this mode calls the value of mim-mode-hook if non-nil."
@@ -592,15 +610,15 @@ is reached."
;; then state corresponds to containing environment. if desired
;; indentation not determined, we are inside a form, so call hook.
(or desired-indent
- (and indent-mim-function
+ (and indent-mim-hook
(not retry)
(setq desired-indent
- (funcall indent-mim-function state indent-point)))
+ (funcall indent-mim-hook state indent-point)))
(setq desired-indent (current-column)))
(goto-char indent-point) ; back to where we started
desired-indent))) ; return column to indent to
-(defun indent-mim-function (state indent-point)
+(defun indent-mim-hook (state indent-point)
"Compute indentation for Mim special forms. Returns column or nil."
(let ((containing-sexp (car (cdr state))) (current-indent (point)))
(save-excursion
@@ -618,7 +636,7 @@ is reached."
(intern-soft (buffer-substring (point)
(progn (forward-sexp 1)
(point)))))
- (method (get function 'indent-mim-function)))
+ (method (get function 'indent-mim-hook)))
(if (or (if (equal method 'DEFINE) (setq method mim-body-indent))
(integerp method))
;; only use method if its first line after containing-sexp.
@@ -651,7 +669,7 @@ is reached."
(defun indent-mim-offset (state indent-point)
;; offset forms explicitly according to list of indentations.
(let ((mim-body-indent mim-body-indent)
- (indentations (get function 'indent-mim-function))
+ (indentations (get function 'indent-mim-hook))
(containing-sexp (car (cdr state)))
(last-sexp (car (nthcdr 2 state)))
indentation)
diff --git a/lisp/mim-mode.elc b/lisp/mim-mode.elc
new file mode 100644
index 00000000000..53d0c938f0a
--- /dev/null
+++ b/lisp/mim-mode.elc
Binary files differ
diff --git a/lisp/mim-syntax.elc b/lisp/mim-syntax.elc
new file mode 100644
index 00000000000..c8a712e9777
--- /dev/null
+++ b/lisp/mim-syntax.elc
Binary files differ
diff --git a/lisp/misc.el b/lisp/misc.el
deleted file mode 100644
index db7b3f223b5..00000000000
--- a/lisp/misc.el
+++ /dev/null
@@ -1,51 +0,0 @@
-;; Basic editing commands for Emacs
-;; Copyright (C) 1989 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-
-(defun copy-from-above-command (&optional arg)
- "Copy characters from previous nonblank line, starting just above point.
-Copy ARG characters, but not past the end of that line.
-If no argument given, copy the entire rest of the line.
-The characters copied are inserted in the buffer before point."
- (interactive "P")
- (let ((cc (current-column))
- n
- (string ""))
- (save-excursion
- (beginning-of-line)
- (backward-char 1)
- (skip-chars-backward "\ \t\n")
- (move-to-column cc)
- ;; Default is enough to copy the whole rest of the line.
- (setq n (if arg (prefix-numeric-value arg) (point-max)))
- ;; If current column winds up in middle of a tab,
- ;; copy appropriate number of "virtual" space chars.
- (if (< cc (current-column))
- (if (= (preceding-char) ?\t)
- (progn
- (setq string (make-string (min n (- (current-column) cc)) ?\ ))
- (setq n (- n (min n (- (current-column) cc)))))
- ;; In middle of ctl char => copy that whole char.
- (backward-char 1)))
- (setq string (concat string
- (buffer-substring
- (point)
- (min (save-excursion (end-of-line) (point))
- (+ n (point)))))))
- (insert string)))
diff --git a/lisp/emulation/mlconvert.el b/lisp/mlconvert.el
index faf88e5ab32..faf88e5ab32 100644
--- a/lisp/emulation/mlconvert.el
+++ b/lisp/mlconvert.el
diff --git a/lisp/mlconvert.elc b/lisp/mlconvert.elc
new file mode 100644
index 00000000000..52f49fb53f8
--- /dev/null
+++ b/lisp/mlconvert.elc
Binary files differ
diff --git a/lisp/emulation/mlsupport.el b/lisp/mlsupport.el
index 14e7a3c9557..e3c75776109 100644
--- a/lisp/emulation/mlsupport.el
+++ b/lisp/mlsupport.el
@@ -31,6 +31,9 @@
(defmacro declare-buffer-specific (&rest vars)
(cons 'progn (mapcar (function (lambda (var) (list 'make-variable-buffer-local (list 'quote var)))) vars)))
+(defmacro setq-default (var val)
+ (list 'set-default (list 'quote var) val))
+
(defun ml-set-default (varname value)
(set-default (intern varname) value))
@@ -118,7 +121,7 @@
(1- (point)) (point-max))))))
(defun set-auto-fill-hook (arg)
- (setq auto-fill-function (intern arg)))
+ (setq auto-fill-hook (intern arg)))
(defun auto-execute (function pattern)
(if (/= (aref pattern 0) ?*)
diff --git a/lisp/mlsupport.elc b/lisp/mlsupport.elc
new file mode 100644
index 00000000000..b546e6341b9
--- /dev/null
+++ b/lisp/mlsupport.elc
Binary files differ
diff --git a/lisp/progmodes/modula2.el b/lisp/modula2.el
index eee1ece3a00..bf714f0b437 100644
--- a/lisp/progmodes/modula2.el
+++ b/lisp/modula2.el
@@ -8,7 +8,7 @@
;;; Added by TEP
(defvar m2-mode-syntax-table nil
- "Syntax table in use in Modula-2 buffers.")
+ "Syntax table in use in Modula-2-mode buffers.")
(defvar m2-compile-command "m2c"
"Command to compile Modula-2 programs")
@@ -65,7 +65,6 @@
(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)
@@ -76,28 +75,28 @@
(defvar m2-indent 5 "*This variable gives the indentation in Modula-2-Mode")
(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-mode-map>
- \\[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."
+"This is a mode intended to support program development in Modula-2.
+All control constructs of Modula-2 can be reached by typing
+Control-C followed by the first character of the construct.
+\\{m2-mode-map}
+ Control-c b begin Control-c c case
+ Control-c d definition Control-c e else
+ Control-c f for Control-c h header
+ Control-c i if Control-c m module
+ Control-c l loop Control-c o or
+ Control-c p procedure Control-c Control-w with
+ Control-c r record Control-c s stdio
+ Control-c t type Control-c u until
+ Control-c v var Control-c w while
+ Control-c x export Control-c y import
+ Control-c { begin-comment Control-c } end-comment
+ Control-c Control-z suspend-emacs Control-c Control-t toggle
+ Control-c Control-c compile Control-x ` next-error
+ Control-c Control-l 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)
@@ -154,11 +153,10 @@ followed by the first character of the construct.
(defun m2-case ()
"Build skeleton CASE statment, prompting for the <expression>."
(interactive)
- (let ((name (read-string "Case-Expression: ")))
- (insert "CASE " name " OF")
- (m2-newline)
- (m2-newline)
- (insert "END (* case " name " *);"))
+ (insert "CASE " (read-string ": ") " OF")
+ (m2-newline)
+ (m2-newline)
+ (insert "END (* case *);")
(end-of-line 0)
(m2-tab))
@@ -182,18 +180,14 @@ followed by the first character of the construct.
(defun m2-for ()
"Build skeleton FOR loop statment, 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: "))
+ (insert "FOR " (read-string "init: ") " TO " (read-string "end: "))
+ (let ((by (read-string "by: ")))
(if (not (string-equal by ""))
- (insert " BY " by))
- (insert " DO")
- (m2-newline)
- (m2-newline)
- (insert "END (* for " name " to " limit " *);"))
+ (insert " BY " by)))
+ (insert " DO")
+ (m2-newline)
+ (m2-newline)
+ (insert "END (* for *);")
(end-of-line 0)
(m2-tab))
@@ -212,12 +206,10 @@ followed by the first character of the construct.
(defun m2-if ()
"Insert skeleton IF statment, prompting for <boolean-expression>."
(interactive)
- (insert "IF ")
- (let ((thecondition (read-string "<boolean-expression>: ")))
- (insert thecondition " THEN")
- (m2-newline)
- (m2-newline)
- (insert "END (* if " thecondition " *);"))
+ (insert "IF " (read-string "<boolean-expression>: ") " THEN")
+ (m2-newline)
+ (m2-newline)
+ (insert "END (* if *);")
(end-of-line 0)
(m2-tab))
@@ -236,19 +228,8 @@ followed by the first character of the construct.
(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))
+ (insert name ";\n\n\n\nEND " name ".\n"))
+ (previous-line 3))
(defun m2-or ()
(interactive)
@@ -282,12 +263,11 @@ followed by the first character of the construct.
(defun m2-with ()
(interactive)
(insert "WITH ")
- (let ((name (read-string "Record-Type: ")))
- (insert name)
- (insert " DO")
- (m2-newline)
- (m2-newline)
- (insert "END (* with " name " *);"))
+ (insert (read-string ": "))
+ (insert " DO")
+ (m2-newline)
+ (m2-newline)
+ (insert "END (* with *);")
(end-of-line 0)
(m2-tab))
@@ -303,14 +283,14 @@ followed by the first character of the construct.
(defun m2-stdio ()
(interactive)
(insert "
-FROM TextIO IMPORT
+>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;
+>FROM SysStreams IMPORT sysIn, sysOut, sysErr;
"))
@@ -326,7 +306,7 @@ FROM SysStreams IMPORT sysIn, sysOut, sysErr;
(m2-newline)
(m2-newline)
(insert "UNTIL ")
- (insert (read-string "<boolean-expression>: ") ";")
+ (insert (read-string ": ") ";")
(end-of-line 0)
(m2-tab))
@@ -340,11 +320,11 @@ FROM SysStreams IMPORT sysIn, sysOut, sysErr;
(defun m2-while ()
(interactive)
(insert "WHILE ")
- (let ((name (read-string "<boolean-expression>: ")))
- (insert name " DO" )
- (m2-newline)
- (m2-newline)
- (insert "END (* while " name " *);"))
+ (insert (read-string ": "))
+ (insert " DO")
+ (m2-newline)
+ (m2-newline)
+ (insert "END (* while *);")
(end-of-line 0)
(m2-tab))
diff --git a/lisp/modula2.elc b/lisp/modula2.elc
new file mode 100644
index 00000000000..e469854a3e2
--- /dev/null
+++ b/lisp/modula2.elc
Binary files differ
diff --git a/lisp/mouse.el b/lisp/mouse.el
deleted file mode 100644
index 5ca1c02c252..00000000000
--- a/lisp/mouse.el
+++ /dev/null
@@ -1,524 +0,0 @@
-;; Mouse support that is independent of window systems.
-;; Copyright (C) 1988 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-(provide 'mouse)
-
-
-(defun mouse-select ()
- "Select the Emacs window the mouse is on."
- (interactive "@"))
-
-(defun mouse-delete-window ()
- "Delete the Emacs window the mouse is on."
- (interactive "@")
- (delete-window))
-
-(defun mouse-keep-one-window ()
- "Select Emacs window mouse is on, then kill all other Emacs windows."
- (interactive "@")
- (delete-other-windows))
-
-(defun mouse-select-and-split ()
- "Select Emacs window mouse is on, then split it vertically in half."
- (interactive "@")
- (split-window-vertically nil))
-
-(defun mouse-set-point (event)
- "Select Emacs window mouse is on, and move point to mouse position."
- (interactive "@e")
- (let ((relative-coordinate
- (coordinates-in-window-p (car event) (selected-window))))
- (if (consp relative-coordinate)
- (progn
- (move-to-window-line (car (cdr relative-coordinate)))
- ;; Note that hscroll must get above 1
- ;; before the text actually starts to move.
- (move-to-column (+ (car relative-coordinate) (current-column)
- (1- (max 1 (window-hscroll (selected-window))))))
- (what-line)))))
-
-(defun mouse-eval-last-sexpr (event)
- (interactive "@e")
- (save-excursion
- (mouse-set-point event)
- (eval-last-sexp nil)))
-
-(defun mouse-line-length (event)
- "Print the length of the line indicated by the pointer."
- (interactive "@e")
- (let ((relative-coordinate
- (coordinates-in-window-p (car event) (selected-window))))
- (if (consp relative-coordinate)
- (save-excursion
- (move-to-window-line (car (cdr relative-coordinate)))
- (end-of-line)
- (push-mark nil t)
- (beginning-of-line)
- (message "Line length: %d"
- (- (region-end) (region-beginning)))
- (sleep-for 1)))))
-
-(defun mouse-set-mark (event)
- "Select Emacs window mouse is on, and set mark at mouse position.
-Display cursor at that position for a second."
- (interactive "@e")
- (let ((point-save (point)))
- (unwind-protect
- (progn (mouse-set-point event)
- (push-mark nil t)
- (sit-for 1))
- (goto-char point-save))))
-
-(defun mouse-fill-paragraph (event)
- "Fill the paragraph at the mouse position."
- (interactive "@e")
- (save-excursion
- (mouse-set-point event)
- (fill-paragraph)))
-
-(defun mouse-fill-paragraph-with-prefix (event)
- "Fill the paragraph at the mouse position with specified fill prefix.
-Click at the end of the fill prefix that you want;
-The text before the mouse position, on the same line, is used as the prefix."
- (interactive "@e")
- (save-excursion
- (mouse-set-point event)
- (let ((fill-prefix (buffer-substring (save-excursion (beginning-of-line)
- (point))
- (point))))
- (fill-paragraph))))
-
-(defun mouse-scroll (event)
- "Scroll point to the mouse position."
- (interactive "@e")
- (let ((relative-coordinate
- (coordinates-in-window-p (car event) (selected-window))))
- (if (consp relative-coordinate)
- (progn
- (recenter (car (cdr relative-coordinate)))
- (scroll-right (+ (car relative-coordinate) (current-column)))))))
-
-(defun mouse-del-char (event)
- "Delete the char pointed to by the mouse."
- (interactive "@e")
- (let ((relative-coordinate
- (coordinates-in-window-p (car event) (selected-window))))
- (if (consp relative-coordinate)
- (progn
- (move-to-window-line (car (cdr relative-coordinate)))
- (move-to-column (+ (car relative-coordinate) (current-column)))
- (delete-char 1 nil)))))
-
-(defun mouse-kill-line (event)
- "Kill the line pointed to by the mouse."
- (interactive "@e")
- (let ((relative-coordinate
- (coordinates-in-window-p (car event) (selected-window))))
- (if (consp relative-coordinate)
- (progn
- (move-to-window-line (car (cdr relative-coordinate)))
- (move-to-column (+ (car relative-coordinate) (current-column)))
- (kill-line nil)))))
-
-(defun narrow-window-to-region (m n)
- "Narrow window to region between point and last mark"
- (interactive "r")
- (save-excursion
- (save-restriction
- (if (eq (selected-window) (next-window))
- (split-window))
- (goto-char m)
- (recenter 0)
- (if (eq (selected-window)
- (if (zerop (minibuffer-depth))
- (next-window)))
- ()
- (shrink-window (- (- (window-height) (count-lines m n)) 1))))))
-
-(defun mouse-window-to-region (event)
- "Narrow window to region between cursor and mouse pointer."
- (interactive "@e")
- (let ((point-save (point)))
- (unwind-protect
- (progn (mouse-set-point event)
- (push-mark nil t)
- (sit-for 1))
- (goto-char point-save)
- (narrow-window-to-region (region-beginning) (region-end)))))
-
-(defun mouse-ignore ()
- "Don't do anything."
- (interactive))
-
-;; Commands for the scroll bar.
-
-(defun mouse-scroll-down (nlines)
- (interactive "@p")
- (scroll-down nlines))
-
-(defun mouse-scroll-up (nlines)
- (interactive "@p")
- (scroll-up nlines))
-
-(defun mouse-scroll-down-full ()
- (interactive "@")
- (scroll-down nil))
-
-(defun mouse-scroll-up-full ()
- (interactive "@")
- (scroll-up nil))
-
-(defun mouse-scroll-move-cursor (nlines)
- (interactive "@p")
- (move-to-window-line nlines))
-
-(defun mouse-scroll-absolute (event)
- (interactive "@e")
- (let* ((pos (car event))
- (position (car pos))
- (length (car (cdr pos))))
- (if (<= length 0) (setq length 1))
- (let* ((scale-factor (max 1 (/ length (/ 8000000 (buffer-size)))))
- (newpos (* (/ (* (/ (buffer-size) scale-factor)
- position)
- length)
- scale-factor)))
- (goto-char newpos)
- (recenter '(4)))))
-
-(defun mouse-scroll-left (ncolumns)
- (interactive "@p")
- (scroll-left ncolumns))
-
-(defun mouse-scroll-right (ncolumns)
- (interactive "@p")
- (scroll-right ncolumns))
-
-(defun mouse-scroll-left-full ()
- (interactive "@")
- (scroll-left nil))
-
-(defun mouse-scroll-right-full ()
- (interactive "@")
- (scroll-right nil))
-
-(defun mouse-scroll-move-cursor-horizontally (ncolumns)
- (interactive "@p")
- (move-to-column ncolumns))
-
-(defun mouse-scroll-absolute-horizontally (event)
- (interactive "@e")
- (let* ((pos (car event))
- (position (car pos))
- (length (car (cdr pos))))
- (set-window-hscroll (selected-window) 33)))
-
-;; Set up these commands, including the prefix keys for the scroll bar.
-
-(fset 'mouse-vertical-scroll-bar-prefix (make-sparse-keymap))
-(define-key global-mouse-map mouse-vertical-scroll-bar-prefix
- 'mouse-vertical-scroll-bar-prefix)
-
-(defun mouse-scroll-motion (event)
- (interactive "e")
- (let ((pos (car (car event)))
- (length (car (cdr (car event)))))
- (message "[%d %d]" pos length)))
-
-(let ((map (function mouse-vertical-scroll-bar-prefix)))
- (define-key map mouse-button-right 'mouse-scroll-down)
- (define-key map mouse-button-left 'mouse-scroll-up)
- (define-key map mouse-button-middle 'mouse-scroll-absolute)
- (define-key map mouse-motion 'x-horizontal-line))
-
-;(fset 'mouse-vertical-slider-prefix (make-sparse-keymap))
-;(define-key global-mouse-map mouse-vertical-slider-prefix
-; 'mouse-vertical-slider-prefix)
-
-;(let ((map (function mouse-vertical-slider-prefix)))
-; (define-key map mouse-button-right 'mouse-scroll-move-cursor)
-; (define-key map mouse-button-left 'mouse-scroll-move-cursor)
-; (define-key map mouse-button-middle 'mouse-scroll-move-cursor))
-
-(fset 'mouse-vertical-thumbup-prefix (make-sparse-keymap))
-(define-key global-mouse-map mouse-vertical-thumbup-prefix
- 'mouse-vertical-thumbup-prefix)
-
-(let ((map (function mouse-vertical-thumbup-prefix)))
- (define-key map mouse-button-right 'mouse-scroll-down-full)
- (define-key map mouse-button-left 'mouse-scroll-down-full)
- (define-key map mouse-button-middle 'mouse-scroll-down-full))
-
-(fset 'mouse-vertical-thumbdown-prefix (make-sparse-keymap))
-(define-key global-mouse-map mouse-vertical-thumbdown-prefix
- 'mouse-vertical-thumbdown-prefix)
-
-(let ((map (function mouse-vertical-thumbdown-prefix)))
- (define-key map mouse-button-right 'mouse-scroll-up-full)
- (define-key map mouse-button-left 'mouse-scroll-up-full)
- (define-key map mouse-button-middle 'mouse-scroll-up-full))
-
-;; Horizontal bar
-
-(fset 'mouse-horizontal-scroll-bar-prefix (make-sparse-keymap))
-(define-key global-mouse-map mouse-horizontal-scroll-bar-prefix
- 'mouse-horizontal-scroll-bar-prefix)
-
-(let ((map (function mouse-horizontal-scroll-bar-prefix)))
- (define-key map mouse-button-right 'mouse-scroll-right)
- (define-key map mouse-button-left 'mouse-scroll-left)
- (define-key map mouse-button-middle 'mouse-scroll-absolute-horizontally))
-
-(fset 'mouse-horizontal-thumbleft-prefix (make-sparse-keymap))
-(define-key global-mouse-map mouse-horizontal-thumbleft-prefix
- 'mouse-horizontal-thumbleft-prefix)
-
-(let ((map (function mouse-horizontal-thumbleft-prefix)))
- (define-key map mouse-button-right 'mouse-scroll-left-full)
- (define-key map mouse-button-left 'mouse-scroll-left-full)
- (define-key map mouse-button-middle 'mouse-scroll-left-full))
-
-(fset 'mouse-horizontal-thumbright-prefix (make-sparse-keymap))
-(define-key global-mouse-map mouse-horizontal-thumbright-prefix
- 'mouse-horizontal-thumbright-prefix)
-
-(let ((map (function mouse-horizontal-thumbright-prefix)))
- (define-key map mouse-button-right 'mouse-scroll-right-full)
- (define-key map mouse-button-left 'mouse-scroll-right-full)
- (define-key map mouse-button-middle 'mouse-scroll-right-full))
-
-
-;;
-;; Here are experimental things being tested. Mouse events
-;; are of the form:
-;; ((x y) window screen-part key-sequence timestamp)
-
-;;
-;; Dynamically track mouse coordinates
-;;
-
-(defun track-mouse (event)
- "Track the coordinates, absolute and relative, of the mouse."
- (interactive "@e")
- (while mouse-grabbed
- (let* ((pos (read-mouse-position (selected-screen)))
- (abs-x (car pos))
- (abs-y (cdr pos))
- (relative-coordinate (coordinates-in-window-p
- (list (car pos) (cdr pos))
- (selected-window))))
- (if (consp relative-coordinate)
- (message "mouse: [%d %d], (%d %d)" abs-x abs-y
- (car relative-coordinate)
- (car (cdr relative-coordinate)))
- (message "mouse: [%d %d]" abs-x abs-y)))))
-
-;;
-;; Dynamically put a box around the line indicated by point
-;;
-
-(require 'backquote)
-
-(defun mouse-select-buffer-line (event)
- (interactive "@e")
- (let ((relative-coordinate
- (coordinates-in-window-p (car event) (selected-window)))
- (abs-y (car (cdr (car event)))))
- (if (consp relative-coordinate)
- (progn
- (save-excursion
- (move-to-window-line (car (cdr relative-coordinate)))
- (x-draw-rectangle
- (selected-screen)
- abs-y 0
- (save-excursion
- (move-to-window-line (car (cdr relative-coordinate)))
- (end-of-line)
- (push-mark nil t)
- (beginning-of-line)
- (- (region-end) (region-beginning))) 1)
- (setq the-buffer (Buffer-menu-buffer t)))
- (sit-for 1)
- (x-erase-rectangle (selected-screen))))))
-
-(defvar last-line-drawn nil)
-(defvar begin-delim "[^ \t]")
-(defvar end-delim "[^ \t]")
-
-(defun mouse-boxing (event)
- (interactive "@e")
- (save-excursion
- (let ((screen (selected-screen)))
- (while (= (x-mouse-events) 0)
- (let* ((pos (read-mouse-position screen))
- (abs-x (car pos))
- (abs-y (cdr pos))
- (relative-coordinate
- (coordinates-in-window-p (` ((, abs-x) (, abs-y)))
- (selected-window)))
- (begin-reg nil)
- (end-reg nil)
- (end-column nil)
- (begin-column nil))
- (if (and (consp relative-coordinate)
- (or (not last-line-drawn)
- (not (= last-line-drawn abs-y))))
- (progn
- (move-to-window-line (car (cdr relative-coordinate)))
- (if (= (following-char) 10)
- ()
- (progn
- (setq begin-reg (1- (re-search-forward end-delim)))
- (setq begin-column (1- (current-column)))
- (end-of-line)
- (setq end-reg (1+ (re-search-backward begin-delim)))
- (setq end-column (1+ (current-column)))
- (message "%s" (buffer-substring begin-reg end-reg))
- (x-draw-rectangle screen
- (setq last-line-drawn abs-y)
- begin-column
- (- end-column begin-column) 1))))))))))
-
-(defun mouse-erase-box ()
- (interactive)
- (if last-line-drawn
- (progn
- (x-erase-rectangle (selected-screen))
- (setq last-line-drawn nil))))
-
-(defun test-x-rectangle ()
- (use-local-mouse-map (setq rectangle-test-map (make-sparse-keymap)))
- (define-key rectangle-test-map mouse-motion-button-left 'mouse-boxing)
- (define-key rectangle-test-map mouse-button-left-up 'mouse-erase-box))
-
-;;
-;; Here is how to do double clicking in lisp. About to change.
-;;
-
-(defvar double-start nil)
-(defconst double-click-interval 300
- "Max ticks between clicks")
-
-(defun double-down (event)
- (interactive "@e")
- (if double-start
- (let ((interval (- (nth 4 event) double-start)))
- (if (< interval double-click-interval)
- (progn
- (backward-up-list 1)
- ;; (message "Interval %d" interval)
- (sleep-for 1)))
- (setq double-start nil))
- (setq double-start (nth 4 event))))
-
-(defun double-up (event)
- (interactive "@e")
- (and double-start
- (> (- (nth 4 event ) double-start) double-click-interval)
- (setq double-start nil)))
-
-(defun x-test-doubleclick ()
- (use-local-mouse-map (setq doubleclick-test-map (make-sparse-keymap)))
- (define-key doubleclick-test-map mouse-button-left 'double-down)
- (define-key doubleclick-test-map mouse-button-left-up 'double-up))
-
-;;
-;; This scrolls while button is depressed. Use preferable in scrollbar.
-;;
-
-(defvar scrolled-lines 0)
-(defconst scroll-speed 1)
-
-(defun incr-scroll-down (event)
- (interactive "@e")
- (setq scrolled-lines 0)
- (incremental-scroll scroll-speed))
-
-(defun incr-scroll-up (event)
- (interactive "@e")
- (setq scrolled-lines 0)
- (incremental-scroll (- scroll-speed)))
-
-(defun incremental-scroll (n)
- (while (= (x-mouse-events) 0)
- (setq scrolled-lines (1+ (* scroll-speed scrolled-lines)))
- (scroll-down n)
- (sit-for 300 t)))
-
-(defun incr-scroll-stop (event)
- (interactive "@e")
- (message "Scrolled %d lines" scrolled-lines)
- (setq scrolled-lines 0)
- (sleep-for 1))
-
-(defun x-testing-scroll ()
- (let ((scrolling-map (function mouse-vertical-scroll-bar-prefix)))
- (define-key scrolling-map mouse-button-left 'incr-scroll-down)
- (define-key scrolling-map mouse-button-right 'incr-scroll-up)
- (define-key scrolling-map mouse-button-left-up 'incr-scroll-stop)
- (define-key scrolling-map mouse-button-right-up 'incr-scroll-stop)))
-
-;;
-;; Some playthings suitable for picture mode? They need work.
-;;
-
-(defun mouse-kill-rectangle (event)
- "Kill the rectangle between point and the mouse cursor."
- (interactive "@e")
- (let ((point-save (point)))
- (save-excursion
- (mouse-set-point event)
- (push-mark nil t)
- (if (> point-save (point))
- (kill-rectangle (point) point-save)
- (kill-rectangle point-save (point))))))
-
-(defun mouse-open-rectangle (event)
- "Kill the rectangle between point and the mouse cursor."
- (interactive "@e")
- (let ((point-save (point)))
- (save-excursion
- (mouse-set-point event)
- (push-mark nil t)
- (if (> point-save (point))
- (open-rectangle (point) point-save)
- (open-rectangle point-save (point))))))
-
-;; Must be a better way to do this.
-
-(defun mouse-multiple-insert (n char)
- (while (> n 0)
- (insert char)
- (setq n (1- n))))
-
-;; What this could do is not finalize until button was released.
-
-(defun mouse-move-text (event)
- "Move text from point to cursor position, inserting spaces."
- (interactive "@e")
- (let* ((relative-coordinate
- (coordinates-in-window-p (car event) (selected-window))))
- (if (consp relative-coordinate)
- (cond ((> (current-column) (car relative-coordinate))
- (delete-char
- (- (car relative-coordinate) (current-column))))
- ((< (current-column) (car relative-coordinate))
- (mouse-multiple-insert
- (- (car relative-coordinate) (current-column)) " "))
- ((= (current-column) (car relative-coordinate)) (ding))))))
diff --git a/lisp/netunam.el b/lisp/netunam.el
deleted file mode 100644
index 44d828729ef..00000000000
--- a/lisp/netunam.el
+++ /dev/null
@@ -1,152 +0,0 @@
-;; HP-UX RFA Commands
-;; Copyright (C) 1988 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;;; Author: cph@zurich.ai.mit.edu
-
-;;; $Header: netunam.el,v 1.3 88/12/21 16:32:23 GMT cph Exp $
-
-(defconst rfa-node-directory "/net/"
- "Directory in which RFA network special files are stored.
-By HP convention, this is \"/net/\".")
-
-(defvar rfa-default-node nil
- "If not nil, this is the name of the default RFA network special file.")
-
-(defvar rfa-password-memoize-p t
- "If non-nil, remember login user's passwords after they have been entered.")
-
-(defvar rfa-password-alist '()
- "An association from node-name strings to password strings.
-Used if `rfa-password-memoize-p' is non-nil.")
-
-(defvar rfa-password-per-node-p t
- "If nil, login user uses same password on all machines.
-Has no effect if `rfa-password-memoize-p' is nil.")
-
-(defun rfa-set-password (password &optional node user)
- "Add PASSWORD to the RFA password database.
-Optional second arg NODE is a string specifying a particular nodename;
- if supplied and not nil, PASSWORD applies to only that node.
-Optional third arg USER is a string specifying the (remote) user whose
- password this is; if not supplied this defaults to (user-login-name)."
- (if (not user) (setq user (user-login-name)))
- (let ((node-entry (assoc node rfa-password-alist)))
- (if node-entry
- (let ((user-entry (assoc user (cdr node-entry))))
- (if user-entry
- (rplacd user-entry password)
- (rplacd node-entry
- (nconc (cdr node-entry)
- (list (cons user password))))))
- (setq rfa-password-alist
- (nconc rfa-password-alist
- (list (list node (cons user password))))))))
-
-(defun rfa-open (node &optional user password)
- "Open a network connection to a server using remote file access.
-First argument NODE is the network node for the remote machine.
-Second optional argument USER is the user name to use on that machine.
- If called interactively, the user name is prompted for.
-Third optional argument PASSWORD is the password string for that user.
- If not given, this is filled in from the value of
-`rfa-password-alist', or prompted for. A prefix argument of - will
-cause the password to be prompted for even if previously memoized."
- (interactive
- (list (read-file-name "rfa-open: " rfa-node-directory rfa-default-node t)
- (read-string "user-name: " (user-login-name))))
- (let ((node
- (and (or rfa-password-per-node-p
- (not (equal user (user-login-name))))
- node)))
- (if (not password)
- (setq password
- (let ((password
- (cdr (assoc user (cdr (assoc node rfa-password-alist))))))
- (or (and (not current-prefix-arg) password)
- (rfa-password-read
- (format "password for user %s%s: "
- user
- (if node (format " on node \"%s\"" node) ""))
- password))))))
- (let ((result
- (sysnetunam (expand-file-name node rfa-node-directory)
- (concat user ":" password))))
- (if (interactive-p)
- (if result
- (message "Opened network connection to %s as %s" node user)
- (error "Unable to open network connection")))
- (if (and rfa-password-memoize-p result)
- (rfa-set-password password node user))
- result))
-
-(defun rfa-close (node)
- "Close a network connection to a server using remote file access.
-NODE is the network node for the remote machine."
- (interactive
- (list (read-file-name "rfa-close: " rfa-node-directory rfa-default-node t)))
- (let ((result (sysnetunam (expand-file-name node rfa-node-directory) "")))
- (cond ((not (interactive-p)) result)
- ((not result) (error "Unable to close network connection"))
- (t (message "Closed network connection to %s" node)))))
-
-(defun rfa-password-read (prompt default)
- (let ((rfa-password-accumulator (or default "")))
- (read-from-minibuffer prompt
- (and default
- (let ((copy (concat default))
- (index 0)
- (length (length default)))
- (while (< index length)
- (aset copy index ?.)
- (setq index (1+ index)))
- copy))
- rfa-password-map)
- rfa-password-accumulator))
-
-(defvar rfa-password-map nil)
-(if (not rfa-password-map)
- (let ((char ? ))
- (setq rfa-password-map (make-keymap))
- (while (< char 127)
- (define-key rfa-password-map (char-to-string char)
- 'rfa-password-self-insert)
- (setq char (1+ char)))
- (define-key rfa-password-map "\C-g"
- 'abort-recursive-edit)
- (define-key rfa-password-map "\177"
- 'rfa-password-rubout)
- (define-key rfa-password-map "\n"
- 'exit-minibuffer)
- (define-key rfa-password-map "\r"
- 'exit-minibuffer)))
-
-(defvar rfa-password-accumulator nil)
-
-(defun rfa-password-self-insert ()
- (interactive)
- (setq rfa-password-accumulator
- (concat rfa-password-accumulator
- (char-to-string last-command-char)))
- (insert ?.))
-
-(defun rfa-password-rubout ()
- (interactive)
- (delete-char -1)
- (setq rfa-password-accumulator
- (substring rfa-password-accumulator 0 -1)))
diff --git a/lisp/nnspool.el b/lisp/nnspool.el
deleted file mode 100644
index 8c5a36ca6ba..00000000000
--- a/lisp/nnspool.el
+++ /dev/null
@@ -1,374 +0,0 @@
-;;; Spool access using NNTP for GNU Emacs
-;; Copyright (C) 1988, 1989 Fujitsu Laboratories LTD.
-;; Copyright (C) 1988, 1989, 1990 Masanobu UMEDA
-;; $Header: nnspool.el,v 1.10 90/03/23 13:25:25 umerin Locked $
-
-;; This file is part of GNU Emacs.
-
-;; 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.
-
-(provide 'nnspool)
-(require 'nntp)
-
-(defvar nnspool-inews-program news-inews-program
- "*Program to post news.")
-
-(defvar nnspool-inews-switches '("-h")
- "*Switches for nnspool-request-post to pass to `inews' for posting news.")
-
-(defvar nnspool-spool-directory news-path
- "*Local news spool directory.")
-
-(defvar nnspool-active-file "/usr/lib/news/active"
- "*Local news active file.")
-
-(defvar nnspool-history-file "/usr/lib/news/history"
- "*Local news history file.")
-
-
-
-(defconst nnspool-version "NNSPOOL 1.10"
- "Version numbers of this version of NNSPOOL.")
-
-(defvar nnspool-current-directory nil
- "Current news group directory.")
-
-;;;
-;;; Replacement of Extended Command for retrieving many headers.
-;;;
-
-(defun nnspool-retrieve-headers (sequence)
- "Return list of article headers specified by SEQUENCE of article id.
-The format of list is
- `([NUMBER SUBJECT FROM XREF LINES DATE MESSAGE-ID REFERENCES] ...)'.
-Reader macros for the vector are defined as `nntp-header-FIELD'.
-Writer macros for the vector are defined as `nntp-set-header-FIELD'.
-News group must be selected before calling me."
- (save-excursion
- (set-buffer nntp-server-buffer)
- ;;(erase-buffer)
- (let ((file nil)
- (number (length sequence))
- (count 0)
- (headers nil) ;Result list.
- (article 0)
- (subject nil)
- (message-id nil)
- (from nil)
- (xref nil)
- (lines 0)
- (date nil)
- (references nil))
- (while sequence
- ;;(nntp-send-strings-to-server "HEAD" (car sequence))
- (setq article (car sequence))
- (setq file
- (concat nnspool-current-directory (prin1-to-string article)))
- (if (and (file-exists-p file)
- (not (file-directory-p file)))
- (progn
- (erase-buffer)
- (insert-file-contents file)
- ;; Make message body invisible.
- (goto-char (point-min))
- (search-forward "\n\n" nil 'move)
- (narrow-to-region (point-min) (point))
- ;; Fold continuation lines.
- (goto-char (point-min))
- (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
- (replace-match " " t t))
- ;; Make it possible to search for `\nFIELD'.
- (goto-char (point-min))
- (insert "\n")
- ;; Extract From:
- (goto-char (point-min))
- (if (search-forward "\nFrom: " nil t)
- (setq from (buffer-substring
- (point)
- (save-excursion (end-of-line) (point))))
- (setq from "(Unknown User)"))
- ;; Extract Subject:
- (goto-char (point-min))
- (if (search-forward "\nSubject: " nil t)
- (setq subject (buffer-substring
- (point)
- (save-excursion (end-of-line) (point))))
- (setq subject "(None)"))
- ;; Extract Message-ID:
- (goto-char (point-min))
- (if (search-forward "\nMessage-ID: " nil t)
- (setq message-id (buffer-substring
- (point)
- (save-excursion (end-of-line) (point))))
- (setq message-id nil))
- ;; Extract Date:
- (goto-char (point-min))
- (if (search-forward "\nDate: " nil t)
- (setq date (buffer-substring
- (point)
- (save-excursion (end-of-line) (point))))
- (setq date nil))
- ;; Extract Lines:
- (goto-char (point-min))
- (if (search-forward "\nLines: " nil t)
- (setq lines (string-to-int
- (buffer-substring
- (point)
- (save-excursion (end-of-line) (point)))))
- (setq lines 0))
- ;; Extract Xref:
- (goto-char (point-min))
- (if (search-forward "\nXref: " nil t)
- (setq xref (buffer-substring
- (point)
- (save-excursion (end-of-line) (point))))
- (setq xref nil))
- ;; Extract References:
- (goto-char (point-min))
- (if (search-forward "\nReferences: " nil t)
- (setq references (buffer-substring
- (point)
- (save-excursion (end-of-line) (point))))
- (setq references nil))
- (setq headers
- (cons (vector article subject from
- xref lines date
- message-id references) headers))
- ))
- (setq sequence (cdr sequence))
- (setq count (1+ count))
- (and (numberp nntp-large-newsgroup)
- (> number nntp-large-newsgroup)
- (zerop (% count 20))
- (message "NNSPOOL: %d%% of headers received."
- (/ (* count 100) number)))
- )
- (and (numberp nntp-large-newsgroup)
- (> number nntp-large-newsgroup)
- (message "NNSPOOL: 100%% of headers received."))
- (nreverse headers)
- )))
-
-
-;;;
-;;; Replacement of NNTP Raw Interface.
-;;;
-
-(defun nnspool-open-server (host &optional service)
- "Open news server on HOST.
-If HOST is nil, use value of environment variable `NNTPSERVER'.
-If optional argument SERVICE is non-nil, open by the service name."
- (let ((host (or host (getenv "NNTPSERVER")))
- (status nil))
- (setq nntp-status-message-string "")
- (cond ((and (file-directory-p nnspool-spool-directory)
- (file-exists-p nnspool-active-file)
- (string-equal host (system-name)))
- (setq status (nnspool-open-server-internal host service)))
- ((string-equal host (system-name))
- (setq nntp-status-message-string
- (format "%s has no news spool. Goodbye." host)))
- ((null host)
- (setq nntp-status-message-string "NNTP server is not specified."))
- (t
- (setq nntp-status-message-string
- (format "NNSPOOL: cannot talk to %s." host)))
- )
- status
- ))
-
-(defun nnspool-close-server ()
- "Close news server."
- (nnspool-close-server-internal))
-
-(fset 'nnspool-request-quit (symbol-function 'nnspool-close-server))
-
-(defun nnspool-server-opened ()
- "Return server process status, T or NIL.
-If the stream is opened, return T, otherwise return NIL."
- (and nntp-server-buffer
- (get-buffer nntp-server-buffer)))
-
-(defun nnspool-status-message ()
- "Return server status response as string."
- nntp-status-message-string
- )
-
-(defun nnspool-request-article (id)
- "Select article by message ID (or number)."
- (let ((file (if (stringp id)
- (nnspool-find-article-by-message-id id)
- (concat nnspool-current-directory (prin1-to-string id)))))
- (if (and (stringp file)
- (file-exists-p file)
- (not (file-directory-p file)))
- (save-excursion
- (nnspool-find-file file)))
- ))
-
-(defun nnspool-request-body (id)
- "Select article body by message ID (or number)."
- (if (nnspool-request-article id)
- (save-excursion
- (set-buffer nntp-server-buffer)
- (goto-char (point-min))
- (if (search-forward "\n\n" nil t)
- (delete-region (point-min) (point)))
- t
- )
- ))
-
-(defun nnspool-request-head (id)
- "Select article head by message ID (or number)."
- (if (nnspool-request-article id)
- (save-excursion
- (set-buffer nntp-server-buffer)
- (goto-char (point-min))
- (if (search-forward "\n\n" nil t)
- (delete-region (1- (point)) (point-max)))
- t
- )
- ))
-
-(defun nnspool-request-stat (id)
- "Select article by message ID (or number)."
- (error "NNSPOOL: STAT is not implemented."))
-
-(defun nnspool-request-group (group)
- "Select news GROUP."
- (let ((pathname (nnspool-article-pathname
- (nnspool-replace-chars-in-string group ?. ?/))))
- (if (file-directory-p pathname)
- (setq nnspool-current-directory pathname))
- ))
-
-(defun nnspool-request-list ()
- "List valid newsgoups."
- (save-excursion
- (nnspool-find-file nnspool-active-file)))
-
-(defun nnspool-request-last ()
- "Set current article pointer to the previous article in the current news group."
- (error "NNSPOOL: LAST is not implemented."))
-
-(defun nnspool-request-next ()
- "Advance current article pointer."
- (error "NNSPOOL: NEXT is not implemented."))
-
-(defun nnspool-request-post ()
- "Post a new news in current buffer."
- (save-excursion
- ;; We have to work in the server buffer because of NEmacs hack.
- (copy-to-buffer nntp-server-buffer (point-min) (point-max))
- (set-buffer nntp-server-buffer)
- (apply 'call-process-region
- (point-min) (point-max)
- nnspool-inews-program 'delete t nil nnspool-inews-switches)
- (prog1
- (or (zerop (buffer-size))
- ;; If inews returns strings, it must be error message
- ;; unless SPOOLNEWS is defined.
- ;; This condition is very weak, but there is no good rule
- ;; identifying errors when SPOOLNEWS is defined.
- ;; Suggested by ohm@kaba.junet.
- (string-match "spooled" (buffer-string)))
- ;; Make status message by unfolding lines.
- (subst-char-in-region (point-min) (point-max) ?\n ?\\ 'noundo)
- (setq nntp-status-message-string (buffer-string))
- (erase-buffer))
- ))
-
-
-;;;
-;;; Replacement of Low-Level Interface to NNTP Server.
-;;;
-
-(defun nnspool-open-server-internal (host &optional service)
- "Open connection to news server on HOST by SERVICE (default is nntp)."
- (save-excursion
- (if (not (string-equal host (system-name)))
- (error "NNSPOOL: cannot talk to %s." host))
- ;; Initialize communication buffer.
- (setq nntp-server-buffer (get-buffer-create " *nntpd*"))
- (set-buffer nntp-server-buffer)
- (buffer-flush-undo (current-buffer))
- (erase-buffer)
- (kill-all-local-variables)
- (setq case-fold-search t) ;Should ignore case.
- (setq nntp-server-process nil)
- (setq nntp-server-name host)
- ;; It is possible to change kanji-fileio-code in this hook.
- (run-hooks 'nntp-server-hook)
- t
- ))
-
-(defun nnspool-close-server-internal ()
- "Close connection to news server."
- (if (get-file-buffer nnspool-history-file)
- (kill-buffer (get-file-buffer nnspool-history-file)))
- (if nntp-server-buffer
- (kill-buffer nntp-server-buffer))
- (setq nntp-server-buffer nil)
- (setq nntp-server-process nil))
-
-(defun nnspool-find-article-by-message-id (id)
- "Return full pathname of an article identified by message-ID."
- (save-excursion
- (let ((buffer (get-file-buffer nnspool-history-file)))
- (if buffer
- (set-buffer buffer)
- ;; Finding history file may take lots of time.
- (message "Reading history file...")
- (set-buffer (find-file-noselect nnspool-history-file))
- (message "Reading history file... done")))
- ;; Search from end of the file. I think this is much faster than
- ;; do from the beginning of the file.
- (goto-char (point-max))
- (if (re-search-backward
- (concat "^" (regexp-quote id)
- "[ \t].*[ \t]\\([^ \t/]+\\)/\\([0-9]+\\)[ \t]*$") nil t)
- (let ((group (buffer-substring (match-beginning 1) (match-end 1)))
- (number (buffer-substring (match-beginning 2) (match-end 2))))
- (concat (nnspool-article-pathname
- (nnspool-replace-chars-in-string group ?. ?/))
- number))
- )))
-
-(defun nnspool-find-file (file)
- "Insert FILE in server buffer safely."
- (set-buffer nntp-server-buffer)
- (erase-buffer)
- (condition-case ()
- (progn (insert-file-contents file) t)
- (file-error nil)
- ))
-
-(defun nnspool-article-pathname (group)
- "Make pathname for GROUP."
- (concat (file-name-as-directory nnspool-spool-directory) group "/"))
-
-(defun nnspool-replace-chars-in-string (string from to)
- "Replace characters in STRING from FROM to TO."
- (let ((string (substring string 0)) ;Copy string.
- (len (length string))
- (idx 0))
- ;; Replace all occurence of FROM with TO.
- (while (< idx len)
- (if (= (aref string idx) from)
- (aset string idx to))
- (setq idx (1+ idx)))
- string
- ))
diff --git a/lisp/nntp.el b/lisp/nntp.el
deleted file mode 100644
index 6bb7a741076..00000000000
--- a/lisp/nntp.el
+++ /dev/null
@@ -1,667 +0,0 @@
-;;; NNTP (RFC977) Interface for GNU Emacs
-;; Copyright (C) 1987, 1988, 1989 Fujitsu Laboratories LTD.
-;; Copyright (C) 1987, 1988, 1989, 1990 Masanobu UMEDA
-;; $Header: nntp.el,v 3.10 90/03/23 13:25:27 umerin Locked $
-
-;; This file is part of GNU Emacs.
-
-;; 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.
-
-;; This implementation is tested on both 1.2a and 1.5 version of the
-;; NNTP package.
-
-;; Troubleshooting of NNTP
-;;
-;; (1) Select routine may signal an error or fall into infinite loop
-;; while waiting for the server response. In this case, you'd better
-;; not use byte-compiled codes but original source. If you still have
-;; a problems with it, set the variable `nntp-buggy-select' to T.
-;;
-;; (2) Emacs may hang up while retrieving headers since too many
-;; requests have been sent to the NNTP server without reading their
-;; replies. In this case, reduce the number of the requests sent to
-;; the server at one time by setting the variable
-;; `nntp-maximum-request' to a lower value.
-;;
-;; (3) If the TCP/IP stream (open-network-stream) is not supported by
-;; emacs, compile and install `tcp.el' and `tcp.c' which is an
-;; emulation program of the stream. If you modified `tcp.c' for your
-;; system, please send me the diffs. I'll include some of them in the
-;; future releases.
-
-(provide 'nntp)
-
-(defvar nntp-server-hook nil
- "*Hooks for the NNTP server.
-If the kanji code of the NNTP server is different from the local kanji
-code, the correct kanji code of the buffer associated with the NNTP
-server must be specified as follows:
-
-(setq nntp-server-hook
- '(lambda ()
- ;; Server's Kanji code is EUC (NEmacs hack).
- (make-local-variable 'kanji-fileio-code)
- (setq kanji-fileio-code 0)))
-
-If you'd like to change something depending on the server in this
-hook, use the variable `nntp-server-name'.")
-
-(defvar nntp-buggy-select (memq system-type '(usg-unix-v fujitsu-uts))
- "*T if your select routine is buggy.
-If the select routine signals error or fall into infinite loop while
-waiting for the server response, the variable must be set to t. In
-case of Fujitsu UTS, it is set to T since `accept-process-output'
-doesn't work properly.")
-
-(defvar nntp-maximum-request 400
- "*The maximum number of the requests sent to the NNTP server at one time.
-If Emacs hangs up while retrieving headers, set the variable to a
-lower value.")
-
-(defvar nntp-large-newsgroup 50
- "*The number of the articles which indicates a large newsgroup.
-If the number of the articles is greater than the value, verbose
-messages will be shown to indicate the current status.")
-
-
-(defconst nntp-version "NNTP 3.10"
- "Version numbers of this version of NNTP.")
-
-(defvar nntp-server-name nil
- "The name of the host running NNTP server.")
-
-(defvar nntp-server-buffer nil
- "Buffer associated with NNTP server process.")
-
-(defvar nntp-server-process nil
- "The NNTP server process.
-You'd better not use this variable in NNTP front-end program but
-instead use `nntp-server-buffer'.")
-
-(defvar nntp-status-message-string nil
- "Save the server response message.
-You'd better not use this variable in NNTP front-end program but
-instead call function `nntp-status-message' to get status message.")
-
-;;;
-;;; Extended Command for retrieving many headers.
-;;;
-;; Retrieving lots of headers by sending command asynchronously.
-;; Access functions to headers are defined as macro.
-
-(defmacro nntp-header-number (header)
- "Return article number in HEADER."
- (` (aref (, header) 0)))
-
-(defmacro nntp-set-header-number (header number)
- "Set article number of HEADER to NUMBER."
- (` (aset (, header) 0 (, number))))
-
-(defmacro nntp-header-subject (header)
- "Return subject string in HEADER."
- (` (aref (, header) 1)))
-
-(defmacro nntp-set-header-subject (header subject)
- "Set article subject of HEADER to SUBJECT."
- (` (aset (, header) 1 (, subject))))
-
-(defmacro nntp-header-from (header)
- "Return author string in HEADER."
- (` (aref (, header) 2)))
-
-(defmacro nntp-set-header-from (header from)
- "Set article author of HEADER to FROM."
- (` (aset (, header) 2 (, from))))
-
-(defmacro nntp-header-xref (header)
- "Return xref string in HEADER."
- (` (aref (, header) 3)))
-
-(defmacro nntp-set-header-xref (header xref)
- "Set article xref of HEADER to xref."
- (` (aset (, header) 3 (, xref))))
-
-(defmacro nntp-header-lines (header)
- "Return lines in HEADER."
- (` (aref (, header) 4)))
-
-(defmacro nntp-set-header-lines (header lines)
- "Set article lines of HEADER to LINES."
- (` (aset (, header) 4 (, lines))))
-
-(defmacro nntp-header-date (header)
- "Return date in HEADER."
- (` (aref (, header) 5)))
-
-(defmacro nntp-set-header-date (header date)
- "Set article date of HEADER to DATE."
- (` (aset (, header) 5 (, date))))
-
-(defmacro nntp-header-id (header)
- "Return Id in HEADER."
- (` (aref (, header) 6)))
-
-(defmacro nntp-set-header-id (header id)
- "Set article Id of HEADER to ID."
- (` (aset (, header) 6 (, id))))
-
-(defmacro nntp-header-references (header)
- "Return references in HEADER."
- (` (aref (, header) 7)))
-
-(defmacro nntp-set-header-references (header ref)
- "Set article references of HEADER to REF."
- (` (aset (, header) 7 (, ref))))
-
-(defun nntp-retrieve-headers (sequence)
- "Return list of article headers specified by SEQUENCE of article id.
-The format of list is
- `([NUMBER SUBJECT FROM XREF LINES DATE MESSAGE-ID REFERENCES] ...)'.
-Reader macros for the vector are defined as `nntp-header-FIELD'.
-Writer macros for the vector are defined as `nntp-set-header-FIELD'.
-News group must be selected before calling me."
- (save-excursion
- (set-buffer nntp-server-buffer)
- (erase-buffer)
- (let ((number (length sequence))
- (last-point (point-min))
- (received 0)
- (count 0)
- (headers nil) ;Result list.
- (article 0)
- (subject nil)
- (message-id)
- (from nil)
- (xref nil)
- (lines 0)
- (date nil)
- (references nil))
- ;; Send HEAD command.
- (while sequence
- (nntp-send-strings-to-server "HEAD" (car sequence))
- (setq sequence (cdr sequence))
- (setq count (1+ count))
- ;; Every 400 header requests we have to read stream in order
- ;; to avoid deadlock.
- (if (or (null sequence) ;All requests have been sent.
- (zerop (% count nntp-maximum-request)))
- (progn
- (accept-process-output)
- (while (progn
- (goto-char last-point)
- ;; Count replies.
- (while (re-search-forward "^[0-9]" nil t)
- (setq received (1+ received)))
- (setq last-point (point))
- (< received count))
- ;; If number of headers is greater than 100, give
- ;; informative messages.
- (and (numberp nntp-large-newsgroup)
- (> number nntp-large-newsgroup)
- (zerop (% received 20))
- (message "NNTP: %d%% of headers received."
- (/ (* received 100) number)))
- (nntp-accept-response))
- ))
- )
- ;; Wait for text of last command.
- (goto-char (point-max))
- (re-search-backward "^[0-9]" nil t)
- (if (looking-at "^[23]")
- (while (progn
- (goto-char (- (point-max) 3))
- (not (looking-at "^\\.\r$")))
- (nntp-accept-response)))
- (and (numberp nntp-large-newsgroup)
- (> number nntp-large-newsgroup)
- (message "NNTP: 100%% of headers received."))
- ;; Now all of replies are received.
- (setq received number)
- ;; First, fold continuation lines.
- (goto-char (point-min))
- (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
- (replace-match " " t t))
- ;;(delete-non-matching-lines
- ;; "^Subject:\\|^Xref:\\|^From:\\|^Lines:\\|^Date:\\|^References:\\|^[23]")
- (and (numberp nntp-large-newsgroup)
- (> number nntp-large-newsgroup)
- (message "NNTP: Parsing headers..."))
- ;; Then examines replies.
- (goto-char (point-min))
- (while (not (eobp))
- (cond ((looking-at "^[23][0-9][0-9][ \t]+\\([0-9]+\\)[ \t]+\\(<[^>]+>\\)")
- (setq article
- (string-to-int
- (buffer-substring (match-beginning 1) (match-end 1))))
- (setq message-id
- (buffer-substring (match-beginning 2) (match-end 2)))
- (forward-line 1)
- ;; Set default value.
- (setq subject nil)
- (setq xref nil)
- (setq from nil)
- (setq lines 0)
- (setq date nil)
- (setq references nil)
- ;; Thanks go to mly@AI.MIT.EDU (Richard Mlynarik)
- (while (and (not (eobp))
- (not (memq (following-char) '(?2 ?3))))
- (if (looking-at "\\(From\\|Subject\\|Date\\|Lines\\|Xref\\|References\\):[ \t]+\\([^ \t\n]+.*\\)\r$")
- (let ((s (buffer-substring
- (match-beginning 2) (match-end 2)))
- (c (char-after (match-beginning 0))))
- ;; We don't have to worry about letter case.
- (cond ((char-equal c ?F) ;From:
- (setq from s))
- ((char-equal c ?S) ;Subject:
- (setq subject s))
- ((char-equal c ?D) ;Date:
- (setq date s))
- ((char-equal c ?L) ;Lines:
- (setq lines (string-to-int s)))
- ((char-equal c ?X) ;Xref:
- (setq xref s))
- ((char-equal c ?R) ;References:
- (setq references s))
- )))
- (forward-line 1))
- ;; Finished to parse one header.
- (if (null subject)
- (setq subject "(None)"))
- (if (null from)
- (setq from "(Unknown User)"))
- (setq headers
- (cons (vector article subject from
- xref lines date
- message-id references) headers))
- )
- (t (forward-line 1))
- )
- (setq received (1- received))
- (and (numberp nntp-large-newsgroup)
- (> number nntp-large-newsgroup)
- (zerop (% received 20))
- (message "NNTP: Parsing headers... %d%%"
- (/ (* received 100) number)))
- )
- (and (numberp nntp-large-newsgroup)
- (> number nntp-large-newsgroup)
- (message "NNTP: Parsing headers... done"))
- (nreverse headers)
- )))
-
-
-;;;
-;;; Raw Interface to Network News Transfer Protocol (RFC977).
-;;;
-
-(defun nntp-open-server (host &optional service)
- "Open news server on HOST.
-If HOST is nil, use value of environment variable `NNTPSERVER'.
-If optional argument SERVICE is non-nil, open by the service name."
- (let ((host (or host (getenv "NNTPSERVER")))
- (status nil))
- (setq nntp-status-message-string "")
- (cond ((and host (nntp-open-server-internal host service))
- (setq status (nntp-wait-for-response "^[23].*\r$"))
- ;; Do check unexpected close of connection.
- ;; Suggested by feldmark@hanako.stars.flab.fujitsu.junet.
- (if status
- (set-process-sentinel nntp-server-process
- 'nntp-default-sentinel)
- ;; We have to close connection here, since function
- ;; `nntp-server-opened' may return incorrect status.
- (nntp-close-server-internal)
- ))
- ((null host)
- (setq nntp-status-message-string "NNTP server is not specified."))
- )
- status
- ))
-
-(defun nntp-close-server ()
- "Close news server."
- (unwind-protect
- (progn
- ;; Un-set default sentinel function before closing connection.
- (and nntp-server-process
- (eq 'nntp-default-sentinel
- (process-sentinel nntp-server-process))
- (set-process-sentinel nntp-server-process nil))
- ;; We cannot send QUIT command unless the process is running.
- (if (nntp-server-opened)
- (nntp-send-command nil "QUIT"))
- )
- (nntp-close-server-internal)
- ))
-
-(fset 'nntp-request-quit (symbol-function 'nntp-close-server))
-
-(defun nntp-server-opened ()
- "Return server process status, T or NIL.
-If the stream is opened, return T, otherwise return NIL."
- (and nntp-server-process
- (memq (process-status nntp-server-process) '(open run))))
-
-(defun nntp-status-message ()
- "Return server status response as string."
- (if (and nntp-status-message-string
- ;; NNN MESSAGE
- (string-match "[0-9][0-9][0-9][ \t]+\\([^\r]*\\).*$"
- nntp-status-message-string))
- (substring nntp-status-message-string (match-beginning 1) (match-end 1))
- ;; Empty message if nothing.
- ""
- ))
-
-(defun nntp-request-article (id)
- "Select article by message ID (or number)."
- (prog1
- ;; If NEmacs, end of message may look like: "\256\215" (".^M")
- (nntp-send-command "^\\.\r$" "ARTICLE" id)
- (nntp-decode-text)
- ))
-
-(defun nntp-request-body (id)
- "Select article body by message ID (or number)."
- (prog1
- ;; If NEmacs, end of message may look like: "\256\215" (".^M")
- (nntp-send-command "^\\.\r$" "BODY" id)
- (nntp-decode-text)
- ))
-
-(defun nntp-request-head (id)
- "Select article head by message ID (or number)."
- (prog1
- (nntp-send-command "^\\.\r$" "HEAD" id)
- (nntp-decode-text)
- ))
-
-(defun nntp-request-stat (id)
- "Select article by message ID (or number)."
- (nntp-send-command "^[23].*\r$" "STAT" id))
-
-(defun nntp-request-group (group)
- "Select news GROUP."
- ;; 1.2a NNTP's group command is buggy. "^M" (\r) is not appended to
- ;; end of the status message.
- (nntp-send-command "^[23].*$" "GROUP" group))
-
-(defun nntp-request-list ()
- "List valid newsgoups."
- (prog1
- (nntp-send-command "^\\.\r$" "LIST")
- (nntp-decode-text)
- ))
-
-(defun nntp-request-last ()
- "Set current article pointer to the previous article in the current news group."
- (nntp-send-command "^[23].*\r$" "LAST"))
-
-(defun nntp-request-next ()
- "Advance current article pointer."
- (nntp-send-command "^[23].*\r$" "NEXT"))
-
-(defun nntp-request-post ()
- "Post a new news in current buffer."
- (if (nntp-send-command "^[23].*\r$" "POST")
- (progn
- (nntp-encode-text)
- (nntp-send-region-to-server (point-min) (point-max))
- ;; 1.2a NNTP's post command is buggy. "^M" (\r) is not
- ;; appended to end of the status message.
- (nntp-wait-for-response "^[23].*$")
- )))
-
-(defun nntp-default-sentinel (proc status)
- "Default sentinel function for NNTP server process."
- (if (and nntp-server-process
- (not (nntp-server-opened)))
- (error "NNTP: Connection closed.")
- ))
-
-;; Encoding and decoding of NNTP text.
-
-(defun nntp-decode-text ()
- "Decode text transmitted by NNTP.
-0. Delete status line.
-1. Delete `^M' at end of line.
-2. Delete `.' at end of buffer (end of text mark).
-3. Delete `.' at beginning of line."
- (save-excursion
- (set-buffer nntp-server-buffer)
- ;; Insert newline at end of buffer.
- (goto-char (point-max))
- (if (not (bolp))
- (insert "\n"))
- ;; Delete status line.
- (goto-char (point-min))
- (delete-region (point) (progn (forward-line 1) (point)))
- ;; Delete `^M' at end of line.
- ;; (replace-regexp "\r$" "")
- (while (not (eobp))
- (end-of-line)
- (if (= (preceding-char) ?\r)
- (delete-char -1))
- (forward-line 1)
- )
- ;; Delete `.' at end of buffer (end of text mark).
- (goto-char (point-max))
- (forward-line -1) ;(beginning-of-line)
- (if (looking-at "^\\.$")
- (delete-region (point) (progn (forward-line 1) (point))))
- ;; Replace `..' at beginning of line with `.'.
- (goto-char (point-min))
- ;; (replace-regexp "^\\.\\." ".")
- (while (search-forward "\n.." nil t)
- (delete-char -1))
- ))
-
-(defun nntp-encode-text ()
- "Encode text in current buffer for NNTP transmission.
-1. Insert `.' at beginning of line.
-2. Insert `.' at end of buffer (end of text mark)."
- (save-excursion
- ;; Insert newline at end of buffer.
- (goto-char (point-max))
- (if (not (bolp))
- (insert "\n"))
- ;; Replace `.' at beginning of line with `..'.
- (goto-char (point-min))
- ;; (replace-regexp "^\\." "..")
- (while (search-forward "\n." nil t)
- (insert "."))
- ;; Insert `.' at end of buffer (end of text mark).
- (goto-char (point-max))
- (insert ".\n")
- ))
-
-
-;;;
-;;; Synchronous Communication with NNTP Server.
-;;;
-
-(defun nntp-send-command (response cmd &rest args)
- "Wait for server RESPONSE after sending CMD and optional ARGS to server."
- (save-excursion
- ;; Clear communication buffer.
- (set-buffer nntp-server-buffer)
- (erase-buffer)
- (apply 'nntp-send-strings-to-server cmd args)
- (if response
- (nntp-wait-for-response response)
- t)
- ))
-
-(defun nntp-wait-for-response (regexp)
- "Wait for server response which matches REGEXP."
- (save-excursion
- (let ((status t)
- (wait t))
- (set-buffer nntp-server-buffer)
- ;; Wait for status response (RFC977).
- ;; 1xx - Informative message.
- ;; 2xx - Command ok.
- ;; 3xx - Command ok so far, send the rest of it.
- ;; 4xx - Command was correct, but couldn't be performed for some
- ;; reason.
- ;; 5xx - Command unimplemented, or incorrect, or a serious
- ;; program error occurred.
- (nntp-accept-response)
- (while wait
- (goto-char (point-min))
- (cond ((looking-at "[23]")
- (setq wait nil))
- ((looking-at "[45]")
- (setq status nil)
- (setq wait nil))
- (t (nntp-accept-response))
- ))
- ;; Save status message.
- (end-of-line)
- (setq nntp-status-message-string
- (buffer-substring (point-min) (point)))
- (if status
- (progn
- (setq wait t)
- (while wait
- (goto-char (point-max))
- (forward-line -1) ;(beginning-of-line)
- ;;(message (buffer-substring
- ;; (point)
- ;; (save-excursion (end-of-line) (point))))
- (if (looking-at regexp)
- (setq wait nil)
- (message "NNTP: Reading...")
- (nntp-accept-response)
- (message "")
- ))
- ;; Successfully received server response.
- t
- ))
- )))
-
-
-;;;
-;;; Low-Level Interface to NNTP Server.
-;;;
-
-(defun nntp-send-strings-to-server (&rest strings)
- "Send list of STRINGS to news server as command and its arguments."
- (let ((cmd (car strings))
- (strings (cdr strings)))
- ;; Command and each argument must be separeted by one or more spaces.
- (while strings
- (setq cmd (concat cmd " " (car strings)))
- (setq strings (cdr strings)))
- ;; Command line must be terminated by a CR-LF.
- (process-send-string nntp-server-process (concat cmd "\n"))
- ))
-
-(defun nntp-send-region-to-server (begin end)
- "Send current buffer region (from BEGIN to END) to news server."
- (save-excursion
- ;; We have to work in the buffer associated with NNTP server
- ;; process because of NEmacs hack.
- (copy-to-buffer nntp-server-buffer begin end)
- (set-buffer nntp-server-buffer)
- (setq begin (point-min))
- (setq end (point-max))
- ;; `process-send-region' does not work if text to be sent is very
- ;; large. I don't know maximum size of text sent correctly.
- (let ((last nil)
- (size 100)) ;Size of text sent at once.
- (save-restriction
- (narrow-to-region begin end)
- (goto-char begin)
- (while (not (eobp))
- ;;(setq last (min end (+ (point) size)))
- ;; NEmacs gets confused if character at `last' is Kanji.
- (setq last (save-excursion
- (goto-char (min end (+ (point) size)))
- (or (eobp) (forward-char 1)) ;Adjust point
- (point)))
- (process-send-region nntp-server-process (point) last)
- ;; I don't know whether the next codes solve the known
- ;; problem of communication error of GNU Emacs.
- (accept-process-output)
- ;;(sit-for 0)
- (goto-char last)
- )))
- ;; We cannot erase buffer, because reply may be received.
- (delete-region begin end)
- ))
-
-(defun nntp-open-server-internal (host &optional service)
- "Open connection to news server on HOST by SERVICE (default is nntp)."
- (save-excursion
- ;; Use TCP/IP stream emulation package if needed.
- (or (fboundp 'open-network-stream)
- (require 'tcp))
- ;; Initialize communication buffer.
- (setq nntp-server-buffer (get-buffer-create " *nntpd*"))
- (set-buffer nntp-server-buffer)
- (buffer-flush-undo (current-buffer))
- (erase-buffer)
- (kill-all-local-variables)
- (setq case-fold-search t) ;Should ignore case.
- (setq nntp-server-process
- (open-network-stream "nntpd" (current-buffer)
- host (or service "nntp")))
- (setq nntp-server-name host)
- ;; It is possible to change kanji-fileio-code in this hook.
- (run-hooks 'nntp-server-hook)
- ;; Return the server process.
- nntp-server-process
- ))
-
-(defun nntp-close-server-internal ()
- "Close connection to news server."
- (if nntp-server-process
- (delete-process nntp-server-process))
- (if nntp-server-buffer
- (kill-buffer nntp-server-buffer))
- (setq nntp-server-buffer nil)
- (setq nntp-server-process nil))
-
-(defun nntp-accept-response ()
- "Read response of server.
-It is well-known that the communication speed will be much improved by
-defining this function as macro."
- ;; To deal with server process exiting before
- ;; accept-process-output is called.
- ;; Suggested by Jason Venner <jason@violet.berkeley.edu>.
- ;; This is a copy of `nntp-default-sentinel'.
- (or (memq (process-status nntp-server-process) '(open run))
- (error "NNTP: Connection closed."))
- (if nntp-buggy-select
- (progn
- ;; We cannot use `accept-process-output'.
- ;; Fujitsu UTS requires messages during sleep-for. I don't know why.
- (message "NNTP: Reading...")
- (sleep-for 1)
- (message ""))
- (condition-case errorcode
- (accept-process-output nntp-server-process)
- (error
- (cond ((string-equal "select error: Invalid argument" (nth 1 errorcode))
- ;; Ignore select error.
- nil
- )
- (t
- (signal (car errorcode) (cdr errorcode))))
- ))
- ))
diff --git a/lisp/textmodes/nroff-mode.el b/lisp/nroff-mode.el
index 35bf4213615..16e1445080b 100644
--- a/lisp/textmodes/nroff-mode.el
+++ b/lisp/nroff-mode.el
@@ -23,7 +23,7 @@
"Abbrev table used while in nroff mode.")
(defvar nroff-mode-map nil
- "Major mode keymap for nroff mode.")
+ "Major mode keymap for nroff-mode buffers")
(if (not nroff-mode-map)
(progn
(setq nroff-mode-map (make-sparse-keymap))
@@ -37,8 +37,8 @@
(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
+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)
@@ -165,7 +165,7 @@ An argument is a repeat count; negative means move forward."
(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,
+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
@@ -185,11 +185,12 @@ automatically inserts the matching closing request after point."
(forward-char 1))))
(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."
+ "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"))
(or (assq 'nroff-electric-mode minor-mode-alist)
diff --git a/lisp/nroff-mode.elc b/lisp/nroff-mode.elc
new file mode 100644
index 00000000000..7f76aeec9c2
--- /dev/null
+++ b/lisp/nroff-mode.elc
Binary files differ
diff --git a/lisp/options.el b/lisp/options.el
index e67346cab63..59d89c84bf3 100644
--- a/lisp/options.el
+++ b/lisp/options.el
@@ -67,17 +67,14 @@ Type \\[describe-mode] in that buffer for a list of commands."
(put 'Edit-options-mode 'mode-class 'special)
(defun Edit-options-mode ()
- "\\<Edit-options-mode-map>\
-Major mode for editing Emacs user option settings.
+ "Major mode for editing Emacs user option settings.
Special commands are:
-\\[Edit-options-set] -- set variable point points at. New value read using minibuffer.
-\\[Edit-options-toggle] -- toggle variable, t -> nil, nil -> t.
-\\[Edit-options-t] -- set variable to t.
-\\[Edit-options-nil] -- set variable to nil.
-Changed values made by these commands take effect immediately.
-
+s -- set variable point points at. New value read using minibuffer.
+x -- toggle variable, t -> nil, nil -> t.
+1 -- set variable to t.
+0 -- set variable to nil.
Each variable description is a paragraph.
-For convenience, the characters \\[backward-paragraph] and \\[forward-paragraph] move back and forward by paragraphs."
+For convenience, the characters p and n move back and forward by paragraphs."
(kill-all-local-variables)
(set-syntax-table emacs-lisp-mode-syntax-table)
(use-local-map Edit-options-mode-map)
@@ -87,8 +84,7 @@ For convenience, the characters \\[backward-paragraph] and \\[forward-paragraph]
(setq paragraph-start "^\t")
(setq truncate-lines t)
(setq major-mode 'Edit-options-mode)
- (setq mode-name "Options")
- (run-hooks 'Edit-options-mode-hook))
+ (setq mode-name "Options"))
(defun Edit-options-set () (interactive)
(Edit-options-modify
@@ -106,18 +102,18 @@ For convenience, the characters \\[backward-paragraph] and \\[forward-paragraph]
(defun Edit-options-modify (modfun)
(save-excursion
(let (var pos)
- (re-search-backward "^;; \\|\\`")
+ (re-search-backward "^;; ")
(forward-char 3)
(setq pos (point))
(save-restriction
- (narrow-to-region pos (progn (end-of-line) (1- (point))))
- (goto-char pos)
- (setq var (read (current-buffer))))
+ (narrow-to-region pos (progn (end-of-line) (1- (point))))
+ (goto-char pos)
+ (setq var (read (current-buffer))))
(goto-char pos)
(forward-line 1)
(forward-char 1)
(save-excursion
- (set var (funcall modfun var)))
+ (set var (funcall modfun var)))
(kill-sexp 1)
(prin1 (symbol-value var) (current-buffer)))))
diff --git a/lisp/options.elc b/lisp/options.elc
new file mode 100644
index 00000000000..67659cf3bd7
--- /dev/null
+++ b/lisp/options.elc
Binary files differ
diff --git a/lisp/textmodes/ooutline.el b/lisp/outline.el
index c56a3eb10c6..974895a38cb 100644
--- a/lisp/textmodes/ooutline.el
+++ b/lisp/outline.el
@@ -20,23 +20,16 @@
;; Jan '86, Some new features added by Peter Desnoyers and rewritten by RMS.
(defvar outline-regexp "[*\^l]+"
- "*Regular expression to match the beginning of a heading.
-Any line whose beginning matches this regexp is considered to start a heading.
+ "*Regular expression to match the beginning of a heading line.
+Any line whose beginning matches this regexp is considered 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.")
-
-(defvar outline-heading-end-regexp "[\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.")
(defvar outline-mode-map nil "")
(if outline-mode-map
nil
- (setq outline-mode-map (nconc (make-sparse-keymap) text-mode-map))
+ (setq outline-mode-map (copy-keymap text-mode-map))
(define-key outline-mode-map "\C-c\C-n" 'outline-next-visible-heading)
(define-key outline-mode-map "\C-c\C-p" 'outline-previous-visible-heading)
(define-key outline-mode-map "\C-c\C-i" 'show-children)
@@ -46,11 +39,6 @@ in the file it applies to.")
(define-key outline-mode-map "\C-c\C-f" 'outline-forward-same-level)
(define-key outline-mode-map "\C-c\C-b" 'outline-backward-same-level))
-(defvar outline-minor-mode nil
- "Non-nil if using Outline mode as a minor mode of some other mode.")
-(setq minor-mode-alist (append minor-mode-alist
- (list '(outline-minor-mode " Outl"))))
-
(defun outline-mode ()
"Set major mode for editing outlines with selective display.
Headings are lines which start with asterisks: one for major headings,
@@ -61,21 +49,21 @@ 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-mode-map>
-\\[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
+Commands:
+C-c C-n outline-next-visible-heading move by visible headings
+C-c C-p outline-previous-visible-heading
+C-c C-f outline-forward-same-level similar but skip subheadings
+C-c C-b outline-backward-same-level
+C-c C-u outline-up-heading move from subheading to heading
-M-x hide-body make all text invisible (not headings).
-M-x show-all make everything in buffer visible.
+Meta-x hide-body make all text invisible (not headings).
+Meta-x 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.
+C-c C-h hide-subtree make body and subheadings invisible.
+C-c C-s show-subtree make body and subheadings visible.
+C-c C-i 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.
M-x hide-entry make immediately following body invisible.
@@ -84,12 +72,12 @@ M-x hide-leaves make body under heading and under its subheadings invisible.
The subheadings remain visible.
M-x 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
+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."
+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)
@@ -102,44 +90,18 @@ Turning on outline mode calls the value of `text-mode-hook' and then of
(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 "\\)"))
(run-hooks 'text-mode-hook 'outline-mode-hook))
-
-(defun outline-minor-mode (arg)
- (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)
- (make-local-variable 'outline-old-map)
- (setq outline-old-map (current-local-map))
- (let ((new-map (copy-keymap outline-old-map)))
- (define-key new-map "\C-c"
- (lookup-key outline-mode-map "\C-c"))
- (use-local-map new-map))
- (make-local-variable 'outline-regexp)
- (setq outline-regexp "[ \t]*/\\*")
- (make-local-variable 'outline-heading-end-regexp)
- (setq outline-heading-end-regexp "\\*/[^\n\^M]*[\n\^M]")
- (run-hooks 'outline-minor-mode-hook))
- (progn
- (setq selective-display nil)
- (use-local-map outline-old-map))))
(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 column number of the end of what `outline-regexp matches'."
+Point must be at the beginning of a header line.
+This is actually the length of whatever outline-regexp matches."
(save-excursion
(looking-at outline-regexp)
- (save-excursion (goto-char (match-end 0)) (current-column))))
+ (- (match-end 0) (match-beginning 0))))
(defun outline-next-preface ()
"Skip forward to just before the next heading line."
@@ -158,7 +120,7 @@ the column number of the end of what `outline-regexp matches'."
(defun outline-back-to-heading ()
"Move to previous (possibly invisible) heading line,
-or to the beginning of this line if it is a heading line."
+or to beginning of this line if it is a heading line."
(beginning-of-line)
(or (outline-on-heading-p)
(re-search-backward (concat "^\\(" outline-regexp "\\)") nil 'move)))
@@ -170,15 +132,10 @@ or to the beginning of this line if it is a heading line."
(and (eq (preceding-char) ?\n)
(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)."
+A heading line is one that starts with a `*' (or that outline-regexp matches)."
(interactive "p")
(if (< arg 0)
(beginning-of-line)
@@ -189,8 +146,7 @@ A heading line is one that starts with a `*' (or that
(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)."
+A heading line is one that starts with a `*' (or that outline-regexp matches)."
(interactive "p")
(outline-next-visible-heading (- arg)))
@@ -202,14 +158,13 @@ while if FLAG is `\\^M' (control-M) the text is hidden."
(unwind-protect
(subst-char-in-region from to
(if (= flag ?\n) ?\^M ?\n)
- flag)
+ flag t)
(set-buffer-modified-p modp))))
(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)))
@@ -230,17 +185,12 @@ while if FLAG is `\\^M' (control-M) the text is hidden."
(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)
+ (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)))))))
+ (forward-char
+ (if (looking-at "[\n\^M][\n\^M]")
+ 2 1)))))))
(defun show-all ()
"Show all of the text in the buffer."
@@ -256,7 +206,6 @@ while if FLAG is `\\^M' (control-M) the text is hidden."
"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 ()
@@ -267,13 +216,12 @@ while if FLAG is `\\^M' (control-M) the text is hidden."
(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)
+ (beginning-of-line)
(let ((opoint (point))
(first t)
(level (outline-level)))
@@ -291,17 +239,10 @@ while if FLAG is `\\^M' (control-M) the text is hidden."
(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
- (beginning-of-line)
- (let ((start-level (outline-level)))
- (outline-next-heading)
- (max 1 (- (outline-level) start-level))))))
+ "Show all direct subheadings of this heading. Optional LEVEL specifies
+how many levels below the current level should be shown."
+ (interactive "p")
+ (or level (setq level 1))
(save-excursion
(save-restriction
(beginning-of-line)
@@ -315,13 +256,11 @@ Default is enough to cause the following heading to appear."
(not (eobp))))
(if (<= (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)))))))
+ (let ((end (1+ (point))))
+ (forward-char -1)
+ (if (memq (preceding-char) '(?\n ?\^M))
+ (forward-char -1))
+ (outline-flag-region (point) end ?\n))))))))
(defun outline-up-heading (arg)
"Move to the heading line of which the present line is a subheading.
diff --git a/lisp/outline.elc b/lisp/outline.elc
new file mode 100644
index 00000000000..64e9272d0ea
--- /dev/null
+++ b/lisp/outline.elc
Binary files differ
diff --git a/lisp/textmodes/page.el b/lisp/page.el
index 576e23a7560..19b29d02f08 100644
--- a/lisp/textmodes/page.el
+++ b/lisp/page.el
@@ -20,8 +20,7 @@
(defun forward-page (&optional count)
"Move forward to page boundary. With arg, repeat, or go back if negative.
-A page boundary is any line whose beginning matches the regexp
-`page-delimiter'."
+A page boundary is any line whose beginning matches the regexp page-delimiter."
(interactive "p")
(or count (setq count 1))
(while (and (> count 0) (not (eobp)))
@@ -38,8 +37,7 @@ A page boundary is any line whose beginning matches the regexp
(defun backward-page (&optional count)
"Move backward to page boundary. With arg, repeat, or go fwd if negative.
-A page boundary is any line whose beginning matches the regexp
-`page-delimiter'."
+A page boundary is any line whose beginning matches the regexp page-delimiter."
(interactive "p")
(or count (setq count 1))
(forward-page (- count)))
diff --git a/lisp/page.elc b/lisp/page.elc
new file mode 100644
index 00000000000..22867f35278
--- /dev/null
+++ b/lisp/page.elc
Binary files differ
diff --git a/lisp/textmodes/paragraphs.el b/lisp/paragraphs.el
index 748a08e986a..cb6c25955fe 100644
--- a/lisp/textmodes/paragraphs.el
+++ b/lisp/paragraphs.el
@@ -19,15 +19,13 @@
(defvar paragraph-ignore-fill-prefix nil
- "Non-nil means the paragraph commands are not affected by `fill-prefix'.
+ "Non-nil means the paragraph commands are not affected by fill-prefix.
This is desirable in modes where blank lines are the paragraph delimiters.")
(defun forward-paragraph (&optional arg)
- "Move forward to end of paragraph.
-With arg N, do it N times; negative arg -N means move forward N paragraphs.
-
-A line which `paragraph-start' matches either separates paragraphs
-\(if `paragraph-separate' matches it also) or is the first line of a paragraph.
+ "Move forward to end of paragraph. With arg, do it arg times.
+A line which paragraph-start matches either separates paragraphs
+\(if paragraph-separate matches it also) or is the first line of a paragraph.
A paragraph end is the beginning of a line which is not part of the paragraph
to which the end of the previous line belongs, or the end of the buffer."
(interactive "p")
@@ -86,40 +84,31 @@ to which the end of the previous line belongs, or the end of the buffer."
(setq arg (1- arg)))))
(defun backward-paragraph (&optional arg)
- "Move backward to start of paragraph.
-With arg N, do it N times; negative arg -N means move forward N paragraphs.
-
-A paragraph start is the beginning of a line which is a
-`first-line-of-paragraph' or which is ordinary text and follows a
-paragraph-separating line; except: if the first real line of a
-paragraph is preceded by a blank line, the paragraph starts at that
-blank line.
-
-See `forward-paragraph' for more information."
+ "Move backward to start of paragraph. With arg, do it arg times.
+A paragraph start is the beginning of a line which is a first-line-of-paragraph
+or which is ordinary text and follows a paragraph-separating line; except:
+if the first real line of a paragraph is preceded by a blank line,
+the paragraph starts at that blank line.
+See forward-paragraph for more information."
(interactive "p")
(or arg (setq arg 1))
(forward-paragraph (- arg)))
(defun mark-paragraph ()
- "Put point at beginning of this paragraph, mark at end.
-The paragraph marked is the one that contains point or follows point."
+ "Put point at beginning of this paragraph, mark at end."
(interactive)
(forward-paragraph 1)
(push-mark nil t)
(backward-paragraph 1))
(defun kill-paragraph (arg)
- "Kill forward to end of paragraph.
-With arg N, kill forward to Nth end of paragraph;
-negative arg -N means kill backward to Nth start of paragraph."
- (interactive "p")
+ "Kill to end of paragraph."
+ (interactive "*p")
(kill-region (point) (progn (forward-paragraph arg) (point))))
(defun backward-kill-paragraph (arg)
- "Kill back to start of paragraph.
-With arg N, kill back to Nth start of paragraph;
-negative arg -N means kill forward to Nth end of paragraph."
- (interactive "p")
+ "Kill back to start of paragraph."
+ (interactive "*p")
(kill-region (point) (progn (backward-paragraph arg) (point))))
(defun transpose-paragraphs (arg)
@@ -153,11 +142,11 @@ negative arg -N means kill forward to Nth end of paragraph."
(end-of-paragraph-text))))))
(defun forward-sentence (&optional arg)
- "Move forward to next`sentence-end'. With argument, repeat.
-With negative argument, move backward repeatedly to `sentence-beginning'.
-
-The variable `sentence-end' is a regular expression that matches ends of
-sentences. Also, every paragraph boundary terminates sentences as well."
+ "Move forward to next sentence-end. With argument, repeat.
+With negative argument, move backward repeatedly to sentence-beginning.
+Sentence ends are identified by the value of sentence-end
+treated as a regular expression. Also, every paragraph boundary
+terminates sentences as well."
(interactive "p")
(or arg (setq arg 1))
(while (< arg 0)
@@ -175,14 +164,14 @@ sentences. Also, every paragraph boundary terminates sentences as well."
(defun backward-sentence (&optional arg)
"Move backward to start of sentence. With arg, do it arg times.
-See `forward-sentence' for more information."
+See forward-sentence for more information."
(interactive "p")
(or arg (setq arg 1))
(forward-sentence (- arg)))
(defun kill-sentence (&optional arg)
"Kill from point to end of sentence.
-With arg, repeat; negative arg -N means kill back to Nth start of sentence."
+With arg, repeat, or backward if negative arg."
(interactive "*p")
(let ((beg (point)))
(forward-sentence arg)
@@ -190,14 +179,14 @@ With arg, repeat; negative arg -N means kill back to Nth start of sentence."
(defun backward-kill-sentence (&optional arg)
"Kill back from point to start of sentence.
-With arg, repeat, or kill forward to Nth end of sentence if negative arg -N."
+With arg, repeat, or forward if negative arg."
(interactive "*p")
(let ((beg (point)))
(backward-sentence arg)
(kill-region beg (point))))
(defun mark-end-of-sentence (arg)
- "Put mark at end of sentence. Arg works as in `forward-sentence'."
+ "Put mark at end of sentence. Arg works as in forward-sentence."
(interactive "p")
(push-mark
(save-excursion
diff --git a/lisp/paragraphs.elc b/lisp/paragraphs.elc
new file mode 100644
index 00000000000..ee1d8ded85c
--- /dev/null
+++ b/lisp/paragraphs.elc
Binary files differ
diff --git a/lisp/paths.el b/lisp/paths.el
index 66391e31898..2442bf0f2e8 100644
--- a/lisp/paths.el
+++ b/lisp/paths.el
@@ -24,14 +24,10 @@
;; If these settings are not right, override them with `setq'
;; in site-init.el. Do not change this file.
-(defvar Info-directory-list
- (list "/usr/local/lib/info/"
- (expand-file-name "../info/" exec-directory))
- "List of directories to search for Info documentation files.")
+(defvar Info-directory (expand-file-name "../info/" exec-directory))
(defvar news-path "/usr/spool/news/"
"The root directory below which all news files are stored.")
-
(defvar news-inews-program
(cond ((file-exists-p "/usr/bin/inews") "/usr/bin/inews")
((file-exists-p "/usr/local/inews") "/usr/local/inews")
@@ -40,50 +36,27 @@
(t "inews"))
"Program to post news.")
-(defvar gnus-default-nntp-server ""
- ;; set this to your local server
- "The name of the host running an NNTP server.
-If it is a string such as \":DIRECTORY\", then ~/DIRECTORY
-is used as a news spool. `gnus-nntp-server' is initialised from NNTPSERVER
-environment variable or, if none, this value.")
-
-(defvar gnus-nntp-service "nntp"
- "NNTP service name, usually \"nntp\" or 119).
-Go to a local news spool if its value is nil, in which case `gnus-nntp-server'
-should be set to `(system-name)'.")
-
-(defvar gnus-your-domain nil
- "Your domain name without your host name like: \"stars.flab.Fujitsu.CO.JP\"
-The DOMAINNAME environment variable is used instead if defined. If
-the function `system-name' returns a fully qualified domain name, there is no
-need to define the name.")
-
-(defvar gnus-your-organization ""
- "Your organization like: \"Fujitsu Laboratories Ltd., Kawasaki, Japan.\"
-The `ORGANIZATION' environment variable is used instead if defined.")
-
(defvar mh-progs
- (cond ((file-directory-p "/usr/new/mh") "/usr/new/mh/")
- ((file-directory-p "/usr/local/bin/mh") "/usr/local/bin/mh/")
- ((file-directory-p "/usr/local/mh/") "/usr/local/mh/")
- (t "/usr/local/bin/"))
- "Directory containing MH commands")
+ (cond ((file-directory-p "/usr/bin/mh/") "/usr/bin/mh/") ;Ultrix 4.2
+ ((file-directory-p "/usr/new/mh/") "/usr/new/mh/") ;Ultrix <4.2
+ ((file-directory-p "/usr/local/bin/mh/") "/usr/local/bin/mh/")
+ ((file-directory-p "/usr/local/mh/") "/usr/local/mh/")
+ (t "/usr/local/bin/"))
+ "Directory containing MH commands.")
(defvar mh-lib
- (cond ((file-directory-p "/usr/new/lib/mh") "/usr/new/lib/mh/")
- ((file-directory-p "/usr/local/lib/mh") "/usr/local/lib/mh/")
- (t "/usr/local/bin/mh/"))
- "Directory of MH library")
+ (cond ((file-directory-p "/usr/lib/mh/") "/usr/lib/mh/") ;Ultrix 4.2
+ ((file-directory-p "/usr/new/lib/mh/") "/usr/new/lib/mh/") ;Ultrix <4.2
+ ((file-directory-p "/usr/local/lib/mh/") "/usr/local/lib/mh/")
+ (t "/usr/local/bin/mh/"))
+ "Directory of MH library.")
-(defvar rmail-file-name "~/RMAIL"
+(defconst rmail-file-name "~/RMAIL"
"Name of user's primary mail file.")
-(defvar gnus-startup-file "~/.newsrc"
- "The file listing groups to which user is subscribed.
-Will use `gnus-startup-file'-SERVER instead if exists.")
-
(defconst rmail-spool-directory
- (if (memq system-type '(hpux usg-unix-v unisoft-unix rtu irix))
+ (if (memq system-type '(hpux usg-unix-v unisoft-unix rtu
+ silicon-graphics-unix))
"/usr/mail/"
"/usr/spool/mail/")
"Name of directory used by system mailer for delivering new mail.
@@ -131,18 +104,6 @@ Append a section-number or section-name to get a directory name.")
'("/usr/man/cat.C" "/usr/man/cat.CP" "/usr/man/cat.CT"
"/usr/man/cat.DOS/" "/usr/man/cat.F" "/usr/man/cat.HW"
"/usr/man/cat.M/" "/usr/man/cat.S" "/usr/man/cat.LOCAL"))
- ((file-exists-p "/usr/man/cat3/cat3")
- ;; This is for UMAX.
- '("/usr/man/cat1" "/usr/man/cat2"
- "/usr/man/cat3" "/usr/man/cat3/cat3"
- "/usr/man/cat3/cat3b" "/usr/man/cat3/cat3c"
- "/usr/man/cat3/cat3f" "/usr/man/cat3/cat3m"
- "/usr/man/cat3/cat3n" "/usr/man/cat3/cat3p"
- "/usr/man/cat3/cat3s" "/usr/man/cat3/cat3u"
- "/usr/man/cat3/cat3x" "/usr/man/cat4"
- "/usr/man/cat5" "/usr/man/cat6"
- "/usr/man/cat7" "/usr/man/cat8"
- "/usr/man/catl" "/usr/man/catn"))
((file-exists-p "/usr/man/cat1")
'("/usr/man/cat1" "/usr/man/cat2" "/usr/man/cat3"
"/usr/man/cat4" "/usr/man/cat5" "/usr/man/cat6"
@@ -152,12 +113,7 @@ Append a section-number or section-name to get a directory name.")
"/usr/catman/p_man/man2" "/usr/catman/p_man/man3"
"/usr/catman/p_man/man4" "/usr/catman/p_man/man5"
"/usr/catman/a_man/man1" "/usr/catman/a_man/man7"
- "/usr/catman/a_man/man8" "/usr/catman/local"
- "/usr/catman/a_man/man8" "/usr/catman/local/man1"
- "/usr/catman/local/man2" "/usr/catman/local/man3"
- "/usr/catman/local/man4" "/usr/catman/local/man5"
- "/usr/catman/local/man6" "/usr/catman/local/man7"
- "/usr/catman/local/man8")))
+ "/usr/catman/a_man/man8" "/usr/catman/local")))
"List of directories containing formatted manual pages.")
(defconst abbrev-file-name
diff --git a/lisp/textmodes/picture.el b/lisp/picture.el
index d6915c4b0ae..c0325003e73 100644
--- a/lisp/textmodes/picture.el
+++ b/lisp/picture.el
@@ -23,7 +23,7 @@
(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
+Differs from move-to-column in that it creates or modifies whitespace
if necessary to attain exactly the specified column."
(move-to-column column)
(let ((col (current-column)))
@@ -135,7 +135,7 @@ The mode line is updated to reflect the current direction."
(message ""))
(defun picture-move ()
- "Move in direction of `picture-vertical-step' and `picture-horizontal-step'."
+ "Move in direction of picture-vertical-step and picture-horizontal-step."
(picture-move-down picture-vertical-step)
(picture-forward-column picture-horizontal-step))
@@ -152,7 +152,7 @@ Do \\[command-apropos] picture-movement to see commands which control motion."
"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."
+Do \\[command-apropos] picture-movement to see commands which control motion."
(interactive "p")
(picture-motion (- arg)))
@@ -162,8 +162,8 @@ Do \\[command-apropos] `picture-movement' to see commands which control motion."
(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."
+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))
@@ -191,9 +191,9 @@ Do \\[command-apropos] `picture-movement' to see those commands."
(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."
+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
@@ -247,7 +247,7 @@ It defines a set of \"interesting characters\" to look for when setting
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
+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
: : : :
@@ -264,13 +264,14 @@ 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."
+ "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)
@@ -297,7 +298,7 @@ stops computed are displayed in the minibuffer with `:' at each stop."
"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'.
+\"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)))
@@ -321,18 +322,20 @@ If no such character is found, move to beginning of line."
(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
+ "Tab transparently (move) to next tab stop.
+With 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'."
+See also documentation for variable picture-tab-chars."
(interactive "P")
- (let* ((opoint (point)))
- (move-to-tab-stop)
+ (let* ((opoint (point))
+ (target (prog2 (tab-to-tab-stop)
+ (current-column)
+ (delete-region opoint (point)))))
+ (move-to-column-force target)
(if arg
- (let (indent-tabs-mode
- (column (current-column)))
+ (let (indent-tabs-mode)
(delete-region opoint (point))
- (indent-to column)))))
+ (indent-to target)))))
;; Picture Rectangles
@@ -343,27 +346,40 @@ 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."
+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."
+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))
+ (indent-tabs-mode nil)
+ markpos oldmark)
(prog1 (save-excursion
+ (save-excursion
+ (goto-char (setq oldmark (mark)))
+ (setq markpos (current-column)))
(if killp
(delete-extract-rectangle start end)
(prog1 (extract-rectangle start end)
- (clear-rectangle start end))))
- (move-to-column-force column))))
+ (clear-rectangle start end t))))
+ (move-to-column-force column)
+ ;; Make the mark point at the same column
+ ;; as it did before.
+ (set-marker (mark-marker)
+ (save-excursion
+ (goto-char oldmark)
+ (move-to-column-force markpos)
+ (point))))))
(defun picture-yank-rectangle (&optional insertp)
"Overlay rectangle saved by \\[picture-clear-rectangle]
@@ -526,7 +542,7 @@ they are not defaultly assigned to keys."
(make-local-variable 'picture-vertical-step)
(make-local-variable 'picture-horizontal-step)
(picture-set-motion 0 1)
- (run-hooks 'edit-picture-hook)
+ (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.")
diff --git a/lisp/picture.elc b/lisp/picture.elc
new file mode 100644
index 00000000000..f8bfa4b8e2a
--- /dev/null
+++ b/lisp/picture.elc
Binary files differ
diff --git a/lisp/play/gomoku.el b/lisp/play/gomoku.el
deleted file mode 100644
index c40c108895f..00000000000
--- a/lisp/play/gomoku.el
+++ /dev/null
@@ -1,1161 +0,0 @@
-;; Gomoku game between you and Emacs
-;; Copyright (C) 1988 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;;; Gomoku game between you and GNU Emacs. Last modified on 13 Sep 1988
-;;;
-;;; Written by Ph. Schnoebelen (phs@lifia.imag.fr), 1987, 1988
-;;; with precious advices from J.-F. Rit.
-;;; This has been tested with GNU Emacs 18.50.
-
-(provide 'gomoku)
-
-
-;; RULES:
-;;
-;; Gomoku is a game played between two players on a rectangular board. Each
-;; player, in turn, marks a free square of its choice. The winner is the first
-;; one to mark five contiguous squares in any direction (horizontally,
-;; vertically or diagonally).
-;;
-;; I have been told that, in "The TRUE Gomoku", some restrictions are made
-;; about the squares where one may play, or else there is a known forced win
-;; for the first player. This program has no such restriction, but it does not
-;; know about the forced win, nor do I. Furthermore, you probably do not know
-;; it yourself :-).
-
-
-;; HOW TO INSTALL:
-;;
-;; There is nothing specific w.r.t. installation: just put this file in the
-;; lisp directory and add an autoload for command gomoku in site-init.el. If
-;; you don't want to rebuild Emacs, then every single user interested in
-;; Gomoku will have to put the autoload command in its .emacs file. Another
-;; possibility is to define in your .emacs some command using (require
-;; 'gomoku).
-;;
-;; The most important thing is to BYTE-COMPILE gomoku.el because it is
-;; important that the code be as fast as possible.
-;;
-;; There are two main places where you may want to customize the program: key
-;; bindings and board display. These features are commented in the code. Go
-;; and see.
-
-
-;; HOW TO USE:
-;;
-;; Once this file has been installed, the command "M-x gomoku" will display a
-;; board, the size of which depends on the size of the current window. The
-;; size of the board is easily modified by giving numeric arguments to the
-;; gomoku command and/or by customizing the displaying parameters.
-;;
-;; Emacs plays when it is its turn. When it is your turn, just put the cursor
-;; on the square where you want to play and hit RET, or X, or whatever key you
-;; bind to the command gomoku-human-plays. When it is your turn, Emacs is
-;; idle: you may switch buffers, read your mail, ... Just come back to the
-;; *Gomoku* buffer and resume play.
-
-
-;; ALGORITHM:
-;;
-;; The algorithm is briefly described in section "THE SCORE TABLE". Some
-;; parameters may be modified if you want to change the style exhibited by the
-;; program.
-
-;;;
-;;; GOMOKU MODE AND KEYMAP.
-;;;
-(defvar gomoku-mode-hook nil
- "If non-nil, its value is called on entry to Gomoku mode.")
-
-(defvar gomoku-mode-map nil
- "Local keymap to use in Gomoku mode.")
-
-(if gomoku-mode-map nil
- (setq gomoku-mode-map (make-sparse-keymap))
-
- ;; Key bindings for cursor motion. Arrow keys are just "function"
- ;; keys, see below.
- (define-key gomoku-mode-map "y" 'gomoku-move-nw) ; Y
- (define-key gomoku-mode-map "u" 'gomoku-move-ne) ; U
- (define-key gomoku-mode-map "b" 'gomoku-move-sw) ; B
- (define-key gomoku-mode-map "n" 'gomoku-move-se) ; N
- (define-key gomoku-mode-map "h" 'gomoku-move-left) ; H
- (define-key gomoku-mode-map "l" 'gomoku-move-right) ; L
- (define-key gomoku-mode-map "j" 'gomoku-move-down) ; J
- (define-key gomoku-mode-map "k" 'gomoku-move-up) ; K
- (define-key gomoku-mode-map "\C-n" 'gomoku-move-down) ; C-N
- (define-key gomoku-mode-map "\C-p" 'gomoku-move-up) ; C-P
- (define-key gomoku-mode-map "\C-f" 'gomoku-move-right) ; C-F
- (define-key gomoku-mode-map "\C-b" 'gomoku-move-left) ; C-B
-
- ;; Key bindings for entering Human moves.
- ;; If you have a mouse, you may also bind some mouse click ...
- (define-key gomoku-mode-map "X" 'gomoku-human-plays) ; X
- (define-key gomoku-mode-map "x" 'gomoku-human-plays) ; x
- (define-key gomoku-mode-map "\C-m" 'gomoku-human-plays) ; RET
- (define-key gomoku-mode-map "\C-cp" 'gomoku-human-plays) ; C-C P
- (define-key gomoku-mode-map "\C-cb" 'gomoku-human-takes-back) ; C-C B
- (define-key gomoku-mode-map "\C-cr" 'gomoku-human-resigns) ; C-C R
- (define-key gomoku-mode-map "\C-ce" 'gomoku-emacs-plays) ; C-C E
-
- ;; Key bindings for "function" keys. If your terminal has such
- ;; keys, make sure they are declared through the function-keymap
- ;; keymap (see file keypad.el).
- ;; One problem with keypad.el is that the function-key-sequence
- ;; function is really slow, so slow that you may want to comment out
- ;; the following lines ...
- (if (featurep 'keypad)
- (let (keys)
- (if (setq keys (function-key-sequence ?u)) ; Up Arrow
- (define-key gomoku-mode-map keys 'gomoku-move-up))
- (if (setq keys (function-key-sequence ?d)) ; Down Arrow
- (define-key gomoku-mode-map keys 'gomoku-move-down))
- (if (setq keys (function-key-sequence ?l)) ; Left Arrow
- (define-key gomoku-mode-map keys 'gomoku-move-left))
- (if (setq keys (function-key-sequence ?r)) ; Right Arrow
- (define-key gomoku-mode-map keys 'gomoku-move-right))
-;; (if (setq keys (function-key-sequence ?e)) ; Enter
-;; (define-key gomoku-mode-map keys 'gomoku-human-plays))
-;; (if (setq keys (function-key-sequence ?I)) ; Insert
-;; (define-key gomoku-mode-map keys 'gomoku-human-plays))
- )))
-
-
-
-(defun gomoku-mode ()
- "Major mode for playing Gomoku against Emacs.
-You and Emacs play in turn by marking a free square. You mark it with X
-and Emacs marks it with O. The winner is the first to get five contiguous
-marks horizontally, vertically or in diagonal.
-
-You play by moving the cursor over the square you choose and hitting \\[gomoku-human-plays].
-
-Other useful commands:
-\\{gomoku-mode-map}
-Entry to this mode calls the value of `gomoku-mode-hook' if that value
-is non-nil."
- (interactive)
- (setq major-mode 'gomoku-mode
- mode-name "Gomoku")
- (gomoku-display-statistics)
- (use-local-map gomoku-mode-map)
- (run-hooks 'gomoku-mode-hook))
-
-;;;
-;;; THE BOARD.
-;;;
-
-;; The board is a rectangular grid. We code empty squares with 0, X's with 1
-;; and O's with 6. The rectangle is recorded in a one dimensional vector
-;; containing padding squares (coded with -1). These squares allow us to
-;; detect when we are trying to move out of the board. We denote a square by
-;; its (X,Y) coords, or by the INDEX corresponding to them in the vector. The
-;; leftmost topmost square has coords (1,1) and index gomoku-board-width + 2.
-;; Similarly, vectors between squares may be given by two DX, DY coords or by
-;; one DEPL (the difference between indexes).
-
-(defvar gomoku-board-width nil
- "Number of columns on the Gomoku board.")
-
-(defvar gomoku-board-height nil
- "Number of lines on the Gomoku board.")
-
-(defvar gomoku-board nil
- "Vector recording the actual state of the Gomoku board.")
-
-(defvar gomoku-vector-length nil
- "Length of gomoku-board vector.")
-
-(defvar gomoku-draw-limit nil
- ;; This is usually set to 70% of the number of squares.
- "After how many moves will Emacs offer a draw?")
-
-
-(defun gomoku-xy-to-index (x y)
- "Translate X, Y cartesian coords into the corresponding board index."
- (+ (* y gomoku-board-width) x y))
-
-(defun gomoku-index-to-x (index)
- "Return corresponding x-coord of board INDEX."
- (% index (1+ gomoku-board-width)))
-
-(defun gomoku-index-to-y (index)
- "Return corresponding y-coord of board INDEX."
- (/ index (1+ gomoku-board-width)))
-
-(defun gomoku-init-board ()
- "Create the gomoku-board vector and fill it with initial values."
- (setq gomoku-board (make-vector gomoku-vector-length 0))
- ;; Every square is 0 (i.e. empty) except padding squares:
- (let ((i 0) (ii (1- gomoku-vector-length)))
- (while (<= i gomoku-board-width) ; The squares in [0..width] and in
- (aset gomoku-board i -1) ; [length - width - 1..length - 1]
- (aset gomoku-board ii -1) ; are padding squares.
- (setq i (1+ i)
- ii (1- ii))))
- (let ((i 0))
- (while (< i gomoku-vector-length)
- (aset gomoku-board i -1) ; and also all k*(width+1)
- (setq i (+ i gomoku-board-width 1)))))
-
-;;;
-;;; THE SCORE TABLE.
-;;;
-
-;; Every (free) square has a score associated to it, recorded in the
-;; GOMOKU-SCORE-TABLE vector. The program always plays in the square having
-;; the highest score.
-
-(defvar gomoku-score-table nil
- "Vector recording the actual score of the free squares.")
-
-
-;; The key point point about the algorithm is that, rather than considering
-;; the board as just a set of squares, we prefer to see it as a "space" of
-;; internested 5-tuples of contiguous squares (called qtuples).
-;;
-;; The aim of the program is to fill one qtuple with its O's while preventing
-;; you from filling another one with your X's. To that effect, it computes a
-;; score for every qtuple, with better qtuples having better scores. Of
-;; course, the score of a qtuple (taken in isolation) is just determined by
-;; its contents as a set, i.e. not considering the order of its elements. The
-;; highest score is given to the "OOOO" qtuples because playing in such a
-;; qtuple is winning the game. Just after this comes the "XXXX" qtuple because
-;; not playing in it is just loosing the game, and so on. Note that a
-;; "polluted" qtuple, i.e. one containing at least one X and at least one O,
-;; has score zero because there is no more any point in playing in it, from
-;; both an attacking and a defending point of view.
-;;
-;; Given the score of every qtuple, the score of a given free square on the
-;; board is just the sum of the scores of all the qtuples to which it belongs,
-;; because playing in that square is playing in all its containing qtuples at
-;; once. And it is that function which takes into account the internesting of
-;; the qtuples.
-;;
-;; This algorithm is rather simple but anyway it gives a not so dumb level of
-;; play. It easily extends to "n-dimensional Gomoku", where a win should not
-;; be obtained with as few as 5 contiguous marks: 6 or 7 (depending on n !)
-;; should be preferred.
-
-
-;; Here are the scores of the nine "non-polluted" configurations. Tuning
-;; these values will change (hopefully improve) the strength of the program
-;; and may change its style (rather aggressive here).
-
-(defconst nil-score 7 "Score of an empty qtuple.")
-(defconst Xscore 15 "Score of a qtuple containing one X.")
-(defconst XXscore 400 "Score of a qtuple containing two X's.")
-(defconst XXXscore 1800 "Score of a qtuple containing three X's.")
-(defconst XXXXscore 100000 "Score of a qtuple containing four X's.")
-(defconst Oscore 35 "Score of a qtuple containing one O.")
-(defconst OOscore 800 "Score of a qtuple containing two O's.")
-(defconst OOOscore 15000 "Score of a qtuple containing three O's.")
-(defconst OOOOscore 800000 "Score of a qtuple containing four O's.")
-
-;; These values are not just random: if, given the following situation:
-;;
-;; . . . . . . . O .
-;; . X X a . . . X .
-;; . . . X . . . X .
-;; . . . X . . . X .
-;; . . . . . . . b .
-;;
-;; you want Emacs to play in "a" and not in "b", then the parameters must
-;; satisfy the inequality:
-;;
-;; 6 * XXscore > XXXscore + XXscore
-;;
-;; because "a" mainly belongs to six "XX" qtuples (the others are less
-;; important) while "b" belongs to one "XXX" and one "XX" qtuples. Other
-;; conditions are required to obtain sensible moves, but the previous example
-;; should illustrate the point. If you manage to improve on these values,
-;; please send me a note. Thanks.
-
-
-;; As we choosed values 0, 1 and 6 to denote empty, X and O squares, the
-;; contents of a qtuple is uniquely determined by the sum of its elements and
-;; we just have to set up a translation table.
-
-(defconst gomoku-score-trans-table
- (vector nil-score Xscore XXscore XXXscore XXXXscore 0
- Oscore 0 0 0 0 0
- OOscore 0 0 0 0 0
- OOOscore 0 0 0 0 0
- OOOOscore 0 0 0 0 0
- 0)
- "Vector associating qtuple contents to their score.")
-
-
-;; If you do not modify drastically the previous constants, the only way for a
-;; square to have a score higher than OOOOscore is to belong to a "OOOO"
-;; qtuple, thus to be a winning move. Similarly, the only way for a square to
-;; have a score between XXXXscore and OOOOscore is to belong to a "XXXX"
-;; qtuple. We may use these considerations to detect when a given move is
-;; winning or loosing.
-
-(defconst gomoku-winning-threshold OOOOscore
- "Threshold score beyond which an Emacs move is winning.")
-
-(defconst gomoku-loosing-threshold XXXXscore
- "Threshold score beyond which a human move is winning.")
-
-
-(defun gomoku-strongest-square ()
- "Compute index of free square with highest score, or nil if none."
- ;; We just have to loop other all squares. However there are two problems:
- ;; 1/ The SCORE-TABLE only gives correct scores to free squares. To speed
- ;; up future searches, we set the score of padding or occupied squares
- ;; to -1 whenever we meet them.
- ;; 2/ We want to choose randomly between equally good moves.
- (let ((score-max 0)
- (count 0) ; Number of equally good moves
- (square (gomoku-xy-to-index 1 1)) ; First square
- (end (gomoku-xy-to-index gomoku-board-width gomoku-board-height))
- best-square score)
- (while (<= square end)
- (cond
- ;; If score is lower (i.e. most of the time), skip to next:
- ((< (aref gomoku-score-table square) score-max))
- ;; If score is better, beware of non free squares:
- ((> (setq score (aref gomoku-score-table square)) score-max)
- (if (zerop (aref gomoku-board square)) ; is it free ?
- (setq count 1 ; yes: take it !
- best-square square
- score-max score)
- (aset gomoku-score-table square -1))) ; no: kill it !
- ;; If score is equally good, choose randomly. But first check freeness:
- ((not (zerop (aref gomoku-board square)))
- (aset gomoku-score-table square -1))
- ((= count (random-number (setq count (1+ count))))
- (setq best-square square
- score-max score)))
- (setq square (1+ square))) ; try next square
- best-square))
-
-(defun random-number (n)
- "Return a random integer between 0 and N-1 inclusive."
- (setq n (% (random) n))
- (if (< n 0) (- n) n))
-
-;;;
-;;; INITIALIZING THE SCORE TABLE.
-;;;
-
-;; At initialization the board is empty so that every qtuple amounts for
-;; nil-score. Therefore, the score of any square is nil-score times the number
-;; of qtuples that pass through it. This number is 3 in a corner and 20 if you
-;; are sufficiently far from the sides. As computing the number is time
-;; consuming, we initialize every square with 20*nil-score and then only
-;; consider squares at less than 5 squares from one side. We speed this up by
-;; taking symmetry into account.
-;; Also, as it is likely that successive games will be played on a board with
-;; same size, it is a good idea to save the initial SCORE-TABLE configuration.
-
-(defvar gomoku-saved-score-table nil
- "Recorded initial value of previous score table.")
-
-(defvar gomoku-saved-board-width nil
- "Recorded value of previous board width.")
-
-(defvar gomoku-saved-board-height nil
- "Recorded value of previous board height.")
-
-
-(defun gomoku-init-score-table ()
- "Create the score table vector and fill it with initial values."
- (if (and gomoku-saved-score-table ; Has it been stored last time ?
- (= gomoku-board-width gomoku-saved-board-width)
- (= gomoku-board-height gomoku-saved-board-height))
- (setq gomoku-score-table (copy-sequence gomoku-saved-score-table))
- ;; No, compute it:
- (setq gomoku-score-table
- (make-vector gomoku-vector-length (* 20 nil-score)))
- (let (i j maxi maxj maxi2 maxj2)
- (setq maxi (/ (1+ gomoku-board-width) 2)
- maxj (/ (1+ gomoku-board-height) 2)
- maxi2 (min 4 maxi)
- maxj2 (min 4 maxj))
- ;; We took symmetry into account and could use it more if the board
- ;; would have been square and not rectangular !
- ;; In our case we deal with all (i,j) in the set [1..maxi2]*[1..maxj] U
- ;; [maxi2+1..maxi]*[1..maxj2]. Maxi2 and maxj2 are used because the
- ;; board may well be less than 8 by 8 !
- (setq i 1)
- (while (<= i maxi2)
- (setq j 1)
- (while (<= j maxj)
- (gomoku-init-square-score i j)
- (setq j (1+ j)))
- (setq i (1+ i)))
- (while (<= i maxi)
- (setq j 1)
- (while (<= j maxj2)
- (gomoku-init-square-score i j)
- (setq j (1+ j)))
- (setq i (1+ i))))
- (setq gomoku-saved-score-table (copy-sequence gomoku-score-table)
- gomoku-saved-board-width gomoku-board-width
- gomoku-saved-board-height gomoku-board-height)))
-
-(defun gomoku-nb-qtuples (i j)
- "Return the number of qtuples containing square I,J."
- ;; This function is complicated because we have to deal
- ;; with ugly cases like 3 by 6 boards, but it works.
- ;; If you have a simpler (and correct) solution, send it to me. Thanks !
- (let ((left (min 4 (1- i)))
- (right (min 4 (- gomoku-board-width i)))
- (up (min 4 (1- j)))
- (down (min 4 (- gomoku-board-height j))))
- (+ -12
- (min (max (+ left right) 3) 8)
- (min (max (+ up down) 3) 8)
- (min (max (+ (min left up) (min right down)) 3) 8)
- (min (max (+ (min right up) (min left down)) 3) 8))))
-
-(defun gomoku-init-square-score (i j)
- "Give initial score to square I,J and to its mirror images."
- (let ((ii (1+ (- gomoku-board-width i)))
- (jj (1+ (- gomoku-board-height j)))
- (sc (* (gomoku-nb-qtuples i j) (aref gomoku-score-trans-table 0))))
- (aset gomoku-score-table (gomoku-xy-to-index i j) sc)
- (aset gomoku-score-table (gomoku-xy-to-index ii j) sc)
- (aset gomoku-score-table (gomoku-xy-to-index i jj) sc)
- (aset gomoku-score-table (gomoku-xy-to-index ii jj) sc)))
-
-;;;
-;;; MAINTAINING THE SCORE TABLE.
-;;;
-
-;; We do not provide functions for computing the SCORE-TABLE given the
-;; contents of the BOARD. This would involve heavy nested loops, with time
-;; proportional to the size of the board. It is better to update the
-;; SCORE-TABLE after each move. Updating needs not modify more than 36
-;; squares: it is done in constant time.
-
-(defun gomoku-update-score-table (square dval)
- "Update score table after SQUARE received a DVAL increment."
- ;; The board has already been updated when this function is called.
- ;; Updating scores is done by looking for qtuples boundaries in all four
- ;; directions and then calling update-score-in-direction.
- ;; Finally all squares received the right increment, and then are up to
- ;; date, except possibly for SQUARE itself if we are taking a move back for
- ;; its score had been set to -1 at the time.
- (let* ((x (gomoku-index-to-x square))
- (y (gomoku-index-to-y square))
- (imin (max -4 (- 1 x)))
- (jmin (max -4 (- 1 y)))
- (imax (min 0 (- gomoku-board-width x 4)))
- (jmax (min 0 (- gomoku-board-height y 4))))
- (gomoku-update-score-in-direction imin imax
- square 1 0 dval)
- (gomoku-update-score-in-direction jmin jmax
- square 0 1 dval)
- (gomoku-update-score-in-direction (max imin jmin) (min imax jmax)
- square 1 1 dval)
- (gomoku-update-score-in-direction (max (- 1 y) -4
- (- x gomoku-board-width))
- (min 0 (- x 5)
- (- gomoku-board-height y 4))
- square -1 1 dval)))
-
-(defun gomoku-update-score-in-direction (left right square dx dy dval)
- "Update scores for all squares in the qtuples starting between the LEFTth
-square and the RIGHTth after SQUARE, along the DX, DY direction, considering
-that DVAL has been added on SQUARE."
- ;; We always have LEFT <= 0, RIGHT <= 0 and DEPL > 0 but we may very well
- ;; have LEFT > RIGHT, indicating that no qtuple contains SQUARE along that
- ;; DX,DY direction.
- (cond
- ((> left right)) ; Quit
- (t ; Else ..
- (let (depl square0 square1 square2 count delta)
- (setq depl (gomoku-xy-to-index dx dy)
- square0 (+ square (* left depl))
- square1 (+ square (* right depl))
- square2 (+ square0 (* 4 depl)))
- ;; Compute the contents of the first qtuple:
- (setq square square0
- count 0)
- (while (<= square square2)
- (setq count (+ count (aref gomoku-board square))
- square (+ square depl)))
- (while (<= square0 square1)
- ;; Update the squares of the qtuple beginning in SQUARE0 and ending
- ;; in SQUARE2.
- (setq delta (- (aref gomoku-score-trans-table count)
- (aref gomoku-score-trans-table (- count dval))))
- (cond ((not (zerop delta)) ; or else nothing to update
- (setq square square0)
- (while (<= square square2)
- (if (zerop (aref gomoku-board square)) ; only for free squares
- (aset gomoku-score-table square
- (+ (aref gomoku-score-table square) delta)))
- (setq square (+ square depl)))))
- ;; Then shift the qtuple one square along DEPL, this only requires
- ;; modifying SQUARE0 and SQUARE2.
- (setq square2 (+ square2 depl)
- count (+ count (- (aref gomoku-board square0))
- (aref gomoku-board square2))
- square0 (+ square0 depl)))))))
-
-;;;
-;;; GAME CONTROL.
-;;;
-
-;; Several variables are used to monitor a game, including a GAME-HISTORY (the
-;; list of all (SQUARE . PREVSCORE) played) that allows to take moves back
-;; (anti-updating the score table) and to compute the table from scratch in
-;; case of an interruption.
-
-(defvar gomoku-game-in-progress nil
- "Non-nil if a game is in progress.")
-
-(defvar gomoku-game-history nil
- "A record of all moves that have been played during current game.")
-
-(defvar gomoku-number-of-moves nil
- "Number of moves already played in current game.")
-
-(defvar gomoku-number-of-human-moves nil
- "Number of moves already played by human in current game.")
-
-(defvar gomoku-emacs-played-first nil
- "Non-nil if Emacs played first.")
-
-(defvar gomoku-human-took-back nil
- "Non-nil if Human took back a move during the game.")
-
-(defvar gomoku-human-refused-draw nil
- "Non-nil if Human refused Emacs offer of a draw.")
-
-(defvar gomoku-emacs-is-computing nil
- ;; This is used to detect interruptions. Hopefully, it should not be needed.
- "Non-nil if Emacs is in the middle of a computation.")
-
-
-(defun gomoku-start-game (n m)
- "Initialize a new game on an N by M board."
- (setq gomoku-emacs-is-computing t) ; Raise flag
- (setq gomoku-game-in-progress t)
- (setq gomoku-board-width n
- gomoku-board-height m
- gomoku-vector-length (1+ (* (+ m 2) (1+ n)))
- gomoku-draw-limit (/ (* 7 n m) 10))
- (setq gomoku-game-history nil
- gomoku-number-of-moves 0
- gomoku-number-of-human-moves 0
- gomoku-emacs-played-first nil
- gomoku-human-took-back nil
- gomoku-human-refused-draw nil)
- (gomoku-init-display n m) ; Display first: the rest takes time
- (gomoku-init-score-table) ; INIT-BOARD requires that the score
- (gomoku-init-board) ; table be already created.
- (setq gomoku-emacs-is-computing nil))
-
-(defun gomoku-play-move (square val &optional dont-update-score)
- "Go to SQUARE, play VAL and update everything."
- (setq gomoku-emacs-is-computing t) ; Raise flag
- (cond ((= 1 val) ; a Human move
- (setq gomoku-number-of-human-moves (1+ gomoku-number-of-human-moves)))
- ((zerop gomoku-number-of-moves) ; an Emacs move. Is it first ?
- (setq gomoku-emacs-played-first t)))
- (setq gomoku-game-history
- (cons (cons square (aref gomoku-score-table square))
- gomoku-game-history)
- gomoku-number-of-moves (1+ gomoku-number-of-moves))
- (gomoku-plot-square square val)
- (aset gomoku-board square val) ; *BEFORE* UPDATE-SCORE !
- (if dont-update-score nil
- (gomoku-update-score-table square val) ; previous val was 0: dval = val
- (aset gomoku-score-table square -1))
- (setq gomoku-emacs-is-computing nil))
-
-(defun gomoku-take-back ()
- "Take back last move and update everything."
- (setq gomoku-emacs-is-computing t)
- (let* ((last-move (car gomoku-game-history))
- (square (car last-move))
- (oldval (aref gomoku-board square)))
- (if (= 1 oldval)
- (setq gomoku-number-of-human-moves (1- gomoku-number-of-human-moves)))
- (setq gomoku-game-history (cdr gomoku-game-history)
- gomoku-number-of-moves (1- gomoku-number-of-moves))
- (gomoku-plot-square square 0)
- (aset gomoku-board square 0) ; *BEFORE* UPDATE-SCORE !
- (gomoku-update-score-table square (- oldval))
- (aset gomoku-score-table square (cdr last-move)))
- (setq gomoku-emacs-is-computing nil))
-
-;;;
-;;; SESSION CONTROL.
-;;;
-
-(defvar gomoku-number-of-wins 0
- "Number of games already won in this session.")
-
-(defvar gomoku-number-of-losses 0
- "Number of games already lost in this session.")
-
-(defvar gomoku-number-of-draws 0
- "Number of games already drawn in this session.")
-
-
-(defun gomoku-terminate-game (result)
- "Terminate the current game with RESULT."
- (let (message)
- (cond
- ((eq result 'emacs-won)
- (setq gomoku-number-of-wins (1+ gomoku-number-of-wins))
- (setq message
- (cond ((< gomoku-number-of-moves 20)
- "This was a REALLY QUICK win.")
- (gomoku-human-refused-draw
- "I won... Too bad you refused my offer of a draw !")
- (gomoku-human-took-back
- "I won... Taking moves back will not help you !")
- ((not gomoku-emacs-played-first)
- "I won... Playing first did not help you much !")
- ((and (zerop gomoku-number-of-losses)
- (zerop gomoku-number-of-draws)
- (> gomoku-number-of-wins 1))
- "I'm becoming tired of winning...")
- (t
- "I won."))))
- ((eq result 'human-won)
- (setq gomoku-number-of-losses (1+ gomoku-number-of-losses))
- (setq message
- (cond
- (gomoku-human-took-back
- "OK, you won this one. I, for one, never take my moves back...")
- (gomoku-emacs-played-first
- "OK, you won this one... so what ?")
- (t
- "OK, you won this one. Now, let me play first just once."))))
- ((eq result 'human-resigned)
- (setq gomoku-number-of-wins (1+ gomoku-number-of-wins))
- (setq message "So you resign. That's just one more win for me."))
- ((eq result 'nobody-won)
- (setq gomoku-number-of-draws (1+ gomoku-number-of-draws))
- (setq message
- (cond
- (gomoku-human-took-back
- "This is a draw. I, for one, never take my moves back...")
- (gomoku-emacs-played-first
- "This is a draw. Just chance, I guess.")
- (t
- "This is a draw. Now, let me play first just once."))))
- ((eq result 'draw-agreed)
- (setq gomoku-number-of-draws (1+ gomoku-number-of-draws))
- (setq message
- (cond
- (gomoku-human-took-back
- "Draw agreed. I, for one, never take my moves back...")
- (gomoku-emacs-played-first
- "Draw agreed. You were lucky.")
- (t
- "Draw agreed. Now, let me play first just once."))))
- ((eq result 'crash-game)
- (setq message
- "Sorry, I have been interrupted and cannot resume that game...")))
-
- (gomoku-display-statistics)
- (if message (message message))
- (ding)
- (setq gomoku-game-in-progress nil)))
-
-(defun gomoku-crash-game ()
- "What to do when Emacs detects it has been interrupted."
- (setq gomoku-emacs-is-computing nil)
- (gomoku-terminate-game 'crash-game)
- (sit-for 4) ; Let's see the message
- (gomoku-prompt-for-other-game))
-
-;;;
-;;; INTERACTIVE COMMANDS.
-;;;
-
-(defun gomoku (&optional n m)
- "Start a Gomoku game between you and Emacs.
-If a game is in progress, this command allow you to resume it.
-If optional arguments N and M are given, an N by M board is used.
-
-You and Emacs play in turn by marking a free square. You mark it with X
-and Emacs marks it with O. The winner is the first to get five contiguous
-marks horizontally, vertically or in diagonal.
-
-You play by moving the cursor over the square you choose and hitting
-\\<gomoku-mode-map>\\[gomoku-human-plays].
-Use \\[describe-mode] for more info."
- (interactive)
- (gomoku-switch-to-window)
- (cond
- (gomoku-emacs-is-computing
- (gomoku-crash-game))
- ((not gomoku-game-in-progress)
- (let ((max-width (gomoku-max-width))
- (max-height (gomoku-max-height)))
- (or n (setq n max-width))
- (or m (setq m max-height))
- (cond ((< n 1)
- (error "I need at least 1 column"))
- ((< m 1)
- (error "I need at least 1 row"))
- ((> n max-width)
- (error "I cannot display %d columns in that window" n)))
- (if (and (> m max-height)
- (not (equal m gomoku-saved-board-height))
- ;; Use EQUAL because SAVED-BOARD-HEIGHT may be nil
- (not (y-or-n-p (format "Do you really want %d rows " m))))
- (setq m max-height)))
- (message "One moment, please...")
- (gomoku-start-game n m)
- (if (y-or-n-p "Do you allow me to play first ")
- (gomoku-emacs-plays)
- (gomoku-prompt-for-move)))
- ((y-or-n-p "Shall we continue our game ")
- (gomoku-prompt-for-move))
- (t
- (gomoku-human-resigns))))
-
-(defun gomoku-emacs-plays ()
- "Compute Emacs next move and play it."
- (interactive)
- (gomoku-switch-to-window)
- (cond
- (gomoku-emacs-is-computing
- (gomoku-crash-game))
- ((not gomoku-game-in-progress)
- (gomoku-prompt-for-other-game))
- (t
- (message "Let me think...")
- (let (square score)
- (setq square (gomoku-strongest-square))
- (cond ((null square)
- (gomoku-terminate-game 'nobody-won))
- (t
- (setq score (aref gomoku-score-table square))
- (gomoku-play-move square 6)
- (cond ((>= score gomoku-winning-threshold)
- (gomoku-find-filled-qtuple square 6)
- (gomoku-cross-winning-qtuple)
- (gomoku-terminate-game 'emacs-won))
- ((zerop score)
- (gomoku-terminate-game 'nobody-won))
- ((and (> gomoku-number-of-moves gomoku-draw-limit)
- (not gomoku-human-refused-draw)
- (gomoku-offer-a-draw))
- (gomoku-terminate-game 'draw-agreed))
- (t
- (gomoku-prompt-for-move)))))))))
-
-(defun gomoku-human-plays ()
- "Signal to the Gomoku program that you have played.
-You must have put the cursor on the square where you want to play.
-If the game is finished, this command requests for another game."
- (interactive)
- (gomoku-switch-to-window)
- (cond
- (gomoku-emacs-is-computing
- (gomoku-crash-game))
- ((not gomoku-game-in-progress)
- (gomoku-prompt-for-other-game))
- (t
- (let (square score)
- (setq square (gomoku-point-square))
- (cond ((null square)
- (error "Your point is not on a square. Retry !"))
- ((not (zerop (aref gomoku-board square)))
- (error "Your point is not on a free square. Retry !"))
- (t
- (setq score (aref gomoku-score-table square))
- (gomoku-play-move square 1)
- (cond ((and (>= score gomoku-loosing-threshold)
- ;; Just testing SCORE > THRESHOLD is not enough for
- ;; detecting wins, it just gives an indication that
- ;; we confirm with GOMOKU-FIND-FILLED-QTUPLE.
- (gomoku-find-filled-qtuple square 1))
- (gomoku-cross-winning-qtuple)
- (gomoku-terminate-game 'human-won))
- (t
- (gomoku-emacs-plays)))))))))
-
-(defun gomoku-human-takes-back ()
- "Signal to the Gomoku program that you wish to take back your last move."
- (interactive)
- (gomoku-switch-to-window)
- (cond
- (gomoku-emacs-is-computing
- (gomoku-crash-game))
- ((not gomoku-game-in-progress)
- (message "Too late for taking back...")
- (sit-for 4)
- (gomoku-prompt-for-other-game))
- ((zerop gomoku-number-of-human-moves)
- (message "You have not played yet... Your move ?"))
- (t
- (message "One moment, please...")
- ;; It is possible for the user to let Emacs play several consecutive
- ;; moves, so that the best way to know when to stop taking back moves is
- ;; to count the number of human moves:
- (setq gomoku-human-took-back t)
- (let ((number gomoku-number-of-human-moves))
- (while (= number gomoku-number-of-human-moves)
- (gomoku-take-back)))
- (gomoku-prompt-for-move))))
-
-(defun gomoku-human-resigns ()
- "Signal to the Gomoku program that you may want to resign."
- (interactive)
- (gomoku-switch-to-window)
- (cond
- (gomoku-emacs-is-computing
- (gomoku-crash-game))
- ((not gomoku-game-in-progress)
- (message "There is no game in progress"))
- ((y-or-n-p "You mean, you resign ")
- (gomoku-terminate-game 'human-resigned))
- ((y-or-n-p "You mean, we continue ")
- (gomoku-prompt-for-move))
- (t
- (gomoku-terminate-game 'human-resigned)))) ; OK. Accept it
-
-;;;
-;;; PROMPTING THE HUMAN PLAYER.
-;;;
-
-(defun gomoku-prompt-for-move ()
- "Display a message asking for Human's move."
- (message (if (zerop gomoku-number-of-human-moves)
- "Your move ? (move to a free square and hit X, RET ...)"
- "Your move ?"))
- ;; This may seem silly, but if one omits the following line (or a similar
- ;; one), the cursor may very well go to some place where POINT is not.
- (save-excursion (set-buffer (other-buffer))))
-
-(defun gomoku-prompt-for-other-game ()
- "Ask for another game, and start it."
- (if (y-or-n-p "Another game ")
- (gomoku gomoku-board-width gomoku-board-height)
- (message "Chicken !")))
-
-(defun gomoku-offer-a-draw ()
- "Offer a draw and return T if Human accepted it."
- (or (y-or-n-p "I offer you a draw. Do you accept it ")
- (prog1 (setq gomoku-human-refused-draw t)
- nil)))
-
-;;;
-;;; DISPLAYING THE BOARD.
-;;;
-
-;; You may change these values if you have a small screen or if the squares
-;; look rectangular, but spacings SHOULD be at least 2 (MUST BE at least 1).
-
-(defconst gomoku-square-width 4
- "*Horizontal spacing between squares on the Gomoku board.")
-
-(defconst gomoku-square-height 2
- "*Vertical spacing between squares on the Gomoku board.")
-
-(defconst gomoku-x-offset 3
- "*Number of columns between the Gomoku board and the side of the window.")
-
-(defconst gomoku-y-offset 1
- "*Number of lines between the Gomoku board and the top of the window.")
-
-
-(defun gomoku-max-width ()
- "Largest possible board width for the current window."
- (1+ (/ (- (window-width (selected-window))
- gomoku-x-offset gomoku-x-offset 1)
- gomoku-square-width)))
-
-(defun gomoku-max-height ()
- "Largest possible board height for the current window."
- (1+ (/ (- (window-height (selected-window))
- gomoku-y-offset gomoku-y-offset 2)
- ;; 2 instead of 1 because WINDOW-HEIGHT includes the mode line !
- gomoku-square-height)))
-
-(defun gomoku-point-x ()
- "Return the board column where point is, or nil if it is not a board column."
- (let ((col (- (current-column) gomoku-x-offset)))
- (if (and (>= col 0)
- (zerop (% col gomoku-square-width))
- (<= (setq col (1+ (/ col gomoku-square-width)))
- gomoku-board-width))
- col)))
-
-(defun gomoku-point-y ()
- "Return the board row where point is, or nil if it is not a board row."
- (let ((row (- (count-lines 1 (point)) gomoku-y-offset 1)))
- (if (and (>= row 0)
- (zerop (% row gomoku-square-height))
- (<= (setq row (1+ (/ row gomoku-square-height)))
- gomoku-board-height))
- row)))
-
-(defun gomoku-point-square ()
- "Return the index of the square point is on, or nil if not on the board."
- (let (x y)
- (and (setq x (gomoku-point-x))
- (setq y (gomoku-point-y))
- (gomoku-xy-to-index x y))))
-
-(defun gomoku-goto-square (index)
- "Move point to square number INDEX."
- (gomoku-goto-xy (gomoku-index-to-x index) (gomoku-index-to-y index)))
-
-(defun gomoku-goto-xy (x y)
- "Move point to square at X, Y coords."
- (goto-line (+ 1 gomoku-y-offset (* gomoku-square-height (1- y))))
- (move-to-column (+ gomoku-x-offset (* gomoku-square-width (1- x)))))
-
-(defun gomoku-plot-square (square value)
- "Draw 'X', 'O' or '.' on SQUARE (depending on VALUE), leave point there."
- (gomoku-goto-square square)
- (gomoku-put-char (cond ((= value 1) ?X)
- ((= value 6) ?O)
- (t ?.)))
- (sit-for 0)) ; Display NOW
-
-(defun gomoku-put-char (char)
- "Draw CHAR on the Gomoku screen."
- (if buffer-read-only (toggle-read-only))
- (insert char)
- (delete-char 1)
- (backward-char 1)
- (toggle-read-only))
-
-(defun gomoku-init-display (n m)
- "Display an N by M Gomoku board."
- (buffer-disable-undo (current-buffer))
- (if buffer-read-only (toggle-read-only))
- (erase-buffer)
- (let (string1 string2 string3 string4)
- ;; We do not use gomoku-plot-square which would be too slow for
- ;; initializing the display. Rather we build STRING1 for lines where
- ;; board squares are to be found, and STRING2 for empty lines. STRING1 is
- ;; like STRING2 except for dots every DX squares. Empty lines are filled
- ;; with spaces so that cursor moving up and down remains on the same
- ;; column.
- (setq string1 (concat (make-string (1- gomoku-square-width) ? ) ".")
- string1 (apply 'concat
- (make-list (1- n) string1))
- string1 (concat (make-string gomoku-x-offset ? ) "." string1 "\n")
- string2 (make-string (+ 1 gomoku-x-offset
- (* (1- n) gomoku-square-width))
- ? )
- string2 (concat string2 "\n")
- string3 (apply 'concat
- (make-list (1- gomoku-square-height) string2))
- string3 (concat string3 string1)
- string3 (apply 'concat
- (make-list (1- m) string3))
- string4 (apply 'concat
- (make-list gomoku-y-offset string2)))
- (insert string4 string1 string3))
- (toggle-read-only)
- (gomoku-goto-xy (/ (1+ n) 2) (/ (1+ m) 2)) ; center of the board
- (sit-for 0)) ; Display NOW
-
-(defun gomoku-display-statistics ()
- "Obnoxiously display some statistics about previous games in mode line."
- ;; We store this string in the mode-line-process local variable.
- ;; This is certainly not the cleanest way out ...
- (setq mode-line-process
- (cond
- ((not (zerop gomoku-number-of-draws))
- (format ": Won %d, lost %d, drew %d"
- gomoku-number-of-wins
- gomoku-number-of-losses
- gomoku-number-of-draws))
- ((not (zerop gomoku-number-of-losses))
- (format ": Won %d, lost %d"
- gomoku-number-of-wins
- gomoku-number-of-losses))
- ((zerop gomoku-number-of-wins)
- "")
- ((= 1 gomoku-number-of-wins)
- ": Already won one")
- (t
- (format ": Won %d in a row"
- gomoku-number-of-wins))))
- ;; Then a (standard) kludgy line will force update of mode line.
- (set-buffer-modified-p (buffer-modified-p)))
-
-(defun gomoku-switch-to-window ()
- "Find or create the Gomoku buffer, and display it."
- (interactive)
- (let ((buff (get-buffer "*Gomoku*")))
- (if buff ; Buffer exists:
- (switch-to-buffer buff) ; no problem.
- (if gomoku-game-in-progress
- (gomoku-crash-game)) ; buffer has been killed or something
- (switch-to-buffer "*Gomoku*") ; Anyway, start anew.
- (gomoku-mode))))
-
-;;;
-;;; CROSSING WINNING QTUPLES.
-;;;
-
-;; When someone succeeds in filling a qtuple, we draw a line over the five
-;; corresponding squares. One problem is that the program does not know which
-;; squares ! It only knows the square where the last move has been played and
-;; who won. The solution is to scan the board along all four directions.
-
-(defvar gomoku-winning-qtuple-beg nil
- "First square of the winning qtuple.")
-
-(defvar gomoku-winning-qtuple-end nil
- "Last square of the winning qtuple.")
-
-(defvar gomoku-winning-qtuple-dx nil
- "Direction of the winning qtuple (along the X axis).")
-
-(defvar gomoku-winning-qtuple-dy nil
- "Direction of the winning qtuple (along the Y axis).")
-
-
-(defun gomoku-find-filled-qtuple (square value)
- "Return T if SQUARE belongs to a qtuple filled with VALUEs."
- (or (gomoku-check-filled-qtuple square value 1 0)
- (gomoku-check-filled-qtuple square value 0 1)
- (gomoku-check-filled-qtuple square value 1 1)
- (gomoku-check-filled-qtuple square value -1 1)))
-
-(defun gomoku-check-filled-qtuple (square value dx dy)
- "Return T if SQUARE belongs to a qtuple filled with VALUEs along DX, DY."
- ;; And record it in the WINNING-QTUPLE-... variables.
- (let ((a 0) (b 0)
- (left square) (right square)
- (depl (gomoku-xy-to-index dx dy))
- a+4)
- (while (and (> a -4) ; stretch tuple left
- (= value (aref gomoku-board (setq left (- left depl)))))
- (setq a (1- a)))
- (setq a+4 (+ a 4))
- (while (and (< b a+4) ; stretch tuple right
- (= value (aref gomoku-board (setq right (+ right depl)))))
- (setq b (1+ b)))
- (cond ((= b a+4) ; tuple length = 5 ?
- (setq gomoku-winning-qtuple-beg (+ square (* a depl))
- gomoku-winning-qtuple-end (+ square (* b depl))
- gomoku-winning-qtuple-dx dx
- gomoku-winning-qtuple-dy dy)
- t))))
-
-(defun gomoku-cross-winning-qtuple ()
- "Cross winning qtuple, as found by `gomoku-find-filled-qtuple'."
- (gomoku-cross-qtuple gomoku-winning-qtuple-beg
- gomoku-winning-qtuple-end
- gomoku-winning-qtuple-dx
- gomoku-winning-qtuple-dy))
-
-(defun gomoku-cross-qtuple (square1 square2 dx dy)
- "Cross every square between SQUARE1 and SQUARE2 in the DX, DY direction."
- (save-excursion ; Not moving point from last square
- (let ((depl (gomoku-xy-to-index dx dy)))
- ;; WARNING: this function assumes DEPL > 0 and SQUARE2 > SQUARE1
- (while (not (= square1 square2))
- (gomoku-goto-square square1)
- (setq square1 (+ square1 depl))
- (cond
- ((and (= dx 1) (= dy 0)) ; Horizontal
- (let ((n 1))
- (while (< n gomoku-square-width)
- (setq n (1+ n))
- (forward-char 1)
- (gomoku-put-char ?-))))
- ((and (= dx 0) (= dy 1)) ; Vertical
- (let ((n 1))
- (while (< n gomoku-square-height)
- (setq n (1+ n))
- (next-line 1)
- (gomoku-put-char ?|))))
- ((and (= dx -1) (= dy 1)) ; 1st Diagonal
- (backward-char (/ gomoku-square-width 2))
- (next-line (/ gomoku-square-height 2))
- (gomoku-put-char ?/))
- ((and (= dx 1) (= dy 1)) ; 2nd Diagonal
- (forward-char (/ gomoku-square-width 2))
- (next-line (/ gomoku-square-height 2))
- (gomoku-put-char ?\\))))))
- (sit-for 0)) ; Display NOW
-
-;;;
-;;; CURSOR MOTION.
-;;;
-(defun gomoku-move-left ()
- "Move point backward one column on the Gomoku board."
- (interactive)
- (let ((x (gomoku-point-x)))
- (backward-char (cond ((null x) 1)
- ((> x 1) gomoku-square-width)
- (t 0)))))
-
-(defun gomoku-move-right ()
- "Move point forward one column on the Gomoku board."
- (interactive)
- (let ((x (gomoku-point-x)))
- (forward-char (cond ((null x) 1)
- ((< x gomoku-board-width) gomoku-square-width)
- (t 0)))))
-
-(defun gomoku-move-down ()
- "Move point down one row on the Gomoku board."
- (interactive)
- (let ((y (gomoku-point-y)))
- (next-line (cond ((null y) 1)
- ((< y gomoku-board-height) gomoku-square-height)
- (t 0)))))
-
-(defun gomoku-move-up ()
- "Move point up one row on the Gomoku board."
- (interactive)
- (let ((y (gomoku-point-y)))
- (previous-line (cond ((null y) 1)
- ((> y 1) gomoku-square-height)
- (t 0)))))
-
-(defun gomoku-move-ne ()
- "Move point North East on the Gomoku board."
- (interactive)
- (gomoku-move-up)
- (gomoku-move-right))
-
-(defun gomoku-move-se ()
- "Move point South East on the Gomoku board."
- (interactive)
- (gomoku-move-down)
- (gomoku-move-right))
-
-(defun gomoku-move-nw ()
- "Move point North West on the Gomoku board."
- (interactive)
- (gomoku-move-up)
- (gomoku-move-left))
-
-(defun gomoku-move-sw ()
- "Move point South West on the Gomoku board."
- (interactive)
- (gomoku-move-down)
- (gomoku-move-left))
-
-
diff --git a/lisp/play/mpuz.el b/lisp/play/mpuz.el
deleted file mode 100644
index f4d622ad819..00000000000
--- a/lisp/play/mpuz.el
+++ /dev/null
@@ -1,448 +0,0 @@
-;;; Multiplication puzzle for GNU Emacs
-;;; by Philippe Schnoebelen <phs@lifia.imag.fr>
-;;; Last modified on 11 Nov 1990
-;;; Copyright (C) 1990 Free Software Foundation, Inc.
-
-;; This file is part of GNU Emacs.
-
-;; 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.
-
-(random t) ; randomize
-
-(defun mpuz-random (n)
- "Return a random integer between 0 and N - 1 inclusive."
- (setq n (% (random) n))
- (if (< n 0) (- n) n))
-
-(defvar mpuz-silent nil
- "*Set this to T if you don't want dings on inputs.")
-
-(defun mpuz-ding ()
- "Dings, unless global variable `mpuz-silent' forbids it."
- (or mpuz-silent (ding t)))
-
-
-;; Mpuz mode and keymaps
-;;----------------------
-(defvar mpuz-mode-hook nil)
-
-(defvar mpuz-mode-map nil
- "Local keymap to use in Mult Puzzle.")
-
-(defvar mpuz-read-map nil
- "Local keymap to use (sometimes) in Mult Puzzle.")
-
-(if mpuz-mode-map nil
- (setq mpuz-mode-map (make-sparse-keymap))
- (define-key mpuz-mode-map "a" 'mpuz-try-letter)
- (define-key mpuz-mode-map "b" 'mpuz-try-letter)
- (define-key mpuz-mode-map "c" 'mpuz-try-letter)
- (define-key mpuz-mode-map "d" 'mpuz-try-letter)
- (define-key mpuz-mode-map "e" 'mpuz-try-letter)
- (define-key mpuz-mode-map "f" 'mpuz-try-letter)
- (define-key mpuz-mode-map "g" 'mpuz-try-letter)
- (define-key mpuz-mode-map "h" 'mpuz-try-letter)
- (define-key mpuz-mode-map "i" 'mpuz-try-letter)
- (define-key mpuz-mode-map "j" 'mpuz-try-letter)
- (define-key mpuz-mode-map "A" 'mpuz-try-letter)
- (define-key mpuz-mode-map "B" 'mpuz-try-letter)
- (define-key mpuz-mode-map "C" 'mpuz-try-letter)
- (define-key mpuz-mode-map "D" 'mpuz-try-letter)
- (define-key mpuz-mode-map "E" 'mpuz-try-letter)
- (define-key mpuz-mode-map "F" 'mpuz-try-letter)
- (define-key mpuz-mode-map "G" 'mpuz-try-letter)
- (define-key mpuz-mode-map "H" 'mpuz-try-letter)
- (define-key mpuz-mode-map "I" 'mpuz-try-letter)
- (define-key mpuz-mode-map "J" 'mpuz-try-letter)
- (define-key mpuz-mode-map "\C-g" 'mpuz-offer-abort)
- (define-key mpuz-mode-map "?" 'describe-mode))
-
-(if mpuz-read-map nil
- (setq mpuz-read-map (make-keymap))
- (fillarray mpuz-read-map 'exit-minibuffer))
-
-(defun mpuz-mode ()
- "Multiplication puzzle with GNU Emacs.
-
-You have to guess which letters stand for which digits in the
-multiplication displayed inside the *Mult Puzzle* buffer.
-
-You may enter a proposal (e.g. A=3) by hitting first the letter A,
-then the digit 3, on your keyboard.
-
-At any time you may leave the game to do other editing work. :-)
-Then you may resume the game with M-x mult-puzzle.
-You may abort a game by hitting \\[keyboard-quit]."
- (interactive)
- (setq major-mode 'mpuz-mode
- mode-name "Mult Puzzle")
- (use-local-map mpuz-mode-map)
- (run-hooks 'mpuz-mode-hook))
-
-
-;; Some variables for statistics
-;;------------------------------
-(defvar mpuz-nb-errors 0
- "Number of errors made in current game.")
-
-(defvar mpuz-nb-completed-games 0
- "Number of games completed.")
-
-(defvar mpuz-nb-cumulated-errors 0
- "Number of errors made in previous games.")
-
-
-;; Some variables for game tracking
-;;---------------------------------
-(defvar mpuz-in-progress nil
- "True if a game is currently in progress.")
-
-(defvar mpuz-found-digits (make-vector 10 nil)
- "A vector recording which digits have been decrypted.")
-
-(defmacro mpuz-digit-solved-p (digit)
- (list 'aref 'mpuz-found-digits digit))
-
-
-;; A puzzle uses a permutation of [0..9] into itself.
-;; We use both the permutation and its inverse.
-;;---------------------------------------------------
-(defvar mpuz-digit-to-letter (make-vector 10 0)
- "A permutation from [0..9] to [0..9].")
-
-(defvar mpuz-letter-to-digit (make-vector 10 0)
- "The inverse of mpuz-digit-to-letter.")
-
-(defmacro mpuz-to-digit (letter)
- (list 'aref 'mpuz-letter-to-digit letter))
-
-(defmacro mpuz-to-letter (digit)
- (list 'aref 'mpuz-digit-to-letter digit))
-
-(defun mpuz-build-random-perm ()
- "Initialize puzzle coding with a random permutation."
- (let ((letters (list 0 1 2 3 4 5 6 7 8 9)) ; new cons cells, because of delq
- (index 10)
- elem)
- (while letters
- (setq elem (nth (mpuz-random index) letters)
- letters (delq elem letters)
- index (1- index))
- (aset mpuz-digit-to-letter index elem)
- (aset mpuz-letter-to-digit elem index))))
-
-
-;; A puzzle also uses a board displaying a mulplication.
-;; Every digit appears in the board, crypted or not.
-;;------------------------------------------------------
-(defvar mpuz-board (make-vector 10 nil)
- "The board associates ot any digit the list of squares where it appears.")
-
-(defun mpuz-put-digit-on-board (number square)
- "Put (last digit of) NUMBER on SQUARE of the puzzle board."
- ;; i.e. push SQUARE on NUMBER square-list
- (setq number (% number 10))
- (aset mpuz-board number (cons square (aref mpuz-board number))))
-
-(defun mpuz-check-all-solved ()
- "Check whether all digits have been solved. Return t if yes."
- (catch 'found
- (let ((digit -1))
- (while (> 10 (setq digit (1+ digit)))
- (if (and (not (mpuz-digit-solved-p digit)) ; unsolved
- (aref mpuz-board digit)) ; and appearing in the puzzle !
- (throw 'found nil))))
- t))
-
-
-;; To build a puzzle, we take two random numbers and multiply them.
-;; We also take a random permutation for encryption.
-;; The random numbers are only use to see which digit appears in which square
-;; of the board. Everything is stored in individual squares.
-;;---------------------------------------------------------------------------
-(defun mpuz-random-puzzle ()
- "Draw random values to be multiplied in a puzzle."
- (mpuz-build-random-perm)
- (fillarray mpuz-board nil) ; erase the board
- (let (A B C D E)
- ;; A,B,C,D & E, are the five rows of our multiplication.
- ;; Choose random values, discarding uninteresting cases.
- (while (progn
- (setq A (mpuz-random 1000)
- B (mpuz-random 100)
- C (* A (% B 10))
- D (* A (/ B 10))
- E (* A B))
- (or (< C 1000) (< D 1000)))) ; forbid leading zeros in C or D
- ;; Individual digits are now put on their respectives squares.
- ;; [NB: A square is a pair <row,column> of the screen.]
- (mpuz-put-digit-on-board A '(2 . 9))
- (mpuz-put-digit-on-board (/ A 10) '(2 . 7))
- (mpuz-put-digit-on-board (/ A 100) '(2 . 5))
- (mpuz-put-digit-on-board B '(4 . 9))
- (mpuz-put-digit-on-board (/ B 10) '(4 . 7))
- (mpuz-put-digit-on-board C '(6 . 9))
- (mpuz-put-digit-on-board (/ C 10) '(6 . 7))
- (mpuz-put-digit-on-board (/ C 100) '(6 . 5))
- (mpuz-put-digit-on-board (/ C 1000) '(6 . 3))
- (mpuz-put-digit-on-board D '(8 . 7))
- (mpuz-put-digit-on-board (/ D 10) '(8 . 5))
- (mpuz-put-digit-on-board (/ D 100) '(8 . 3))
- (mpuz-put-digit-on-board (/ D 1000) '(8 . 1))
- (mpuz-put-digit-on-board E '(10 . 9))
- (mpuz-put-digit-on-board (/ E 10) '(10 . 7))
- (mpuz-put-digit-on-board (/ E 100) '(10 . 5))
- (mpuz-put-digit-on-board (/ E 1000) '(10 . 3))
- (mpuz-put-digit-on-board (/ E 10000) '(10 . 1))))
-
-;; Display
-;;--------
-(defconst mpuz-framework
- "
- . . .
- Number of errors (this game): 0
- x . .
- -------
- . . . .
- Number of completed games: 0
- . . . .
- --------- Average number of errors: 0.00
- . . . . ."
- "The general picture of the puzzle screen, as a string.")
-
-(defun mpuz-create-buffer ()
- "Create (or recreate) the puzzle buffer. Return it."
- (let ((buff (get-buffer-create "*Mult Puzzle*")))
- (save-excursion
- (set-buffer buff)
- (let ((buffer-read-only nil))
- (erase-buffer)
- (insert mpuz-framework)
- (mpuz-paint-board)
- (mpuz-paint-errors)
- (mpuz-paint-statistics)))
- buff))
-
-(defun mpuz-paint-errors ()
- "Paint error count on the puzzle screen."
- (mpuz-switch-to-window)
- (let ((buffer-read-only nil))
- (goto-line 3)
- (move-to-column 49)
- (mpuz-delete-line)
- (insert (prin1-to-string mpuz-nb-errors))))
-
-(defun mpuz-paint-statistics ()
- "Paint statistics about previous games on the puzzle screen."
- (let* ((mean (if (zerop mpuz-nb-completed-games) 0
- (/ (+ mpuz-nb-completed-games (* 200 mpuz-nb-cumulated-errors))
- (* 2 mpuz-nb-completed-games))))
- (frac-part (% mean 100)))
- (let ((buffer-read-only nil))
- (goto-line 7)
- (move-to-column 51)
- (mpuz-delete-line)
- (insert (prin1-to-string mpuz-nb-completed-games))
- (goto-line 9)
- (move-to-column 50)
- (mpuz-delete-line)
- (insert (format "%d.%d%d" (/ mean 100) (/ frac-part 10) (% frac-part 10))))))
-
-(defun mpuz-paint-board ()
- "Paint board situation on the puzzle screen."
- (mpuz-switch-to-window)
- (let ((letter -1))
- (while (> 10 (setq letter (1+ letter)))
- (mpuz-paint-digit (mpuz-to-digit letter))))
- (goto-char (point-min)))
-
-(defun mpuz-paint-digit (digit)
- "Paint all occurrences of DIGIT on the puzzle board."
- ;; (mpuz-switch-to-window)
- (let ((char (if (mpuz-digit-solved-p digit)
- (+ digit ?0)
- (+ (mpuz-to-letter digit) ?A)))
- (square-l (aref mpuz-board digit)))
- (let ((buffer-read-only nil))
- (while square-l
- (goto-line (car (car square-l))) ; line before column !
- (move-to-column (cdr (car square-l)))
- (insert char)
- (delete-char 1)
- (backward-char 1)
- (setq square-l (cdr square-l))))))
-
-(defun mpuz-delete-line ()
- "Clear from point to next newline." ; & put nothing in the kill ring
- (while (not (= ?\n (char-after (point))))
- (delete-char 1)))
-
-(defun mpuz-get-buffer ()
- "Get the puzzle buffer if it exists."
- (get-buffer "*Mult Puzzle*"))
-
-(defun mpuz-switch-to-window ()
- "Find or create the Mult-Puzzle buffer, and display it."
- (let ((buff (mpuz-get-buffer)))
- (or buff (setq buff (mpuz-create-buffer)))
- (switch-to-buffer buff)
- (or buffer-read-only (toggle-read-only))
- (mpuz-mode)))
-
-
-;; Game control
-;;-------------
-(defun mpuz-abort-game ()
- "Abort any puzzle in progess."
- (message "Mult Puzzle aborted.")
- (setq mpuz-in-progress nil
- mpuz-nb-errors 0)
- (fillarray mpuz-board nil)
- (let ((buff (mpuz-get-buffer)))
- (if buff (kill-buffer buff))))
-
-(defun mpuz-start-new-game ()
- "Start a new puzzle."
- (message "Here we go...")
- (setq mpuz-nb-errors 0
- mpuz-in-progress t)
- (fillarray mpuz-found-digits nil) ; initialize mpuz-found-digits
- (mpuz-random-puzzle)
- (mpuz-switch-to-window)
- (mpuz-paint-board)
- (mpuz-paint-errors)
- (mpuz-ask-for-try))
-
-(defun mpuz-offer-new-game ()
- "Ask if user wants to start a new puzzle."
- (if (y-or-n-p "Start a new game ")
- (mpuz-start-new-game)
- (message "OK. I won't.")))
-
-(defun mult-puzzle ()
- "Multiplication puzzle with GNU Emacs."
- ;; Main entry point
- (interactive)
- (mpuz-switch-to-window)
- (if mpuz-in-progress
- (mpuz-offer-abort)
- (mpuz-start-new-game)))
-
-(defun mpuz-offer-abort ()
- "Ask if user wants to abort current puzzle."
- (interactive)
- (if (y-or-n-p "Abort game ")
- (mpuz-abort-game)
- (mpuz-ask-for-try)))
-
-(defun mpuz-ask-for-try ()
- "Ask for user proposal in puzzle."
- (message "Your try ?"))
-
-(defun mpuz-try-letter ()
- "Propose a digit for a letter in puzzle."
- (interactive)
- (if mpuz-in-progress
- (let (letter-char digit digit-char message)
- (setq letter-char (if (or (< last-command-char ?a)
- (> last-command-char ?z))
- last-command-char
- (- last-command-char 32))
- digit (mpuz-to-digit (- letter-char ?A)))
- (cond ((mpuz-digit-solved-p digit)
- (message "%c already solved." letter-char))
- ((null (aref mpuz-board digit))
- (message "%c does not appear." letter-char))
- ((progn (setq message (format "%c = " letter-char))
- ;; <char> has been entered.
- ;; Print "<char> =" and
- ;; read <num> or = <num>
- (read-from-minibuffer message nil mpuz-read-map)
- (if (= last-input-char ?\=)
- (read-from-minibuffer message nil mpuz-read-map))
- (setq digit-char last-input-char)
- (message "%c = %c" letter-char digit-char)
- (or (> digit-char ?9) (< digit-char ?0))) ; bad input
- (ding t))
- (t
- (mpuz-try-proposal letter-char digit-char))))
- (mpuz-offer-new-game)))
-
-(defun mpuz-try-proposal (letter-char digit-char)
- "Propose LETTER-CHAR as code for DIGIT-CHAR."
- (let* ((letter (- letter-char ?A))
- (digit (- digit-char ?0))
- (correct-digit (mpuz-to-digit letter)))
- (cond ((mpuz-digit-solved-p correct-digit)
- (message "%c has already been found."))
- ((= digit correct-digit)
- (message "%c = %c correct !" letter-char digit-char)
- (mpuz-ding)
- (mpuz-correct-guess digit))
- (t ;;; incorrect guess
- (message "%c = %c incorrect !" letter-char digit-char)
- (mpuz-ding)
- (setq mpuz-nb-errors (1+ mpuz-nb-errors))
- (mpuz-paint-errors)))))
-
-(defun mpuz-correct-guess (digit)
- "Handle correct guessing of DIGIT."
- (aset mpuz-found-digits digit t) ; Mark digit as solved
- (mpuz-paint-digit digit) ; Repaint it (now as a digit)
- (if (mpuz-check-all-solved)
- (mpuz-close-game)))
-
-(defun mpuz-close-game ()
- "Housecleaning when puzzle has been solved."
- (setq mpuz-in-progress nil
- mpuz-nb-cumulated-errors (+ mpuz-nb-cumulated-errors mpuz-nb-errors)
- mpuz-nb-completed-games (1+ mpuz-nb-completed-games))
- (mpuz-paint-statistics)
- (let ((message (mpuz-congratulate)))
- (message message)
- (sit-for 4)
- (if (y-or-n-p (concat message " Start a new game "))
- (mpuz-start-new-game)
- (message "Good Bye !"))))
-
-(defun mpuz-congratulate ()
- "Build a congratulation message when puzzle is solved."
- (format "Puzzle solved with %d errors. %s"
- mpuz-nb-errors
- (cond ((= mpuz-nb-errors 0) "That's perfect !")
- ((= mpuz-nb-errors 1) "That's very good !")
- ((= mpuz-nb-errors 2) "That's good.")
- ((= mpuz-nb-errors 3) "That's not bad.")
- ((= mpuz-nb-errors 4) "That's not too bad...")
- ((and (>= mpuz-nb-errors 5)
- (< mpuz-nb-errors 10)) "That's bad !")
- ((and (>= mpuz-nb-errors 10)
- (< mpuz-nb-errors 15)) "That's awful.")
- ((>= mpuz-nb-errors 15) "That's not serious."))))
-
-(defun mpuz-show-solution ()
- "Display solution for debugging purposes."
- (interactive)
- (mpuz-switch-to-window)
- (let (digit list)
- (setq digit -1)
- (while (> 10 (setq digit (1+ digit)))
- (or (mpuz-digit-solved-p digit)
- (setq list (cons digit list))))
- (mapcar 'mpuz-correct-guess list)))
-
-;;; End of mult-puzzle
-
diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el
deleted file mode 100644
index 8ced79837d1..00000000000
--- a/lisp/progmodes/compile.el
+++ /dev/null
@@ -1,478 +0,0 @@
-;; Run compiler as inferior of Emacs, and parse its error messages.
-;; Copyright (C) 1985, 1986, 1988, 1989 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-(provide 'compile)
-
-(defvar compilation-error-list nil
- "List of error message descriptors for visiting erring functions.
-Each error descriptor is a list of length two.
-Its car is a marker pointing to an error message.
-Its cadr is a marker pointing to the text of the line the message is about,
- or nil if that is not interesting.
-The value may be t instead of a list;
-this means that the buffer of error messages should be reparsed
-the next time the list of errors is wanted.")
-
-(defvar compilation-old-error-list nil
- "Value of `compilation-error-list' after errors were parsed.")
-
-(defvar compilation-last-error nil
- "List describing the error found by last call to \\[next-error].
-A list of two markers (ERROR-POS CODE-POS),
-pointing to the error message and the erroneous code, respectively.
-CODE-POS can be nil, if the error message has no specific source location.")
-
-(defvar compilation-parse-errors-hook 'compilation-parse-errors
- "Function to call (no args) to parse error messages from a compilation.
-It should read in the source files which have errors
-and set `compilation-error-list' to a list with an element
-for each error message found. See that variable for more info.")
-
-(defvar compilation-error-buffer nil
- "Current compilation buffer for compilation error processing.")
-
-(defvar compilation-parsing-end nil
- "Position of end of buffer when last error messages parsed.")
-
-(defvar compilation-error-message nil
- "Message to print when no more matches for compilation-error-regexp are found")
-
-;; The filename excludes colons to avoid confusion when error message
-;; starts with digits.
-(defvar compilation-error-regexp
- "\\([^ :\n]+\\(: *\\|, line \\|(\\)[0-9]+\\)\\|\\([0-9]+ *of *[^ \n]+\\)\\|\\(\"[^ \n]+\",L[0-9]+\\)"
- "Regular expression for filename/linenumber in error in compilation log.")
-
-(defvar compile-window-height nil
- "*Desired height of compilation window. nil means use Emacs default.")
-
-(defvar compile-command "make -k "
- "Last shell command used to do a compilation; default for next compilation.
-
-Sometimes it is useful for files to supply local values for this variable.
-You might also use mode hooks to specify it in certain modes, like this:
-
- (setq c-mode-hook
- '(lambda () (or (file-exists-p \"makefile\") (file-exists-p \"Makefile\")
- (progn (make-local-variable 'compile-command)
- (setq compile-command
- (concat \"make -k \"
- buffer-file-name))))))")
-
-(defvar compilation-search-path '(nil)
- "List of directories to search for source files named in error messages.
-Elements should be directory names, not file names of directories.
-nil as an element means to try the default directory.")
-
-(defun compile (command)
- "Compile the program including the current buffer. Default: run `make'.
-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 source code that caused it.
-
-To run more than one compilation at once, start one and rename the
-`*compilation*' buffer to some other name. Then start the next one."
- (interactive (list (read-string "Compile command: " compile-command)))
- (setq compile-command command)
- (save-some-buffers nil nil)
- (compile-internal compile-command "No more errors")
- (and compile-window-height
- (= (window-width) (screen-width))
- (enlarge-window (- (- (screen-height) (window-height))
- compile-window-height) nil)))
-
-(defun grep (command-args)
- "Run grep, with user-specified args, and collect output in a buffer.
-While grep runs asynchronously, you can use the \\[next-error] command
-to find the text that grep hits refer to. It is expected that `grep-command'
-has a `-n' flag, so that line numbers are displayed for each match."
- (interactive
- (list (read-string (concat "Run "
- (substring grep-command 0
- (string-match "[\t ]+" grep-command))
- " (with args): ")
- (progn
- (string-match "-n[\t ]+" grep-command)
- (substring grep-command (match-end 0))))))
- ;; why a redundant string-match? It might not be interactive ...
- (setq grep-command (concat (substring grep-command 0
- (progn
- (string-match "-n" grep-command)
- (match-end 0)))
- " " command-args))
- (compile-internal (concat grep-command " /dev/null")
- "No more grep hits" "grep"))
-
-(defun compile-internal (command error-message
- &optional name-of-mode parser regexp)
- "Run compilation command COMMAND (low level interface).
-ERROR-MESSAGE is a string to print if the user asks to see another error
-and there are no more errors. Third argument NAME-OF-MODE is the name
-to display as the major mode in the `*compilation*' buffer.
-
-Fourth arg PARSER is the error parser function (nil means the default).
-Fifth arg REGEXP is the error message regexp to use (nil means the default).
-The defaults for these variables are the global values of
- `compilation-parse-errors-hook' and `compilation-error-regexp'."
- (save-excursion
- (set-buffer (get-buffer-create "*compilation*"))
- (setq buffer-read-only nil)
- (let ((comp-proc (get-buffer-process (current-buffer))))
- (if comp-proc
- (if (or (not (eq (process-status comp-proc) 'run))
- (yes-or-no-p "A compilation process is running; kill it? "))
- (condition-case ()
- (progn
- (interrupt-process comp-proc)
- (sit-for 1)
- (delete-process comp-proc))
- (error nil))
- (error "Cannot have two processes in `*compilation*' at once"))))
- ;; In case *compilation* is current buffer,
- ;; make sure we get the global values of compilation-error-regexp, etc.
- (kill-all-local-variables))
- (compilation-forget-errors)
- (start-process-shell-command "compilation" "*compilation*" command)
- (with-output-to-temp-buffer "*compilation*"
- (princ "cd ")
- (princ default-directory)
- (terpri)
- (princ command)
- (terpri))
- (let* ((regexp (or regexp compilation-error-regexp))
- (parser (or parser compilation-parse-errors-hook))
- (thisdir default-directory)
- (outbuf (get-buffer "*compilation*"))
- (outwin (get-buffer-window outbuf)))
- (if (eq outbuf (current-buffer))
- (goto-char (point-max)))
- (set-process-sentinel (get-buffer-process outbuf)
- 'compilation-sentinel)
- (save-excursion
- (set-buffer outbuf)
- (if (or (eq compilation-error-buffer outbuf)
- (eq compilation-error-list t)
- (and (null compilation-error-list)
- (not (and (get-buffer-process compilation-error-buffer)
- (eq (process-status compilation-error-buffer)
- 'run)))))
- (setq compilation-error-list t
- compilation-error-buffer outbuf))
- (setq default-directory thisdir)
- (compilation-mode)
- (set-window-start outwin (point-min))
- (setq mode-name (or name-of-mode "Compilation"))
- (setq buffer-read-only t)
- (or (eq outwin (selected-window))
- (set-window-point outwin (point-min))))))
-
-(defvar compilation-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map "\C-c\C-c" 'compile-goto-error)
- map)
- "Keymap for compilation log buffers.")
-
-(defun compilation-mode ()
- "Major mode for compilation log buffers.
-\\<compilation-mode-map>To visit the source for a line-numbered error,
-move point to the error message line and type \\[compile-goto-error]."
- (interactive)
- (fundamental-mode)
- (use-local-map compilation-mode-map)
- (make-local-variable 'compilation-parse-errors-hook)
- (setq compilation-parse-errors-hook parser)
- (make-local-variable 'compilation-error-message)
- (setq compilation-error-message error-message)
- (make-local-variable 'compilation-error-regexp)
- (setq compilation-error-regexp regexp)
- (buffer-disable-undo (current-buffer))
- (setq major-mode 'compilation-mode)
- (setq mode-name "Compilation")
- ;; Make log buffer's mode line show process state
- (setq mode-line-process '(": %s")))
-
-;; Called when compilation process changes state.
-
-(defun compilation-sentinel (proc msg)
- (cond ((null (buffer-name (process-buffer proc)))
- ;; buffer killed
- (set-process-buffer proc nil))
- ((memq (process-status proc) '(signal exit))
- (let* ((obuf (current-buffer))
- omax opoint)
- ;; save-excursion isn't the right thing if
- ;; process-buffer is current-buffer
- (unwind-protect
- (progn
- ;; Write something in *compilation* and hack its mode line,
- (set-buffer (process-buffer proc))
- (setq omax (point-max) opoint (point))
- (goto-char (point-max))
- (insert ?\n mode-name " " msg)
- (forward-char -1)
- (insert " at " (substring (current-time-string) 0 19))
- (forward-char 1)
- (setq mode-line-process
- (concat ": "
- (symbol-name (process-status proc))))
- ;; If buffer and mode line will show that the process
- ;; is dead, we can delete it now. Otherwise it
- ;; will stay around until M-x list-processes.
- (delete-process proc))
- ;; Force mode line redisplay soon
- (set-buffer-modified-p (buffer-modified-p)))
- (if (and opoint (< opoint omax))
- (goto-char opoint))
- (set-buffer obuf)))))
-
-(defun kill-compilation ()
- "Kill the process made by the \\[compile] command."
- (interactive)
- (let ((buffer
- (if (assq 'compilation-parse-errors-hook (buffer-local-variables))
- (current-buffer)
- (get-buffer "*compilation*"))))
- (if (get-buffer-process buffer)
- (interrupt-process (get-buffer-process buffer)))))
-
-;; Reparse errors or parse more/new errors, if appropriate.
-(defun compile-reinitialize-errors (argp)
- ;; If we are out of errors, or if user says "reparse",
- ;; or if we are in a different buffer from the known errors,
- ;; discard the info we have, to force reparsing.
- (if (or (eq compilation-error-list t)
- (consp argp)
- (if (assq 'compilation-parse-errors-hook (buffer-local-variables))
- (not (eq compilation-error-buffer
- (setq compilation-error-buffer (current-buffer))))))
- (progn (compilation-forget-errors)
- (setq compilation-parsing-end 1)))
- (if compilation-error-list
- nil
- (save-excursion
- (switch-to-buffer compilation-error-buffer)
- (set-buffer-modified-p nil)
- (let ((at-start (= compilation-parsing-end 1)))
- (run-hooks 'compilation-parse-errors-hook)
- ;; Remember the entire list for compilation-forget-errors.
- ;; If this is an incremental parse, append to previous list.
- (if at-start
- (setq compilation-old-error-list compilation-error-list)
- (setq compilation-old-error-list
- (nconc compilation-old-error-list compilation-error-list)))))))
-
-(defun compile-goto-error (&optional argp)
- "Visit the source for the error message point is on.
-Use this command in a compilation log buffer.
-C-u as a prefix arg means to reparse the buffer's error messages first;
-other kinds of prefix arguments are ignored."
- (interactive "P")
- (compile-reinitialize-errors argp)
- (save-excursion
- (beginning-of-line)
- (setq compilation-error-list
- (memq (assoc (point-marker) compilation-old-error-list)
- compilation-old-error-list)))
- ;; Move to another window, so that next-error's window changes
- ;; result in the desired setup.
- (or (one-window-p)
- (other-window -1))
- (next-error 1))
-
-(defun next-error (&optional argp)
- "Visit next compilation error message and corresponding source code.
-This operates on the output from the \\[compile] command.
-If all preparsed error messages have been processed,
-the error message buffer is checked for new ones.
-
-A prefix arg specifies how many error messages to move;
-negative means move back to previous error messages.
-Just C-u as a prefix means reparse the error message buffer
-and start at the first error.
-
-\\[next-error] normally applies to the most recent compilation started,
-but as long as you are in the middle of parsing errors from one compilation
-output buffer, you stay with that compilation output buffer.
-
-Use \\[next-error] in a compilation output buffer to switch to
-processing errors from that compilation.
-
-See variables `compilation-parse-errors-hook' and `compilation-error-regexp'
-for customization ideas. When we return, `compilation-last-error'
-points to the error message and the erroneous code."
- (interactive "P")
- (compile-reinitialize-errors argp)
- (if (consp argp)
- (setq argp nil))
- (let* ((next-errors (nthcdr (+ (- (length compilation-old-error-list)
- (length compilation-error-list)
- 1)
- (prefix-numeric-value argp))
- compilation-old-error-list))
- (next-error (car next-errors)))
- (if (null next-error)
- (save-excursion
- (if argp (if (> (prefix-numeric-value argp) 0)
- (error "Moved past last error")
- (error "Moved back past first error")))
- (set-buffer compilation-error-buffer)
- (compilation-forget-errors)
- (error (concat compilation-error-message
- (if (and (get-buffer-process (current-buffer))
- (eq (process-status (current-buffer))
- 'run))
- " yet" "")))))
- (setq compilation-error-list (cdr next-errors))
- ;; If we have an error to go to, go there.
- (if (null (car (cdr next-error)))
- nil
- (switch-to-buffer (marker-buffer (car (cdr next-error))))
- (goto-char (car (cdr next-error)))
- ;; If narrowing got in the way of going to the right place, widen.
- (or (= (point) (car (cdr next-error)))
- (progn
- (widen)
- (goto-char (car (cdr next-error))))))
- ;; Show compilation buffer in other window, scrolled to this error.
- (let* ((pop-up-windows t)
- (w (display-buffer (marker-buffer (car next-error)))))
- (set-window-point w (car next-error))
- (set-window-start w (car next-error)))
- (setq compilation-last-error next-error)))
-
-;; Set compilation-error-list to nil, and
-;; unchain the markers that point to the error messages and their text,
-;; so that they no longer slow down gap motion.
-;; This would happen anyway at the next garbage collection,
-;; but it is better to do it right away.
-(defun compilation-forget-errors ()
- (while compilation-old-error-list
- (let ((next-error (car compilation-old-error-list)))
- (set-marker (car next-error) nil)
- (if (car (cdr next-error))
- (set-marker (car (cdr next-error)) nil)))
- (setq compilation-old-error-list (cdr compilation-old-error-list)))
- (setq compilation-error-list nil))
-
-(defun compilation-parse-errors ()
- "Parse the current buffer as grep, cc or lint error messages.
-See variable `compilation-parse-errors-hook' for the interface it uses."
- (setq compilation-error-list nil)
- (message "Parsing error messages...")
- (let (text-buffer
- last-filename last-linenum)
- ;; Don't reparse messages already seen at last parse.
- (goto-char compilation-parsing-end)
- ;; Don't parse the first two lines as error messages.
- ;; This matters for grep.
- (if (bobp)
- (forward-line 2))
- (while (re-search-forward compilation-error-regexp nil t)
- (let (linenum filename
- error-marker text-marker)
- ;; Extract file name and line number from error message.
- (save-restriction
- (narrow-to-region (match-beginning 0) (match-end 0))
- (goto-char (point-max))
- (skip-chars-backward "[0-9]")
- ;; If it's a lint message, use the last file(linenum) on the line.
- ;; Normally we use the first on the line.
- (if (= (preceding-char) ?\()
- (progn
- (narrow-to-region (point-min) (1+ (buffer-size)))
- (end-of-line)
- (re-search-backward compilation-error-regexp)
- (skip-chars-backward "^ \t\n")
- (narrow-to-region (point) (match-end 0))
- (goto-char (point-max))
- (skip-chars-backward "[0-9]")))
- ;; Are we looking at a "filename-first" or "line-number-first" form?
- (if (looking-at "[0-9]")
- (progn
- (setq linenum (read (current-buffer)))
- (goto-char (point-min)))
- ;; Line number at start, file name at end.
- (progn
- (goto-char (point-min))
- (setq linenum (read (current-buffer)))
- (goto-char (point-max))
- (skip-chars-backward "^ \t\n")))
- (setq filename (compilation-grab-filename)))
- ;; Locate the erring file and line.
- (if (and (equal filename last-filename)
- (= linenum last-linenum))
- nil
- (beginning-of-line 1)
- (setq error-marker (point-marker))
- ;; text-buffer gets the buffer containing this error's file.
- (if (not (equal filename last-filename))
- (setq last-filename filename
- text-buffer (compilation-find-file filename)
- last-linenum 0))
- (if text-buffer
- ;; Go to that buffer and find the erring line.
- (save-excursion
- (set-buffer text-buffer)
- (if (zerop last-linenum)
- (progn
- (goto-char 1)
- (setq last-linenum 1)))
- (forward-line (- linenum last-linenum))
- (setq last-linenum linenum)
- (setq text-marker (point-marker))
- (setq compilation-error-list
- (cons (list error-marker text-marker)
- compilation-error-list)))))
- (forward-line 1)))
- (setq compilation-parsing-end (point-max)))
- (message "Parsing error messages...done")
- (setq compilation-error-list (nreverse compilation-error-list)))
-
-;; Find or create a buffer for file FILENAME.
-;; Search the directories in compilation-search-path
-;; after trying the current directory.
-(defun compilation-find-file (filename)
- (let ((dirs compilation-search-path)
- result)
- (while (and dirs (null result))
- (let ((name (if (car dirs)
- (concat (car dirs) filename)
- filename)))
- (setq result
- (and (file-exists-p name)
- (find-file-noselect name))))
- (setq dirs (cdr dirs)))
- result))
-
-(defun compilation-grab-filename ()
- "Return a string which is a filename, starting at point.
-Ignore quotes and parentheses around it, as well as trailing colons."
- (if (eq (following-char) ?\")
- (save-restriction
- (narrow-to-region (point)
- (progn (forward-sexp 1) (point)))
- (goto-char (point-min))
- (read (current-buffer)))
- (buffer-substring (point)
- (progn
- (skip-chars-forward "^ :,\n\t(")
- (point)))))
-
-(define-key ctl-x-map "`" 'next-error)
diff --git a/lisp/progmodes/prolog.el b/lisp/prolog.el
index 2ca899a59d0..10903e1fcab 100644
--- a/lisp/progmodes/prolog.el
+++ b/lisp/prolog.el
@@ -22,9 +22,6 @@
(defvar prolog-mode-abbrev-table nil)
(defvar prolog-mode-map nil)
-(defvar prolog-program-name "prolog"
- "*Program name for invoking an inferior Prolog with `run-prolog'.")
-
(defvar prolog-consult-string "reconsult(user).\n"
"*(Re)Consult mode (for C-Prolog and Quintus Prolog). ")
@@ -179,8 +176,7 @@ rigidly along with this one (not yet)."
(t
(save-excursion
(skip-chars-backward " \t")
- ;; Insert one space at least, except at left margin.
- (max (+ (current-column) (if (bolp) 0 1))
+ (max (1+ (current-column)) ;Insert one space at least
comment-column)))
))
@@ -190,6 +186,12 @@ rigidly along with this one (not yet)."
;;;
(defvar inferior-prolog-mode-map nil)
+;; Moved into inferior-prolog-mode
+;;(if inferior-prolog-mode-map
+;; nil
+;; (setq inferior-prolog-mode-map (copy-alist shell-mode-map))
+;; (prolog-mode-commands inferior-prolog-mode-map))
+
(defun inferior-prolog-mode ()
"Major mode for interacting with an inferior Prolog process.
@@ -197,8 +199,8 @@ 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.
+if that value is non-nil. Likewise with the value of shell-mode-hook.
+prolog-mode-hook is called after shell-mode-hook.
You can send text to the inferior Prolog from other buffers
using the commands send-region, send-string and \\[prolog-consult-region].
@@ -210,27 +212,35 @@ 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."
+\\[shell-send-eof] sends end-of-file as input.
+\\[kill-shell-input] and \\[backward-kill-word] are kill commands, imitating normal Unix input editing.
+\\[interrupt-shell-subjob] interrupts the shell or its current subjob if any.
+\\[stop-shell-subjob] stops, likewise. \\[quit-shell-subjob] sends quit signal, likewise."
(interactive)
- (require 'comint)
- (comint-mode)
- (setq major-mode 'inferior-prolog-mode
- mode-name "Inferior Prolog"
- comint-prompt-regexp "^| [ ?][- ] *")
+ (kill-all-local-variables)
+ (setq major-mode 'inferior-prolog-mode)
+ (setq mode-name "Inferior Prolog")
+ (setq mode-line-process '(": %s"))
(prolog-mode-variables)
- (if inferior-prolog-mode-map nil
- (setq inferior-prolog-mode-map (copy-keymap comint-mode-map))
+ (require 'shell)
+ (if inferior-prolog-mode-map
+ nil
+ (setq inferior-prolog-mode-map (copy-alist shell-mode-map))
(prolog-mode-commands inferior-prolog-mode-map))
(use-local-map inferior-prolog-mode-map)
- (run-hooks 'prolog-mode-hook))
+ (make-local-variable 'last-input-start)
+ (setq last-input-start (make-marker))
+ (make-local-variable 'last-input-end)
+ (setq last-input-end (make-marker))
+ (make-variable-buffer-local 'shell-prompt-pattern)
+ (setq shell-prompt-pattern "^| [ ?][- ] *") ;Set prolog prompt pattern
+ (run-hooks 'shell-mode-hook 'prolog-mode-hook))
(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))
+ (require 'shell)
+ (switch-to-buffer (make-shell "prolog" "prolog"))
(inferior-prolog-mode))
(defun prolog-consult-region (compile beg end)
diff --git a/lisp/prolog.elc b/lisp/prolog.elc
new file mode 100644
index 00000000000..e87c1b23ee0
--- /dev/null
+++ b/lisp/prolog.elc
Binary files differ
diff --git a/lisp/rect.el b/lisp/rect.el
index 3dd06f1be0e..e79b193211c 100644
--- a/lisp/rect.el
+++ b/lisp/rect.el
@@ -111,9 +111,8 @@ and ending with the line where the region ends."
(operate-on-rectangle 'delete-rectangle-line start end t))
(defun delete-extract-rectangle (start end)
- "Delete contents of rectangle and return it as a list of strings.
-Arguments START and END are the corners of the rectangle.
-The value is list of strings, one for each line of the rectangle."
+ "Return and delete contents of rectangle with corners at START and END.
+Value is list of strings, one for each line of the rectangle."
(let (lines)
(operate-on-rectangle 'delete-extract-rectangle-line
start end t)
@@ -181,10 +180,9 @@ but insted winds up to the right of the rectangle."
(point)))
(indent-to column)))
-(defun clear-rectangle (start end)
+(defun clear-rectangle (start end &optional preserve-position)
"Blank out rectangle with corners at point and mark.
-The text previously in the region is overwritten by the blanks.
-When called from a program, requires two args which specify the corners."
+The text previously in the region is overwritten by the blanks."
(interactive "r")
(operate-on-rectangle 'clear-rectangle-line start end t))
@@ -193,7 +191,8 @@ When called from a program, requires two args which specify the corners."
(let ((column (+ (current-column) endextra)))
(delete-region (point)
(progn (goto-char startpos)
- (skip-chars-backward " \t")
+ (or preserve-position
+ (skip-chars-backward " \t"))
(point)))
(indent-to column)))
diff --git a/lisp/rect.elc b/lisp/rect.elc
new file mode 100644
index 00000000000..d6366fb8d57
--- /dev/null
+++ b/lisp/rect.elc
Binary files differ
diff --git a/lisp/register.el b/lisp/register.el
index fd901f99f4a..ead49c35540 100644
--- a/lisp/register.el
+++ b/lisp/register.el
@@ -21,45 +21,36 @@
(defvar register-alist nil
"Alist of elements (NAME . CONTENTS), one for each Emacs register.
NAME is a character (a number). CONTENTS is a string, number,
-screen configuration, mark or list.
-A list represents a rectangle; its elements are strings.")
+mark or list. A list represents a rectangle; its elements are strings.")
(defun get-register (char)
"Return contents of Emacs register named CHAR, or nil if none."
(cdr (assq char register-alist)))
(defun set-register (char value)
- "Set contents of Emacs register named CHAR to VALUE.
-Returns VALUE."
+ "Set contents of Emacs register named CHAR to VALUE."
(let ((aelt (assq char register-alist)))
(if aelt
(setcdr aelt value)
(setq aelt (cons char value))
- (setq register-alist (cons aelt register-alist)))
- value))
+ (setq register-alist (cons aelt register-alist)))))
-(defun point-to-register (char arg)
- "Store current location of point in register REGISTER.
-With prefix argument, store current screen configuration.
-Use \\[jump-to-register] to go to that location or restore that configuration.
+(defun point-to-register (char)
+ "Store current location of point in a register.
Argument is a character, naming the register."
- (interactive "cPoint to register: \nP")
- (set-register char (if arg (current-screen-configuration) (point-marker))))
+ (interactive "cPoint to register: ")
+ (set-register char (point-marker)))
-(fset 'register-to-point 'jump-to-register)
-(defun jump-to-register (char)
+(defun register-to-point (char)
"Move point to location stored in a register.
Argument is a character, naming the register."
- (interactive "cJump to register: ")
+ (interactive "cRegister to point: ")
(let ((val (get-register char)))
- (condition-case ()
- (set-screen-configuration val)
- (error
- (if (markerp val)
- (progn
- (switch-to-buffer (marker-buffer val))
- (goto-char val))
- (error "Register doesn't contain a buffer position or screen configuration"))))))
+ (if (markerp val)
+ (progn
+ (switch-to-buffer (marker-buffer val))
+ (goto-char val))
+ (error "Register doesn't contain a buffer position"))))
;(defun number-to-register (arg char)
; "Store a number in a register.
@@ -133,7 +124,7 @@ Interactively, second arg is non-nil if prefix arg is supplied."
(if (or (integerp val) (markerp val))
(princ (+ 0 val) (current-buffer))
(error "Register does not contain text")))))
- (if (not arg) (exchange-point-and-mark)))
+ (or arg (exchange-point-and-mark)))
(defun copy-to-register (char start end &optional delete-flag)
"Copy region into register REG.
diff --git a/lisp/register.elc b/lisp/register.elc
new file mode 100644
index 00000000000..679adffb4c5
--- /dev/null
+++ b/lisp/register.elc
Binary files differ
diff --git a/lisp/replace.el b/lisp/replace.el
index fabcd11a554..6bbcde4e8b6 100644
--- a/lisp/replace.el
+++ b/lisp/replace.el
@@ -38,10 +38,7 @@ Applies to all lines after point."
(if (< start end)
(delete-region start end))))
(setq start (save-excursion (forward-line 1)
- (point)))
- ;; If the match was empty, avoid matching again at same place.
- (and (not (eobp)) (= (match-beginning 0) (match-end 0))
- (forward-char 1))))))
+ (point)))))))
(fset 'delete-matching-lines 'flush-lines)
(defun flush-lines (regexp)
@@ -61,14 +58,15 @@ Applies to lines after point."
(defun how-many (regexp)
"Print number of matches for REGEXP following point."
(interactive "sHow many matches for (regexp): ")
- (let ((count 0) opoint)
+ (let ((count 0) (opoint -1))
(save-excursion
- (while (and (not (eobp))
- (progn (setq opoint (point))
- (re-search-forward regexp nil t)))
- (if (= opoint (point))
- (forward-char 1)
- (setq count (1+ count))))
+ ;; If we did forward-char on the previous loop,
+ ;; and that brought us to eof, search anyway.
+ (while (and (or (not (eobp)) (/= opoint (point)))
+ (re-search-forward regexp nil t))
+ (if (prog1 (= opoint (point)) (setq opoint (point)))
+ (forward-char 1)
+ (setq count (1+ count))))
(message "%d occurrences" count))))
(defvar occur-mode-map ())
@@ -80,7 +78,6 @@ Applies to lines after point."
(defvar occur-buffer nil)
(defvar occur-nlines nil)
(defvar occur-pos-list nil)
-(defvar occur-last-string "")
(defun occur-mode ()
"Major mode for output from \\[occur].
@@ -104,18 +101,15 @@ in the buffer that the occurrences were found in.
(progn
(setq occur-buffer nil
occur-pos-list nil)
- (error "Buffer in which occurrences were found is deleted")))
+ (error "Buffer in which occurences were found is deleted.")))
(let* ((occur-number (save-excursion
- (beginning-of-line)
- (/ (1- (count-lines (point-min)
- (save-excursion
- (beginning-of-line)
- (point))))
- (cond ((< occur-nlines 0)
- (- 2 occur-nlines))
- ((> occur-nlines 0)
- (+ 2 (* 2 occur-nlines)))
- (t 1)))))
+ (beginning-of-line)
+ (/ (1- (count-lines (point-min) (point)))
+ (cond ((< occur-nlines 0)
+ (- 2 occur-nlines))
+ ((> occur-nlines 0)
+ (+ 2 (* 2 occur-nlines)))
+ (t 1)))))
(pos (nth occur-number occur-pos-list)))
(pop-to-buffer occur-buffer)
(goto-char (marker-position pos))))
@@ -125,41 +119,27 @@ in the buffer that the occurrences were found in.
match. A negative number means to include that many lines before the match.
A positive number means to include that many lines both before and after.")
-(defvar occur-whole-buffer nil
- "If t, occur operates on whole buffer, otherwise occur starts from point.
-default is nil.")
-
(fset 'list-matching-lines 'occur)
-
(defun occur (regexp &optional nlines)
- "Show lines containing a match for REGEXP. If the global variable
-occur-whole-buffer is non-nil, the entire buffer is searched, otherwise
-search begins at point. Interactively, REGEXP defaults to the last REGEXP
-used interactively.
-
-Each line is displayed with NLINES lines before and after,
-or -NLINES before if NLINES is negative.
+ "Show all lines following point containing a match for REGEXP.
+Display each line with NLINES lines before and after,
+ or -NLINES before if NLINES is negative.
NLINES defaults to list-matching-lines-default-context-lines.
Interactively it is the prefix arg.
The lines are shown in a buffer named *Occur*.
It serves as a menu to find any of the occurrences in this buffer.
\\[describe-mode] in that buffer will explain how."
- (interactive (list (setq occur-last-string
- (read-string "List lines matching regexp: "
- occur-last-string))
- current-prefix-arg))
+ (interactive "sList lines matching regexp: \nP")
(setq nlines (if nlines (prefix-numeric-value nlines)
list-matching-lines-default-context-lines))
(let ((first t)
(buffer (current-buffer))
- (linenum 1)
- (prevpos (point-min)))
- (if (not occur-whole-buffer)
- (save-excursion
- (beginning-of-line)
- (setq linenum (1+ (count-lines (point-min) (point))))
- (setq prevpos (point))))
+ linenum prevpos)
+ (save-excursion
+ (beginning-of-line)
+ (setq linenum (1+ (count-lines (point-min) (point))))
+ (setq prevpos (point)))
(with-output-to-temp-buffer "*Occur*"
(save-excursion
(set-buffer standard-output)
@@ -173,14 +153,13 @@ It serves as a menu to find any of the occurrences in this buffer.
(if (eq buffer standard-output)
(goto-char (point-max)))
(save-excursion
- (if occur-whole-buffer
- (beginning-of-buffer))
;; Find next match, but give up if prev match was at end of buffer.
(while (and (not (= prevpos (point-max)))
(re-search-forward regexp nil t))
- (beginning-of-line)
- (setq linenum (+ linenum (count-lines prevpos (point))))
- (setq prevpos (point))
+ (beginning-of-line 1)
+ (save-excursion
+ (setq linenum (+ linenum (count-lines prevpos (point))))
+ (setq prevpos (point)))
(let* ((start (save-excursion
(forward-line (if (< nlines 0) nlines (- nlines)))
(point)))
@@ -228,34 +207,21 @@ C-r to enter recursive edit (\\[exit-recursive-edit] to get out again),
C-w to delete match and recursive edit,
C-l to clear the screen, redisplay, and offer same replacement again,
! to replace all remaining matches with no more questions,
-^ to move point back to previous match."
+^ to move point back to previous match.
+
+Type a Space now to remove this message."
"Help message while in query-replace")
-(defun perform-replace (from-string replacements
- query-flag regexp-flag delimited-flag
- &optional repeat-count)
- "Subroutine of `query-replace'. Its complexity handles interactive queries.
-Don't use this in your own program unless you want to query and set the mark
-just as `query-replace' does. Instead, write a simple loop like this:
- (while (re-search-forward \"foo[ \t]+bar\" nil t)
- (replace-match \"foobar\" nil nil))
-which will run faster and do exactly what you probably want."
+(defun perform-replace (from-string to-string
+ query-flag regexp-flag delimited-flag)
(let ((nocasify (not (and case-fold-search case-replace
(string-equal from-string
(downcase from-string)))))
(literal (not regexp-flag))
(search-function (if regexp-flag 're-search-forward 'search-forward))
(search-string from-string)
- (next-replacement nil)
- (replacement-index 0)
(keep-going t)
- (stack nil)
- (next-rotate-count 0)
- (replace-count 0)
(lastrepl nil)) ;Position after last match considered.
- (if (stringp replacements)
- (setq next-replacement replacements)
- (or repeat-count (setq repeat-count 1)))
(if delimited-flag
(setq search-function 're-search-forward
search-string (concat "\\b"
@@ -263,137 +229,82 @@ which will run faster and do exactly what you probably want."
(regexp-quote from-string))
"\\b")))
(push-mark)
- (undo-boundary)
+ (push-mark)
(while (and keep-going
(not (eobp))
- (funcall search-function search-string nil t)
- (if (eq lastrepl (point))
- (progn
- ;; Don't replace the null string
- ;; right after end of previous replacement.
- (forward-char 1)
- (funcall search-function search-string nil t))
- t))
- ;; If time for a change, advance to next replacement string.
- (if (and (listp replacements)
- (= next-rotate-count replace-count))
- (progn
- (setq next-rotate-count
- (+ next-rotate-count repeat-count))
- (setq next-replacement (nth replacement-index replacements))
- (setq replacement-index (% (1+ replacement-index) (length replacements)))))
- (if (not query-flag)
- (progn
- (replace-match next-replacement nocasify literal)
- (setq replace-count (1+ replace-count)))
+ (progn
+ (set-mark (point))
+ (funcall search-function search-string nil t)))
+ ;; Don't replace the null string
+ ;; right after end of previous replacement.
+ (if (eq lastrepl (point))
+ (forward-char 1)
(undo-boundary)
- (let (done replaced)
- (while (not done)
- ;; Preserve the match data. Process filters and sentinels
- ;; could run inside read-char..
- (let ((data (match-data))
- (help-form
- '(concat "Query replacing "
- (if regexp-flag "regexp " "")
- from-string " with " next-replacement ".\n\n"
- (substitute-command-keys query-replace-help))))
- (setq char help-char)
- (while (or (not (numberp char)) (= char help-char))
- (message "Query replacing %s with %s: " from-string next-replacement)
- (setq char (read-event))
- (if (and (numberp char) (= char ??))
- (setq unread-command-char help-char char help-char)))
- (store-match-data data))
- (cond ((or (= char ?\e)
- (= char ?q))
- (setq keep-going nil)
- (setq done t))
- ((= char ?^)
- (let ((elt (car stack)))
- (goto-char (car elt))
- (setq replaced (eq t (cdr elt)))
+ (if (not query-flag)
+ (replace-match to-string nocasify literal)
+ (let (done replaced)
+ (while (not done)
+ ;; Preserve the match data. Process filters and sentinels
+ ;; could run inside read-char..
+ (let ((data (match-data))
+ (help-form
+ '(concat "Query replacing "
+ (if regexp-flag "regexp " "")
+ from-string " with " to-string ".\n\n"
+ (substitute-command-keys query-replace-help))))
+ (setq char help-char)
+ (while (= char help-char)
+ (message "Query replacing %s with %s: " from-string to-string)
+ (setq char (read-char))
+ (if (= char ??)
+ (setq unread-command-char help-char char help-char)))
+ (store-match-data data))
+ (cond ((or (= char ?\e)
+ (= char ?q))
+ (setq keep-going nil)
+ (setq done t))
+ ((= char ?^)
+ (goto-char (mark))
+ (setq replaced t))
+ ((or (= char ?\ )
+ (= char ?y))
(or replaced
- (store-match-data (cdr elt)))
- (setq stack (cdr stack))))
- ((or (= char ?\ )
- (= char ?y))
- (or replaced
- (replace-match next-replacement nocasify literal))
- (setq done t replaced t))
- ((= char ?\.)
- (or replaced
- (replace-match next-replacement nocasify literal))
- (setq keep-going nil)
- (setq done t replaced t))
- ((= char ?\,)
- (if (not replaced)
- (progn
- (replace-match next-replacement nocasify literal)
- (setq replaced t))))
- ((= char ?!)
- (or replaced
- (replace-match next-replacement nocasify literal))
- (setq done t query-flag nil replaced t))
- ((or (= char ?\177)
- (= char ?n))
- (setq done t))
- ((= char ?\C-l)
- (recenter nil))
- ((= char ?\C-r)
- (store-match-data
- (prog1 (match-data)
- (save-excursion (recursive-edit)))))
- ((= char ?\C-w)
- (delete-region (match-beginning 0) (match-end 0))
- (store-match-data
- (prog1 (match-data)
- (save-excursion (recursive-edit))))
- (setq replaced t))
- (t
- (setq keep-going nil)
- (setq unread-command-char char)
- (setq done t))))
- ;; Record previous position for ^ when we move on.
- ;; Change markers to numbers in the match data
- ;; since lots of markers slow down editing.
- (setq stack
- (cons (cons (point)
- (or replaced
- (mapcar
- (function (lambda (elt)
- (and elt
- (marker-position elt))))
- (match-data))))
- stack))
- (if replaced (setq replace-count (1+ replace-count)))))
- (setq lastrepl (point)))
- (and keep-going stack)))
-
-(defun map-query-replace-regexp (regexp to-strings &optional arg)
- "Replace some matches for REGEXP with various strings, in rotation.
-The second argument TO-STRINGS contains the replacement strings, separated
-by spaces. This command works like `query-replace-regexp' except
-that each successive replacement uses the next successive replacement string,
-wrapping around from the last such string to the first.
-
-Non-interactively, TO-STRINGS may be a list of replacement strings.
-
-A prefix argument N says to use each replacement string N times
-before rotating to the next."
- (interactive "sMap query replace (regexp): \nsQuery replace %s with (space-separated strings): \nP")
- (let (replacements)
- (if (listp to-strings)
- (setq replacements to-strings)
- (while (/= (length to-strings) 0)
- (if (string-match " " to-strings)
- (setq replacements
- (append replacements
- (list (substring to-strings 0
- (string-match " " to-strings))))
- to-strings (substring to-strings
- (1+ (string-match " " to-strings))))
- (setq replacements (append replacements (list to-strings))
- to-strings ""))))
- (perform-replace regexp replacements t t nil arg))
- (message "Done"))
+ (replace-match to-string nocasify literal))
+ (setq done t))
+ ((= char ?\.)
+ (or replaced
+ (replace-match to-string nocasify literal))
+ (setq keep-going nil)
+ (setq done t))
+ ((= char ?\,)
+ (if (not replaced)
+ (progn
+ (replace-match to-string nocasify literal)
+ (setq replaced t))))
+ ((= char ?!)
+ (or replaced
+ (replace-match to-string nocasify literal))
+ (setq done t query-flag nil))
+ ((or (= char ?\177)
+ (= char ?n))
+ (setq done t))
+ ((= char ?\C-l)
+ (recenter nil))
+ ((= char ?\C-r)
+ (store-match-data
+ (prog1 (match-data)
+ (save-excursion (recursive-edit)))))
+ ((= char ?\C-w)
+ (delete-region (match-beginning 0) (match-end 0))
+ (store-match-data
+ (prog1 (match-data)
+ (save-excursion (recursive-edit))))
+ (setq replaced t))
+ (t
+ (setq keep-going nil)
+ (setq unread-command-char char)
+ (setq done t))))))
+ (setq lastrepl (point))))
+ (pop-mark)
+ keep-going))
diff --git a/lisp/replace.elc b/lisp/replace.elc
new file mode 100644
index 00000000000..0b60b47d117
--- /dev/null
+++ b/lisp/replace.elc
Binary files differ
diff --git a/lisp/reposition.el b/lisp/reposition.el
deleted file mode 100644
index 104021a4432..00000000000
--- a/lisp/reposition.el
+++ /dev/null
@@ -1,185 +0,0 @@
-;;; -*- Mode: Emacs-lisp -*-
-;; Copyright (C) 1991 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;;; Written by Michael D. Ernst, mernst@theory.lcs.mit.edu, Jan 1991.
-
-;;; Reposition-window makes an entire function definition or comment visible,
-;;; or, if it is already visible, places it at the top of the window;
-;;; additional invocations toggle the visibility of comments preceding the
-;;; code. For the gory details, see the documentation for reposition-window;
-;;; rather than reading that, you may just want to play with it.
-
-;;; This tries pretty hard to do the recentering correctly; the precise
-;;; action depends on what the buffer looks like. If you find a situation
-;;; where it doesn't behave well, let me know. This function is modeled
-;;; after one of the same name in ZMACS, but the code is all-new and the
-;;; behavior in some situations differs.
-
-(defun reposition-window (&optional arg)
- "Make the current definition and/or comment visible.
-Further invocations move it to the top of the window or toggle the
-visibility of comments that precede it.
- Point is left unchanged unless prefix ARG is supplied.
- If the definition is fully onscreen, it is moved to the top of the
-window. If it is partly offscreen, the window is scrolled to get the
-definition (or as much as will fit) onscreen, unless point is in a comment
-which is also partly offscreen, in which case the scrolling attempts to get
-as much of the comment onscreen as possible.
- Initially `reposition-window' attempts to make both the definition and
-preceding comments visible. Further invocations toggle the visibility of
-the comment lines.
- If ARG is non-nil, point may move in order to make the whole defun
-visible (if only part could otherwise be made so), to make the defun line
-visible (if point is in code and it could not be made so, or if only
-comments, including the first comment line, are visible), or to make the
-first comment line visible (if point is in a comment)."
- (interactive "P")
- (let* (;; (here (save-excursion (beginning-of-line) (point)))
- (here (point))
- ;; change this name once I've gotten rid of references to ht.
- ;; this is actually the number of the last screen line
- (ht (- (window-height (selected-window)) 2))
- (line (repos-count-screen-lines (window-start) (point)))
- (comment-height
- ;; The call to max deals with the case of cursor between defuns.
- (max 0
- (repos-count-screen-lines-signed
- ;; the beginning of the preceding comment
- (save-excursion
- (forward-char 1) (end-of-defun -1)
- ;; Skip whitespace, newlines, and form feeds.
- (re-search-forward "[^\\s \n\014]")
- (backward-char 1)
- (point))
- here)))
- (defun-height
- (repos-count-screen-lines-signed
- (save-excursion
- (end-of-defun 1) ; so comments associate with following defuns
- (beginning-of-defun 1)
- (point))
- here))
- ;; This must be positive, so don't use the signed version.
- (defun-depth (repos-count-screen-lines here
- (save-excursion
- (end-of-defun 1)
- (point))))
- (defun-line-onscreen-p
- (and (<= defun-height line)
- (<= (- line defun-height) ht))))
- (cond ((or (= comment-height line)
- (and (= line ht)
- (> comment-height line)
- ;; if defun line offscreen, we should be in case 4
- defun-line-onscreen-p))
- ;; Either first comment line is at top of screen or (point at
- ;; bottom of screen, defun line onscreen, and first comment line
- ;; off top of screen). That is, it looks like we just did
- ;; recenter-definition, trying to fit as much of the comment
- ;; onscreen as possible. Put defun line at top of screen; that
- ;; is, show as much code, and as few comments, as possible.
-
- (if (and arg (> defun-depth (1+ ht)))
- ;; Can't fit whole defun onscreen without moving point.
- (progn (end-of-defun) (beginning-of-defun) (recenter 0))
- (recenter (max defun-height 0)))
- ;;(repos-debug-macro "1")
- )
-
- ((or (= defun-height line)
- (= line 0)
- (and (< line comment-height)
- (< defun-height 0)))
- ;; Defun line or cursor at top of screen, OR cursor in comment
- ;; whose first line is offscreen.
- ;; Avoid moving definition up even if defun runs offscreen;
- ;; we care more about getting the comment onscreen.
-
- (cond ((= line ht)
- ;; cursor on last screen line (and so in a comment)
- (if arg (progn (end-of-defun) (beginning-of-defun)))
- (recenter 0)
- ;;(repos-debug-macro "2a")
- )
-
- ;; This condition, copied from case 4, may not be quite right
-
- ((and arg (< ht comment-height))
- ;; Can't get first comment line onscreen.
- ;; Go there and try again.
- (forward-line (- comment-height))
- (beginning-of-line)
- ;; was (reposition-window)
- (recenter 0)
- ;;(repos-debug-macro "2b")
- )
- (t
- (recenter (min ht comment-height))
- ;;(repos-debug-macro "2c")
- ))
- ;; (recenter (min ht comment-height))
- )
-
- ((and (> (+ line defun-depth -1) ht)
- defun-line-onscreen-p)
- ;; Defun runs off the bottom of the screen and the defun line
- ;; is onscreen.
- ;; Move the defun up.
- (recenter (max 0 (1+ (- ht defun-depth)) defun-height))
- ;;(repos-debug-macro "3")
- )
-
- (t
- ;; If on the bottom line and comment start is offscreen
- ;; then just move all comments offscreen, or at least as
- ;; far as they'll go.
-
- ;; Try to get as much of the comments onscreen as possible.
- (if (and arg (< ht comment-height))
- ;; Can't get defun line onscreen; go there and try again.
- (progn (forward-line (- defun-height))
- (beginning-of-line)
- (reposition-window))
- (recenter (min ht comment-height)))
- ;;(repos-debug-macro "4")
- ))))
-
-;;; Auxiliary functions
-
-;; Return number of screen lines between START and END.
-(defun repos-count-screen-lines (start end)
- (save-excursion
- (save-restriction
- (narrow-to-region start end)
- (goto-char (point-min))
- (vertical-motion (- (point-max) (point-min))))))
-
-;; Return number of screen lines between START and END; returns a negative
-;; number if END precedes START.
-(defun repos-count-screen-lines-signed (start end)
- (let ((lines (repos-count-screen-lines start end)))
- (if (< start end)
- lines
- (- lines))))
-
-; (defmacro repos-debug-macro (case-no)
-; (` (message
-; (concat "Case " (, case-no) ": %s %s %s %s %s")
-; ht line comment-height defun-height defun-depth)))
-
diff --git a/lisp/resume.el b/lisp/resume.el
deleted file mode 100644
index 86866c12763..00000000000
--- a/lisp/resume.el
+++ /dev/null
@@ -1,160 +0,0 @@
-;; Process command line arguments from within a suspended Emacs job
-;; Copyright (C) 1988 Free Software Foundation, Inc.
-
-;; This file is not yet part of GNU Emacs, but soon will be.
-
-;; 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.
-
-;; Created by: Joe Wells, jbw@bucsf.bu.edu
-;; Created on: 1988?
-;; Last modified by: Joe Wells, jbw@dodge
-;; Last modified on: Thu Jun 14 15:20:41 1990
-;; Filename: resume.el
-;; Purpose: handle command line arguments when resuming suspended job
-
-;; Stephen Gildea suggested bug fix (gildea@bbn.com).
-;; Ideas from Michael DeCorte and other people.
-
-;; For csh users, insert the following alias in your .cshrc file
-;; (after removing the leading double semicolons, of course):
-;;
-;;# The following line could be just EMACS_CMD=emacs, but this depends on
-;;# your site.
-;;if (! $?EMACS_CMD) set EMACS_CMD=emacs
-;;set JOBS_FILE=/tmp/jobs.$USER.$$
-;;set ARGS_FILE=~/.emacs_args
-;;set STOP_PATT='^\[[0-9]*\] *[ +-] Stopped ............ '
-;;set SUNVIEW_CMD='emacstool -nw -f emacstool-init -f server-start'
-;;set X_CMD=\'\''$EMACS_CMD -i -f server-start'
-;;alias emacs \
-;;' \\
-;; jobs >! "$JOBS_FILE" \\
-;; && grep "$STOP_PATT$EMACS_CMD" "$JOBS_FILE" >& /dev/null \\
-;; && echo `pwd` \!* >! "$ARGS_FILE" && ""fg %$EMACS_CMD \\
-;;|| if (! -e ~/.emacs_server || -f ~/.emacs_server) set status=1 \\
-;; && emacsclient \!* \\
-;;|| @ status=1 - $?DISPLAY && eval "$X_CMD -i \!* &" \\
-;;|| @ status=1 - $?WINDOW_PARENT && eval "$SUNVIEW_CMD \!* &" \\
-;;|| ""$EMACS_CMD -nw \!* \\
-;;'
-;;
-;; The alias works as follows:
-;; 1. If there is a suspended Emacs job that is a child of the
-;; current shell, place its arguments in the ~/.emacs_args file and
-;; resume it.
-;; 2. Else if the ~/.emacs_server socket has been created, presume an
-;; Emacs server is running and attempt to connect to it. If no Emacs
-;; server is listening on the socket, this will fail.
-;; 3. Else if the DISPLAY environment variable is set, presume we are
-;; running under X Windows and start a new GNU Emacs process in the
-;; background as an X client.
-;; 4. Else if the WINDOW_PARENT environment variable is set, presume we
-;; are running under SunView and start an emacstool process in the
-;; background.
-;; 5. Else start a regular Emacs process.
-;;
-;; Notes:
-;; The output of the "jobs" command is not piped directly into "grep"
-;; because that would run the "jobs" command in a subshell.
-;; Before resuming a suspended emacs, the current directory and all
-;; command line arguments are placed in a file name ~/.emacs_args.
-;; The "-nw" switch to Emacs means no windowing system.
-
-;; Insert this in your .emacs file:
-;;(setq suspend-resume-hook 'resume-process-args)
-;;(setq suspend-hook 'empty-args-file)
-;;(autoload 'empty-args-file "resume")
-;;(autoload 'resume-process-args "resume")
-
-;; Finally, put the rest in a file named "resume.el" in a lisp library
-;; directory.
-
-(defvar emacs-args-file (expand-file-name "~/.emacs_args")
- "*This file is where arguments are placed for a suspended emacs job.")
-
-(defvar emacs-args-buffer " *Command Line Args*"
- "Buffer that is used by resume-process-args.")
-
-(defun resume-process-args ()
- "This should be called from inside of suspend-resume-hook. This
-grabs the contents of the file whose name is stored in
-emacs-args-file, and processes these arguments like command line
-options."
- (let ((start-buffer (current-buffer))
- (args-buffer (get-buffer-create emacs-args-buffer))
- length args)
- (unwind-protect
- (progn
- (set-buffer args-buffer)
- (erase-buffer)
- ;; get the contents of emacs-args-file
- (condition-case ()
- (let ((result (insert-file-contents emacs-args-file)))
- (setq length (car (cdr result))))
- ;; the file doesn't exist, ergo no arguments
- (file-error
- (erase-buffer)
- (setq length 0)))
- (if (<= length 0)
- (setq args nil)
- ;; get the arguments from the buffer
- (goto-char (point-min))
- (while (not (eobp))
- (skip-chars-forward " \t\n")
- (let ((begin (point)))
- (skip-chars-forward "^ \t\n")
- (setq args (cons (buffer-substring begin (point)) args)))
- (skip-chars-forward " \t\n"))
- ;; arguments are now in reverse order
- (setq args (nreverse args))
- ;; make sure they're not read again
- (erase-buffer))
- (write-buffer-to-file (current-buffer) emacs-args-file)
- ;; if nothing was in buffer, args will be null
- (or (null args)
- (setq default-directory (file-name-as-directory (car args))
- args (cdr args)))
- ;; actually process the arguments
- (command-line-1 args))
- ;; If the command line args don't result in a find-file, the
- ;; buffer will be left in args-buffer. So we change back to the
- ;; original buffer. The reason I don't just use
- ;; (let ((default-directory foo))
- ;; (command-line-1 args))
- ;; in the context of the original buffer is because let does not
- ;; work properly with buffer-local variables.
- (if (eq (current-buffer) args-buffer)
- (set-buffer start-buffer)))))
-
-(defun empty-args-file ()
- "This empties the contents of the file whose name is specified by
-emacs-args-file."
- (save-excursion
- (set-buffer (get-buffer-create emacs-args-buffer))
- (erase-buffer)
- (write-buffer-to-file (current-buffer) emacs-args-file)))
-
-(defun write-buffer-to-file (buffer file)
- "Writes the contents of BUFFER into FILE, if permissions allow."
- (if (not (file-writable-p file))
- (error "No permission to write file %s" file))
- (save-excursion
- (set-buffer buffer)
- (clear-visited-file-modtime)
- (save-restriction
- (widen)
- (write-region (point-min) (point-max) file nil 'quiet))
- (set-buffer-modified-p nil)))
diff --git a/lisp/mail/rfc822.el b/lisp/rfc822.el
index b7e43f62cda..18cf3c96987 100644
--- a/lisp/mail/rfc822.el
+++ b/lisp/rfc822.el
@@ -1,5 +1,5 @@
;; Hairy rfc822 parser for mail and news and suchlike
-;; Copyright (C) 1986-1990 Free Software Foundation, Inc.
+;; Copyright (C) 1986, 1987 Free Software Foundation, Inc.
;; Author Richard Mlynarik.
;; This file is part of GNU Emacs.
@@ -303,4 +303,3 @@
(setq list (nconc (nreverse tem) list)))))
(nreverse list)))
(and buf (kill-buffer buf))))))
-
diff --git a/lisp/rfc822.elc b/lisp/rfc822.elc
new file mode 100644
index 00000000000..099f39919b2
--- /dev/null
+++ b/lisp/rfc822.elc
Binary files differ
diff --git a/lisp/rmail.el b/lisp/rmail.el
new file mode 100644
index 00000000000..54547042b5f
--- /dev/null
+++ b/lisp/rmail.el
@@ -0,0 +1,1433 @@
+;; "RMAIL" mail reader for Emacs.
+;; Copyright (C) 1985, 1986, 1987, 1988, 1990, 1992 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+;; Souped up by shane@mit-ajax based on ideas of rlk@athena.mit.edu
+;; New features include attribute and keyword support, message
+;; selection by dispatch table, summary by attributes and keywords,
+;; expunging by dispatch table, sticky options for file commands.
+
+(require 'mail-utils)
+(provide 'rmail)
+
+; these variables now declared in loaddefs or paths.el
+;(defvar rmail-spool-directory "/usr/spool/mail/"
+; "This is the name of the directory used by the system mailer for\n\
+;delivering new mail. It's name should end with a slash.")
+;(defvar rmail-dont-reply-to-names
+; nil
+; "*A regexp specifying names to prune of reply to messages.
+;nil means dont reply to yourself.")
+;(defvar rmail-ignored-headers
+; "^via:\\|^mail-from:\\|^origin:\\|^status:\\|^received:\\|^message-id:\\|^summary-line:"
+; "*Gubbish headers one would rather not see.")
+;(defvar rmail-file-name
+; (expand-file-name "~/RMAIL")
+; "")
+;
+;(defvar rmail-delete-after-output nil
+; "*Non-nil means automatically delete a message that is copied to a file.")
+;
+;(defvar rmail-primary-inbox-list
+; '("/usr/spool/mail/$USER" "~/mbox")
+; "")
+
+;; these may be altered by site-init.el to match the format of mmdf files
+;; delimitation used on a given host (delim1 and delim2 from the config
+;; files)
+
+(defvar mmdf-delim1 "^\001\001\001\001\n"
+ "Regexp marking the start of an mmdf message")
+(defvar mmdf-delim2 "^\001\001\001\001\n"
+ "Regexp marking the end of an mmdf message")
+
+(defvar rmail-message-filter nil
+ "If non nil, is a filter function for new headers in RMAIL.
+Called with region narrowed to unformatted header.")
+
+(defvar rmail-mode-map nil)
+
+;; Message counters and markers. Deleted flags.
+
+(defvar rmail-current-message nil)
+(defvar rmail-total-messages nil)
+(defvar rmail-message-vector nil)
+(defvar rmail-deleted-vector nil)
+
+;; These are used by autoloaded rmail-summary.
+
+(defvar rmail-summary-buffer nil)
+(defvar rmail-summary-vector nil)
+
+;; `Sticky' default variables.
+
+;; Last individual label specified to a or k.
+(defvar rmail-last-label nil)
+;; Last set of labels specified to C-M-n or C-M-p or C-M-l.
+(defvar rmail-last-multi-labels nil)
+(defvar rmail-last-file nil)
+(defvar rmail-last-rmail-file nil)
+
+;; Regexp matching the delimiter of messages in UNIX mail format
+;; (UNIX From lines). This is often used with ^ added on the front.
+(defvar rmail-unix-mail-delimiter
+ "From \\([^ \n]*\\(\\|\".*\"[^ \n]*\\)\\) ?\\([^ \n]*\\) \\([^ ]*\\) *\\([0-9]*\\) \\([0-9:]*\\)\\( ?[A-Z]?[A-Z][A-Z]T\\( DST\\)?\\| ?[-+]?[0-9][0-9][0-9][0-9]\\|\\) 19\\([0-9]*\\) *\\(remote from [^\n]*\\)?\n")
+
+;;;; *** Rmail Mode ***
+
+(defun rmail (&optional file-name-arg)
+ "Read and edit incoming mail.
+Moves messages into file named by rmail-file-name (a babyl format file)
+ and edits that file in RMAIL Mode.
+Type \\[describe-mode] once editing that file, for a list of RMAIL commands.
+
+May be called with filename as argument;
+then performs rmail editing on that file,
+but does not copy any new mail into the file."
+ (interactive (if current-prefix-arg
+ (list (read-file-name "Run rmail on RMAIL file: "
+ nil nil t))))
+ (or rmail-last-file
+ (setq rmail-last-file (expand-file-name "~/xmail")))
+ (or rmail-last-rmail-file
+ (setq rmail-last-rmail-file (expand-file-name "~/XMAIL")))
+ (let* ((file-name (expand-file-name (or file-name-arg rmail-file-name)))
+ (existed (get-file-buffer file-name))
+ ;; Don't be confused by apparent local-variables spec
+ ;; in the last message in the RMAIL file.
+ (inhibit-local-variables t))
+ ;; Like find-file, but in the case where a buffer existed
+ ;; and the file was reverted, recompute the message-data.
+ (if (and existed (not (verify-visited-file-modtime existed)))
+ (progn
+ (find-file file-name)
+ (if (and (verify-visited-file-modtime existed)
+ (eq major-mode 'rmail-mode))
+ (progn (rmail-forget-messages)
+ (rmail-set-message-counters))))
+ (find-file file-name))
+ (if (eq major-mode 'rmail-edit-mode)
+ (error "exit rmail-edit-mode before getting new mail"))
+ (if (and existed (eq major-mode 'rmail-mode))
+ nil
+ (rmail-mode)
+ ;; Provide default set of inboxes for primary mail file ~/RMAIL.
+ (and (null rmail-inbox-list)
+ (null file-name-arg)
+ (setq rmail-inbox-list
+ (or rmail-primary-inbox-list
+ (list "~/mbox"
+ (concat rmail-spool-directory
+ (or (getenv "LOGNAME")
+ (getenv "USER")
+ (user-login-name)))))))
+ ;; Convert all or part to Babyl file if possible.
+ (rmail-convert-file)
+ (goto-char (point-max))
+ (if (null rmail-inbox-list)
+ (progn
+ (rmail-set-message-counters)
+ (rmail-show-message))))
+ (rmail-get-new-mail)))
+
+(defun rmail-convert-file ()
+ (let (convert)
+ (widen)
+ (goto-char (point-min))
+ ;; If file doesn't start like a Babyl file,
+ ;; convert it to one, by adding a header and converting each message.
+ (cond ((looking-at "BABYL OPTIONS:"))
+ ((looking-at "Version: 5\n")
+ ;; Losing babyl file made by old version of Rmail.
+ ;; Just fix the babyl file header; don't make a new one,
+ ;; so we don't lose the Labels: file attribute, etc.
+ (let ((buffer-read-only nil))
+ (insert "BABYL OPTIONS:\n")))
+ (t
+ (setq convert t)
+ (rmail-insert-rmail-file-header)))
+ ;; If file was not a Babyl file or if there are
+ ;; Unix format messages added at the end,
+ ;; convert file as necessary.
+ (if (or convert
+ (progn (goto-char (point-max))
+ (search-backward "\^_")
+ (forward-char 1)
+ (looking-at "\n*From ")))
+ (let ((buffer-read-only nil))
+ (message "Converting to Babyl format...")
+ (narrow-to-region (point) (point-max))
+ (rmail-convert-to-babyl-format)
+ (message "Converting to Babyl format...done")))))
+
+(defun rmail-insert-rmail-file-header ()
+ (let ((buffer-read-only nil))
+ (insert "BABYL OPTIONS:
+Version: 5
+Labels:
+Note: This is the header of an rmail file.
+Note: If you are seeing it in rmail,
+Note: it means the file has no messages in it.\n\^_")))
+
+(if rmail-mode-map
+ nil
+ (setq rmail-mode-map (make-keymap))
+ (suppress-keymap rmail-mode-map)
+ (define-key rmail-mode-map "." 'rmail-beginning-of-message)
+ (define-key rmail-mode-map " " 'scroll-up)
+ (define-key rmail-mode-map "\177" 'scroll-down)
+ (define-key rmail-mode-map "n" 'rmail-next-undeleted-message)
+ (define-key rmail-mode-map "p" 'rmail-previous-undeleted-message)
+ (define-key rmail-mode-map "\en" 'rmail-next-message)
+ (define-key rmail-mode-map "\ep" 'rmail-previous-message)
+ (define-key rmail-mode-map "\e\C-n" 'rmail-next-labeled-message)
+ (define-key rmail-mode-map "\e\C-p" 'rmail-previous-labeled-message)
+ (define-key rmail-mode-map "a" 'rmail-add-label)
+ (define-key rmail-mode-map "k" 'rmail-kill-label)
+ (define-key rmail-mode-map "d" 'rmail-delete-forward)
+ (define-key rmail-mode-map "u" 'rmail-undelete-previous-message)
+ (define-key rmail-mode-map "e" 'rmail-expunge)
+ (define-key rmail-mode-map "x" 'rmail-expunge)
+ (define-key rmail-mode-map "s" 'rmail-expunge-and-save)
+ (define-key rmail-mode-map "g" 'rmail-get-new-mail)
+ (define-key rmail-mode-map "h" 'rmail-summary)
+ (define-key rmail-mode-map "\e\C-h" 'rmail-summary)
+ (define-key rmail-mode-map "l" 'rmail-summary-by-labels)
+ (define-key rmail-mode-map "\e\C-l" 'rmail-summary-by-labels)
+ (define-key rmail-mode-map "\e\C-r" 'rmail-summary-by-recipients)
+ (define-key rmail-mode-map "t" 'rmail-toggle-header)
+ (define-key rmail-mode-map "m" 'rmail-mail)
+ (define-key rmail-mode-map "r" 'rmail-reply)
+ (define-key rmail-mode-map "c" 'rmail-continue)
+ (define-key rmail-mode-map "f" 'rmail-forward)
+ (define-key rmail-mode-map "\es" 'rmail-search)
+ (define-key rmail-mode-map "j" 'rmail-show-message)
+ (define-key rmail-mode-map "o" 'rmail-output-to-rmail-file)
+ (define-key rmail-mode-map "\C-o" 'rmail-output)
+ (define-key rmail-mode-map "i" 'rmail-input)
+ (define-key rmail-mode-map "q" 'rmail-quit)
+ (define-key rmail-mode-map ">" 'rmail-last-message)
+ (define-key rmail-mode-map "?" 'describe-mode)
+ (define-key rmail-mode-map "w" 'rmail-edit-current-message)
+ (define-key rmail-mode-map "\C-d" 'rmail-delete-backward))
+
+;; Rmail mode is suitable only for specially formatted data.
+(put 'rmail-mode 'mode-class 'special)
+
+(defun rmail-mode ()
+ "Rmail Mode is used by \\[rmail] for editing Rmail files.
+All normal editing commands are turned off.
+Instead, these commands are available:
+
+. Move point to front of this message (same as \\[beginning-of-buffer]).
+SPC Scroll to next screen of this message.
+DEL Scroll to previous screen of this message.
+n Move to Next non-deleted message.
+p Move to Previous non-deleted message.
+M-n Move to Next message whether deleted or not.
+M-p Move to Previous message whether deleted or not.
+> Move to the last message in Rmail file.
+j Jump to message specified by numeric position in file.
+M-s Search for string and show message it is found in.
+d Delete this message, move to next nondeleted.
+C-d Delete this message, move to previous nondeleted.
+u Undelete message. Tries current message, then earlier messages
+ till a deleted message is found.
+e Expunge deleted messages.
+s Expunge and save the file.
+q Quit Rmail: expunge, save, then switch to another buffer.
+C-x C-s Save without expunging.
+g Move new mail from system spool directory or mbox into this file.
+m Mail a message (same as \\[mail-other-window]).
+c Continue composing outgoing message started before.
+r Reply to this message. Like m but initializes some fields.
+f Forward this message to another user.
+o Output this message to an Rmail file (append it).
+C-o Output this message to a Unix-format mail file (append it).
+i Input Rmail file. Run Rmail on that file.
+a Add label to message. It will be displayed in the mode line.
+k Kill label. Remove a label from current message.
+C-M-n Move to Next message with specified label
+ (label defaults to last one specified).
+ Standard labels: filed, unseen, answered, forwarded, deleted.
+ Any other label is present only if you add it with `a'.
+C-M-p Move to Previous message with specified label
+C-M-h Show headers buffer, with a one line summary of each message.
+C-M-l Like h only just messages with particular label(s) are summarized.
+C-M-r Like h only just messages with particular recipient(s) are summarized.
+t Toggle header, show Rmail header if unformatted or vice versa.
+w Edit the current message. C-c C-c to return to Rmail."
+ (interactive)
+ (kill-all-local-variables)
+ (rmail-mode-1)
+ (rmail-variables)
+ (run-hooks 'rmail-mode-hook))
+
+(defun rmail-mode-1 ()
+ (setq major-mode 'rmail-mode)
+ (setq mode-name "RMAIL")
+ (setq buffer-read-only t)
+ ;; No need to auto save RMAIL files.
+ (setq buffer-auto-save-file-name nil)
+ (if (boundp 'mode-line-modified)
+ (setq mode-line-modified "--- ")
+ (setq mode-line-format
+ (cons "--- " (cdr (default-value 'mode-line-format)))))
+ (use-local-map rmail-mode-map)
+ (set-syntax-table text-mode-syntax-table)
+ (setq local-abbrev-table text-mode-abbrev-table))
+
+(defun rmail-variables ()
+ (make-local-variable 'revert-buffer-function)
+ (setq revert-buffer-function 'rmail-revert)
+ (make-local-variable 'rmail-last-label)
+ (make-local-variable 'rmail-deleted-vector)
+ (make-local-variable 'rmail-keywords)
+ (make-local-variable 'rmail-summary-buffer)
+ (make-local-variable 'rmail-summary-vector)
+ (make-local-variable 'rmail-current-message)
+ (make-local-variable 'rmail-total-messages)
+ (make-local-variable 'require-final-newline)
+ (setq require-final-newline nil)
+ (make-local-variable 'version-control)
+ (setq version-control 'never)
+ (make-local-variable 'file-precious-flag)
+ (setq file-precious-flag t)
+ (make-local-variable 'rmail-message-vector)
+ (make-local-variable 'rmail-last-file)
+ (make-local-variable 'rmail-inbox-list)
+ (setq rmail-inbox-list (rmail-parse-file-inboxes))
+ (make-local-variable 'rmail-keywords)
+ ;; this gets generated as needed
+ (setq rmail-keywords nil))
+
+;; Handle M-x revert-buffer done in an rmail-mode buffer.
+(defun rmail-revert (arg noconfirm)
+ (let (revert-buffer-function)
+ ;; Call our caller again, but this time it does the default thing.
+ (if (revert-buffer arg noconfirm)
+ ;; If the user said "yes", and we changed something,
+ ;; reparse the messages.
+ (progn
+ (rmail-convert-file)
+ (goto-char (point-max))
+ (rmail-set-message-counters)
+ (rmail-show-message)))))
+
+;; Return a list of files from this buffer's Mail: option.
+;; Does not assume that messages have been parsed.
+;; Just returns nil if buffer does not look like Babyl format.
+(defun rmail-parse-file-inboxes ()
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char 1)
+ (cond ((looking-at "BABYL OPTIONS:")
+ (search-forward "\^_" nil 'move)
+ (narrow-to-region 1 (point))
+ (goto-char 1)
+ (if (search-forward "\nMail:" nil t)
+ (progn
+ (narrow-to-region (point) (progn (end-of-line) (point)))
+ (goto-char (point-min))
+ (mail-parse-comma-list))))))))
+
+(defun rmail-expunge-and-save ()
+ "Expunge and save RMAIL file."
+ (interactive)
+ (rmail-expunge)
+ (save-buffer))
+
+(defun rmail-quit ()
+ "Quit out of RMAIL."
+ (interactive)
+ (rmail-expunge-and-save)
+ ;; Don't switch to the summary buffer even if it was recently visible.
+ (if rmail-summary-buffer
+ (bury-buffer rmail-summary-buffer))
+ (let ((obuf (current-buffer)))
+ (switch-to-buffer (other-buffer))
+ (bury-buffer obuf)))
+
+(defun rmail-input (filename)
+ "Run RMAIL on file FILENAME."
+ (interactive "FRun rmail on RMAIL file: ")
+ (rmail filename))
+
+
+;;;; *** Rmail input ***
+
+;; RLK feature not added in this version:
+;; argument specifies inbox file or files in various ways.
+
+(defun rmail-get-new-mail (&optional file-name)
+ "Move any new mail from this RMAIL file's inbox files.
+The inbox files can be specified with the file's Mail: option.
+The variable rmail-primary-inbox-list specifies the inboxes for
+your primary RMAIL file if it has no Mail: option.
+These are normally your ~/mbox and your /usr/spool/mail/$USER.
+
+You can also specify the file to get new mail from. In this
+case, the file of new mail is not changed or deleted.
+Noninteractively, you can pass the inbox file name as an argument.
+Interactively, a prefix argument causes us to read a file name
+and use that file as the inbox."
+ (interactive
+ (list (if current-prefix-arg
+ (read-file-name "Get new mail from file: "))))
+ (or (verify-visited-file-modtime (current-buffer))
+ (progn
+ (find-file (buffer-file-name))
+ (if (verify-visited-file-modtime (current-buffer))
+ (rmail-forget-messages))))
+ (rmail-maybe-set-message-counters)
+ (widen)
+ ;; Get rid of all undo records for this buffer.
+ (or (eq buffer-undo-list t)
+ (setq buffer-undo-list nil))
+ (unwind-protect
+ (let ((opoint (point))
+ (new-messages 0)
+ (delete-files ())
+ ;; If buffer has not changed yet, and has not been saved yet,
+ ;; don't replace the old backup file now.
+ (make-backup-files (and make-backup-files (buffer-modified-p)))
+ (buffer-read-only nil)
+ ;; Don't make undo records for what we do in getting mail.
+ (buffer-undo-list t))
+ (goto-char (point-max))
+ (skip-chars-backward " \t\n") ; just in case of brain damage
+ (delete-region (point) (point-max)) ; caused by require-final-newline
+ (save-excursion
+ (save-restriction
+ (narrow-to-region (point) (point))
+ ;; Read in the contents of the inbox files,
+ ;; renaming them as necessary,
+ ;; and adding to the list of files to delete eventually.
+ (if file-name
+ (rmail-insert-inbox-text (list file-name) nil)
+ (setq delete-files (rmail-insert-inbox-text rmail-inbox-list t)))
+ ;; Scan the new text and convert each message to babyl format.
+ (goto-char (point-min))
+ (save-excursion
+ (setq new-messages (rmail-convert-to-babyl-format)))
+ (or (zerop new-messages)
+ (let (success)
+ (widen)
+ (search-backward "\^_")
+ (narrow-to-region (point) (point-max))
+ (goto-char (1+ (point-min)))
+ (rmail-count-new-messages)
+ (save-buffer)))
+ ;; Delete the old files, now that babyl file is saved.
+ (while delete-files
+ (condition-case ()
+ ;; First, try deleting.
+ (condition-case ()
+ (delete-file (car delete-files))
+ (file-error
+ ;; If we can't delete it, truncate it.
+ (write-region (point) (point) (car delete-files))))
+ (file-error nil))
+ (setq delete-files (cdr delete-files)))))
+ (if (= new-messages 0)
+ (progn (goto-char opoint)
+ (if (or file-name rmail-inbox-list)
+ (message "(No new mail has arrived)")))
+ (message "%d new message%s read"
+ new-messages (if (= 1 new-messages) "" "s"))))
+ ;; Don't leave the buffer screwed up if we get a disk-full error.
+ (rmail-show-message)))
+
+(defun rmail-insert-inbox-text (files renamep)
+ (let (file tofile delete-files movemail popmail)
+ (while files
+ (setq file (expand-file-name (substitute-in-file-name (car files)))
+ ;;>> un*x specific <<
+ tofile (concat file "~"))
+ ;; If getting from mail spool directory,
+ ;; use movemail to move rather than renaming.
+ (setq movemail (equal (file-name-directory file) rmail-spool-directory))
+ (setq popmail (string-match "^po:" (file-name-nondirectory file)))
+ (if popmail (setq file (file-name-nondirectory file)
+ renamep t))
+ (if movemail
+ (progn
+ (setq tofile (expand-file-name
+ ".newmail"
+ ;; Use the directory of this rmail file
+ ;; because it's a nuisance to use the homedir
+ ;; if that is on a full disk and this rmail
+ ;; file isn't.
+ (file-name-directory
+ (expand-file-name buffer-file-name))))
+ ;; On some systems, /usr/spool/mail/foo is a directory
+ ;; and the actual inbox is /usr/spool/mail/foo/foo.
+ (if (file-directory-p file)
+ (setq file (expand-file-name (or (getenv "LOGNAME")
+ (getenv "USER")
+ (user-login-name))
+ file)))))
+ (if popmail
+ (message "Getting mail from post office ...")
+ (if (or (file-exists-p tofile) (file-exists-p file))
+ (message "Getting mail from %s..." file)))
+ ;; Set TOFILE if have not already done so, and
+ ;; rename or copy the file FILE to TOFILE if and as appropriate.
+ (cond ((not renamep)
+ (setq tofile file))
+ ((or (file-exists-p tofile) (and (not popmail)
+ (not (file-exists-p file))))
+ nil)
+ ((and (not movemail) (not popmail))
+ (rename-file file tofile nil)
+ ;; Make the real inbox file empty.
+ ;; Leaving it deleted could cause lossage
+ ;; because mailers often won't create the file.
+ (condition-case ()
+ (write-region (point) (point) file)
+ (file-error nil)))
+ (t
+ (let ((errors nil))
+ (unwind-protect
+ (save-excursion
+ (setq errors (generate-new-buffer " *rmail loss*"))
+ (buffer-flush-undo errors)
+ (call-process
+ (expand-file-name "movemail" exec-directory)
+ nil errors nil file tofile)
+ (if (not (buffer-modified-p errors))
+ ;; No output => movemail won
+ nil
+ (set-buffer errors)
+ (subst-char-in-region (point-min) (point-max)
+ ?\n ?\ )
+ (goto-char (point-max))
+ (skip-chars-backward " \t")
+ (delete-region (point) (point-max))
+ (goto-char (point-min))
+ (if (looking-at "movemail: ")
+ (delete-region (point-min) (match-end 0)))
+ (beep t)
+ (message (concat "movemail: "
+ (buffer-substring (point-min)
+ (point-max))))
+ (sit-for 3)
+ nil))
+ (if errors (kill-buffer errors))))))
+ ;; At this point, TOFILE contains the name to read:
+ ;; Either the alternate name (if we renamed)
+ ;; or the actual inbox (if not renaming).
+ (if (file-exists-p tofile)
+ (let ((omax (point-max)))
+ (goto-char (point-max))
+ (insert-file-contents tofile)
+ (goto-char (point-max))
+ (or (= (preceding-char) ?\n)
+ (= opoint (point-max))
+ (insert ?\n))
+ (setq delete-files (cons tofile delete-files))))
+ (message "")
+ (setq files (cdr files)))
+ delete-files))
+
+;; the rmail-break-forwarded-messages feature is not implemented
+(defun rmail-convert-to-babyl-format ()
+ (let ((count 0) start
+ (case-fold-search nil))
+ (goto-char (point-min))
+ (save-restriction
+ (while (not (eobp))
+ (cond ((looking-at "BABYL OPTIONS:");Babyl header
+ (search-forward "\n\^_")
+ (delete-region (point-min) (point)))
+ ;; Babyl format message
+ ((looking-at "\^L")
+ (or (search-forward "\n\^_" nil t)
+ (progn
+ (message "Invalid Babyl format in inbox!")
+ (sit-for 1)
+ (goto-char (point-max))))
+ (setq count (1+ count))
+ ;; Make sure there is no extra white space after the ^_
+ ;; at the end of the message.
+ ;; Narrowing will make sure that whatever follows the junk
+ ;; will be treated properly.
+ (delete-region (point)
+ (save-excursion
+ (skip-chars-forward " \t\n")
+ (point)))
+ (narrow-to-region (point) (point-max)))
+ ;;*** MMDF format
+ ((let ((case-fold-search t))
+ (looking-at mmdf-delim1))
+ (let ((case-fold-search t))
+ (replace-match "\^L\n0, unseen,,\n*** EOOH ***\n")
+ (setq start (point))
+ (re-search-forward mmdf-delim2 nil t)
+ (replace-match "\^_"))
+ (save-excursion
+ (save-restriction
+ (narrow-to-region start (1- (point)))
+ (goto-char (point-min))
+ (while (search-forward "\n\^_" nil t) ; single char "\^_"
+ (replace-match "\n^_")))) ; 2 chars: "^" and "_"
+ (narrow-to-region (point) (point-max))
+ (setq count (1+ count)))
+ ;;*** Mail format
+ ((looking-at "^From ")
+ (setq start (point))
+ (insert "\^L\n0, unseen,,\n*** EOOH ***\n")
+ (rmail-nuke-pinhead-header)
+ ;; If this message has a Content-Length field,
+ ;; skip to the end of the contents.
+ (let* ((header-end (save-excursion
+ (and (re-search-forward "\n\n" nil t)
+ (point))))
+ (case-fold-search t)
+ (size
+ ;; Get the numeric value from the Content-Length field.
+ (save-excursion
+ ;; Back up to end of prev line,
+ ;; in case the Content-Length field comes first.
+ (forward-char -1)
+ (and (search-forward "\ncontent-length: "
+ header-end t)
+ (let ((beg (point))
+ (eol (progn (end-of-line) (point))))
+ (read (buffer-substring beg eol)))))))
+ (if size
+ (goto-char (+ header-end size))))
+
+ (if (re-search-forward
+ (concat "^[\^_]?\\("
+ rmail-unix-mail-delimiter
+ "\\|"
+ mmdf-delim1 "\\|"
+ "^BABYL OPTIONS:\\|"
+ "\^L\n[01],\\)") nil t)
+ (goto-char (match-beginning 1))
+ (goto-char (point-max)))
+ (setq count (1+ count))
+ (save-excursion
+ (save-restriction
+ (narrow-to-region start (point))
+ (goto-char (point-min))
+ (while (search-forward "\n\^_" nil t); single char
+ (replace-match "\n^_")))); 2 chars: "^" and "_"
+ (insert ?\^_)
+ (narrow-to-region (point) (point-max)))
+ ;;
+ ;;This is a kludge, in case we're wrong about mmdf not
+ ;;allowing anything in between. If it loses, we'll have
+ ;;to look for something else
+ (t (delete-char 1)))))
+ count))
+
+(defun rmail-nuke-pinhead-header ()
+ (save-excursion
+ (save-restriction
+ (let ((start (point))
+ (end (progn
+ (condition-case ()
+ (search-forward "\n\n")
+ (error
+ (goto-char (point-max))
+ (insert "\n\n")))
+ (point)))
+ has-from has-date)
+ (narrow-to-region start end)
+ (let ((case-fold-search t))
+ (goto-char start)
+ (setq has-from (search-forward "\nFrom:" nil t))
+ (goto-char start)
+ (setq has-date (and (search-forward "\nDate:" nil t) (point)))
+ (goto-char start))
+ (let ((case-fold-search nil))
+ (if (re-search-forward (concat "^" rmail-unix-mail-delimiter) nil t)
+ (replace-match
+ (concat
+ ;; Keep and reformat the date if we don't
+ ;; have a Date: field.
+ (if has-date
+ ""
+ ;; If no time zone specified, assume est.
+ (if (= (match-beginning 7) (match-end 7))
+ "Date: \\3, \\5 \\4 \\9 \\6 EST\n"
+ "Date: \\3, \\5 \\4 \\9 \\6\\7\n"))
+ ;; Keep and reformat the sender if we don't
+ ;; have a From: field.
+ (if has-from
+ ""
+ "From: \\1\n")))))))))
+
+;;;; *** Rmail Message Formatting and Header Manipulation ***
+
+(defun rmail-reformat-message (beg end)
+ (goto-char beg)
+ (forward-line 1)
+ (if (/= (following-char) ?0)
+ (error "Bad format in RMAIL file."))
+ (let ((buffer-read-only nil)
+ (delta (- (buffer-size) end)))
+ (delete-char 1)
+ (insert ?1)
+ (forward-line 1)
+ (if (looking-at "Summary-line: ")
+ (forward-line 1))
+ (if (looking-at "\\*\\*\\* EOOH \\*\\*\\*\n")
+ (delete-region (point)
+ (progn (forward-line 1) (point))))
+ (let ((str (buffer-substring (point)
+ (save-excursion (search-forward "\n\n" end 'move)
+ (point)))))
+ (insert str "*** EOOH ***\n")
+ (narrow-to-region (point) (- (buffer-size) delta)))
+ (goto-char (point-min))
+ (if rmail-ignored-headers (rmail-clear-headers))
+ (if rmail-message-filter (funcall rmail-message-filter))))
+
+(defun rmail-clear-headers ()
+ (if (search-forward "\n\n" nil t)
+ (save-restriction
+ (narrow-to-region (point-min) (point))
+ (let ((buffer-read-only nil))
+ (while (let ((case-fold-search t))
+ (goto-char (point-min))
+ (re-search-forward rmail-ignored-headers nil t))
+ (beginning-of-line)
+ (delete-region (point)
+ (progn (re-search-forward "\n[^ \t]")
+ (forward-char -1)
+ (point))))))))
+
+(defun rmail-toggle-header ()
+ "Show original message header if pruned header currently shown, or vice versa."
+ (interactive)
+ (rmail-maybe-set-message-counters)
+ (narrow-to-region (rmail-msgbeg rmail-current-message) (point-max))
+ (let ((buffer-read-only nil))
+ (goto-char (point-min))
+ (forward-line 1)
+ (if (= (following-char) ?1)
+ (progn (delete-char 1)
+ (insert ?0)
+ (forward-line 1)
+ (if (looking-at "Summary-Line:")
+ (forward-line 1))
+ (insert "*** EOOH ***\n")
+ (forward-char -1)
+ (search-forward "\n*** EOOH ***\n")
+ (forward-line -1)
+ (let ((temp (point)))
+ (and (search-forward "\n\n" nil t)
+ (delete-region temp (point))))
+ (goto-char (point-min))
+ (search-forward "\n*** EOOH ***\n")
+ (narrow-to-region (point) (point-max)))
+ (rmail-reformat-message (point-min) (point-max)))))
+
+;;;; *** Rmail Attributes and Keywords ***
+
+;; Make a string describing current message's attributes and keywords
+;; and set it up as the name of a minor mode
+;; so it will appear in the mode line.
+(defun rmail-display-labels ()
+ (let ((blurb "") (beg (point-min-marker)) (end (point-max-marker)))
+ (save-excursion
+ (unwind-protect
+ (progn
+ (widen)
+ (goto-char (rmail-msgbeg rmail-current-message))
+ (forward-line 1)
+ (if (looking-at "[01],")
+ (progn
+ (narrow-to-region (point) (progn (end-of-line) (point)))
+ ;; Truly valid BABYL format requires a space before each
+ ;; attribute or keyword name. Put them in if missing.
+ (let (buffer-read-only)
+ (goto-char (point-min))
+ (while (search-forward "," nil t)
+ (or (looking-at "[ ,]") (eobp)
+ (insert " "))))
+ (goto-char (point-max))
+ (if (search-backward ",," nil 'move)
+ (progn
+ (if (> (point) (1+ (point-min)))
+ (setq blurb (buffer-substring (+ 1 (point-min)) (point))))
+ (if (> (- (point-max) (point)) 2)
+ (setq blurb
+ (concat blurb
+ ";"
+ (buffer-substring (+ (point) 3)
+ (1- (point-max)))))))))))
+ (narrow-to-region beg end)
+ (set-marker beg nil)
+ (set-marker end nil)))
+ (while (string-match " +," blurb)
+ (setq blurb (concat (substring blurb 0 (match-beginning 0)) ","
+ (substring blurb (match-end 0)))))
+ (while (string-match ", +" blurb)
+ (setq blurb (concat (substring blurb 0 (match-beginning 0)) ","
+ (substring blurb (match-end 0)))))
+ (setq mode-line-process
+ (concat " " rmail-current-message "/" rmail-total-messages
+ blurb))))
+
+;; Turn an attribute of the current message on or off according to STATE.
+;; ATTR is the name of the attribute, as a string.
+(defun rmail-set-attribute (attr state)
+ (let ((omax (- (buffer-size) (point-max)))
+ (omin (- (buffer-size) (point-min)))
+ (buffer-read-only nil))
+ (unwind-protect
+ (save-excursion
+ (widen)
+ (goto-char (+ 3 (rmail-msgbeg rmail-current-message)))
+ (let ((curstate (search-backward (concat ", " attr ",")
+ (prog1 (point) (end-of-line)) t)))
+ (or (eq curstate (not (not state)))
+ (if curstate
+ (delete-region (point) (1- (match-end 0)))
+ (beginning-of-line)
+ (forward-char 2)
+ (insert " " attr ","))))
+ (if (string= attr "deleted")
+ (rmail-set-message-deleted-p rmail-current-message state)))
+ (narrow-to-region (max 1 (- (buffer-size) omin))
+ (- (buffer-size) omax))
+ (rmail-display-labels))))
+
+;; Return t if the attributes/keywords line of msg number MSG
+;; contains a match for the regexp LABELS.
+(defun rmail-message-labels-p (msg labels)
+ (goto-char (rmail-msgbeg msg))
+ (forward-char 3)
+ (re-search-backward labels (prog1 (point) (end-of-line)) t))
+
+;;;; *** Rmail Message Selection And Support ***
+
+(defun rmail-msgend (n)
+ (marker-position (aref rmail-message-vector (1+ n))))
+
+(defun rmail-msgbeg (n)
+ (marker-position (aref rmail-message-vector n)))
+
+(defun rmail-widen-to-current-msgbeg (function)
+ "Call FUNCTION with point at start of internal data of current message.
+Assumes that bounds were previously narrowed to display the message in Rmail.
+The bounds are widened enough to move point where desired,
+then narrowed again afterward.
+Assumes that the visible text of the message is not changed by FUNCTION."
+ (save-excursion
+ (let ((obeg (- (point-max) (point-min)))
+ (unwind-protect
+ (progn
+ (narrow-to-region (rmail-msgbeg rmail-current-message)
+ (point-max))
+ (goto-char (point-min))
+ (funcall function))
+ (narrow-to-region (- (point-max) obeg) (point-max)))))))
+
+(defun rmail-forget-messages ()
+ (unwind-protect
+ (if (vectorp rmail-message-vector)
+ (let* ((i 0)
+ (v rmail-message-vector)
+ (n (length v)))
+ (while (< i n)
+ (move-marker (aref v i) nil)
+ (setq i (1+ i)))))
+ (setq rmail-message-vector nil)
+ (setq rmail-deleted-vector nil)))
+
+(defun rmail-maybe-set-message-counters ()
+ (if (not (and rmail-deleted-vector
+ rmail-message-vector
+ rmail-current-message
+ rmail-total-messages))
+ (rmail-set-message-counters)))
+
+(defun rmail-count-new-messages (&optional nomsg)
+ (let* ((case-fold-search nil)
+ (total-messages 0)
+ (messages-head nil)
+ (deleted-head nil))
+ (or nomsg (message "Counting new messages..."))
+ (goto-char (point-max))
+ ;; Put at the end of messages-head
+ ;; the entry for message N+1, which marks
+ ;; the end of message N. (N = number of messages).
+ (search-backward "\^_")
+ (setq messages-head (list (point-marker)))
+ (rmail-set-message-counters-counter (point-min))
+ (setq rmail-current-message (1+ rmail-total-messages))
+ (setq rmail-total-messages
+ (+ rmail-total-messages total-messages))
+ (setq rmail-message-vector
+ (vconcat rmail-message-vector (cdr messages-head)))
+ (aset rmail-message-vector
+ rmail-current-message (car messages-head))
+ (setq rmail-deleted-vector
+ (concat rmail-deleted-vector deleted-head))
+ (setq rmail-summary-vector
+ (vconcat rmail-summary-vector (make-vector total-messages nil)))
+ (goto-char (point-min))
+ (or nomsg (message "Counting new messages...done (%d)" total-messages))))
+
+(defun rmail-set-message-counters ()
+ (rmail-forget-messages)
+ (save-excursion
+ (save-restriction
+ (widen)
+ (let* ((point-save (point))
+ (total-messages 0)
+ (messages-after-point)
+ (case-fold-search nil)
+ (messages-head nil)
+ (deleted-head nil))
+ (message "Counting messages...")
+ (goto-char (point-max))
+ ;; Put at the end of messages-head
+ ;; the entry for message N+1, which marks
+ ;; the end of message N. (N = number of messages).
+ (search-backward "\^_")
+ (setq messages-head (list (point-marker)))
+ (rmail-set-message-counters-counter (min (point) point-save))
+ (setq messages-after-point total-messages)
+ (rmail-set-message-counters-counter)
+ (setq rmail-total-messages total-messages)
+ (setq rmail-current-message
+ (min total-messages
+ (max 1 (- total-messages messages-after-point))))
+ (setq rmail-message-vector
+ (apply 'vector (cons (point-min-marker) messages-head))
+ rmail-deleted-vector (concat "D" deleted-head)
+ rmail-summary-vector (make-vector rmail-total-messages nil))
+ (message "Counting messages...done")))))
+
+(defun rmail-set-message-counters-counter (&optional stop)
+ (while (search-backward "\^_\^L\n" stop t)
+ (setq messages-head (cons (point-marker) messages-head))
+ (save-excursion
+ (setq deleted-head
+ (cons (if (search-backward ", deleted,"
+ (prog1 (point)
+ (forward-line 2))
+ t)
+ ?D ?\ )
+ deleted-head)))
+ (if (zerop (% (setq total-messages (1+ total-messages)) 20))
+ (message "Counting messages...%d" total-messages))))
+
+(defun rmail-beginning-of-message ()
+ "Show current message starting from the beginning."
+ (interactive)
+ (rmail-show-message rmail-current-message))
+
+(defun rmail-show-message (&optional n)
+ "Show message number N (prefix argument), counting from start of file."
+ (interactive "p")
+ (rmail-maybe-set-message-counters)
+ (widen)
+ (if (zerop rmail-total-messages)
+ (progn (narrow-to-region (point-min) (1- (point-max)))
+ (goto-char (point-min))
+ (setq mode-line-process nil))
+ (let (blurb)
+ (if (not n)
+ (setq n rmail-current-message)
+ (cond ((<= n 0)
+ (setq n 1
+ rmail-current-message 1
+ blurb "No previous message"))
+ ((> n rmail-total-messages)
+ (setq n rmail-total-messages
+ rmail-current-message rmail-total-messages
+ blurb "No following message"))
+ (t
+ (setq rmail-current-message n))))
+ (let ((beg (rmail-msgbeg n))
+ (end (rmail-msgend n)))
+ (goto-char beg)
+ (forward-line 1)
+ (if (= (following-char) ?0)
+ (progn
+ (rmail-reformat-message beg end)
+ (rmail-set-attribute "unseen" nil))
+ (search-forward "\n*** EOOH ***\n" end t)
+ (narrow-to-region (point) end))
+ (goto-char (point-min))
+ (rmail-display-labels)
+ (run-hooks 'rmail-show-message-hook)
+ (if blurb
+ (message blurb))))))
+
+(defun rmail-next-message (n)
+ "Show following message whether deleted or not.
+With prefix argument N, moves forward N messages,
+or backward if N is negative."
+ (interactive "p")
+ (rmail-maybe-set-message-counters)
+ (rmail-show-message (+ rmail-current-message n)))
+
+(defun rmail-previous-message (n)
+ "Show previous message whether deleted or not.
+With prefix argument N, moves backward N messages,
+or forward if N is negative."
+ (interactive "p")
+ (rmail-next-message (- n)))
+
+(defun rmail-next-undeleted-message (n)
+ "Show following non-deleted message.
+With prefix argument N, moves forward N non-deleted messages,
+or backward if N is negative."
+ (interactive "p")
+ (rmail-maybe-set-message-counters)
+ (let ((lastwin rmail-current-message)
+ (current rmail-current-message))
+ (while (and (> n 0) (< current rmail-total-messages))
+ (setq current (1+ current))
+ (if (not (rmail-message-deleted-p current))
+ (setq lastwin current n (1- n))))
+ (while (and (< n 0) (> current 1))
+ (setq current (1- current))
+ (if (not (rmail-message-deleted-p current))
+ (setq lastwin current n (1+ n))))
+ (if (/= lastwin rmail-current-message)
+ (rmail-show-message lastwin))
+ (if (< n 0)
+ (message "No previous nondeleted message"))
+ (if (> n 0)
+ (message "No following nondeleted message"))))
+
+(defun rmail-previous-undeleted-message (n)
+ "Show previous non-deleted message.
+With prefix argument N, moves backward N non-deleted messages,
+or forward if N is negative."
+ (interactive "p")
+ (rmail-next-undeleted-message (- n)))
+
+(defun rmail-last-message ()
+ "Show last message in file."
+ (interactive)
+ (rmail-maybe-set-message-counters)
+ (rmail-show-message rmail-total-messages))
+
+(defun rmail-what-message ()
+ (let ((where (point))
+ (low 1)
+ (high rmail-total-messages)
+ (mid (/ rmail-total-messages 2)))
+ (while (> (- high low) 1)
+ (if (>= where (rmail-msgbeg mid))
+ (setq low mid)
+ (setq high mid))
+ (setq mid (+ low (/ (- high low) 2))))
+ (if (>= where (rmail-msgbeg high)) high low)))
+
+(defvar rmail-search-last-regexp nil)
+(defun rmail-search (regexp &optional reversep)
+ "Show message containing next match for REGEXP.
+Search in reverse (earlier messages) with non-nil 2nd arg REVERSEP.
+Interactively, empty argument means use same regexp used last time,
+and reverse search is specified by a negative numeric arg."
+ (interactive
+ (let* ((reversep (< (prefix-numeric-value current-prefix-arg) 0))
+ (prompt (concat (if reversep "Reverse " "") "Rmail search (regexp): "))
+ regexp)
+ (if rmail-search-last-regexp
+ (setq prompt (concat prompt
+ "(default "
+ rmail-search-last-regexp
+ ") ")))
+ (setq regexp (read-string prompt))
+ (cond ((not (equal regexp ""))
+ (setq rmail-search-last-regexp regexp))
+ ((not rmail-search-last-regexp)
+ (error "No previous Rmail search string")))
+ (list rmail-search-last-regexp reversep)))
+ (message "%sRmail search for %s..."
+ (if reversep "Reverse " "")
+ regexp)
+ (rmail-maybe-set-message-counters)
+ (let ((omin (point-min))
+ (omax (point-max))
+ (opoint (point))
+ win
+ (msg rmail-current-message))
+ (unwind-protect
+ (progn
+ (widen)
+ ;; Check messages one by one, advancing message number up or down
+ ;; but searching forward through each message.
+ (if reversep
+ (while (and (null win) (> msg 1))
+ (goto-char (rmail-msgbeg (setq msg (1- msg))))
+ (setq win (re-search-forward
+ regexp (rmail-msgend msg) t)))
+ (while (and (null win) (< msg rmail-total-messages))
+ (goto-char (rmail-msgbeg (setq msg (1+ msg))))
+ (setq win (re-search-forward regexp (rmail-msgend msg) t)))))
+ (if win
+ (progn
+ ;; If this is a reverse search and we found a message,
+ ;; search backward thru this message to position point.
+ (if reversep
+ (progn
+ (goto-char (rmail-msgend msg))
+ (re-search-backward
+ regexp (rmail-msgbeg msg) t)))
+ (setq win (point))
+ (rmail-show-message msg)
+ (message "%sRmail search for %s...done"
+ (if reversep "Reverse " "")
+ regexp)
+ (goto-char win))
+ (goto-char opoint)
+ (narrow-to-region omin omax)
+ (ding)
+ (message "Searched failed: %s" regexp)))))
+
+;;;; *** Rmail Message Deletion Commands ***
+
+(defun rmail-message-deleted-p (n)
+ (= (aref rmail-deleted-vector n) ?D))
+
+(defun rmail-set-message-deleted-p (n state)
+ (aset rmail-deleted-vector n (if state ?D ?\ )))
+
+(defun rmail-delete-message ()
+ "Delete this message and stay on it."
+ (interactive)
+ (rmail-set-attribute "deleted" t))
+
+(defun rmail-undelete-previous-message ()
+ "Back up to deleted message, select it, and undelete it."
+ (interactive)
+ (let ((msg rmail-current-message))
+ (while (and (> msg 0)
+ (not (rmail-message-deleted-p msg)))
+ (setq msg (1- msg)))
+ (if (= msg 0)
+ (error "No previous deleted message")
+ (if (/= msg rmail-current-message)
+ (rmail-show-message msg))
+ (rmail-set-attribute "deleted" nil))))
+
+(defun rmail-delete-forward (&optional backward)
+ "Delete this message and move to next nondeleted one.
+Deleted messages stay in the file until the \\[rmail-expunge] command is given.
+With prefix argument, delete and move backward."
+ (interactive "P")
+ (rmail-set-attribute "deleted" t)
+ (rmail-next-undeleted-message (if backward -1 1)))
+
+(defun rmail-delete-backward ()
+ "Delete this message and move to previous nondeleted one.
+Deleted messages stay in the file until the \\[rmail-expunge] command is given."
+ (interactive)
+ (rmail-delete-forward t))
+
+(defun rmail-expunge ()
+ "Actually erase all deleted messages in the file."
+ (interactive)
+ (message "Expunging deleted messages...")
+ ;; Discard any prior undo information.
+ (or (eq buffer-undo-list t)
+ (setq buffer-undo-list nil))
+ (rmail-maybe-set-message-counters)
+ (let* ((omax (- (buffer-size) (point-max)))
+ (omin (- (buffer-size) (point-min)))
+ (opoint (if (and (> rmail-current-message 0)
+ (= ?D (aref rmail-deleted-vector rmail-current-message)))
+ 0 (- (point) (point-min))))
+ (messages-head (cons (aref rmail-message-vector 0) nil))
+ (messages-tail messages-head)
+ ;; Don't make any undo records for the expunging itself.
+ (buffer-undo-list t)
+ (win))
+ (unwind-protect
+ (save-excursion
+ (widen)
+ (goto-char (point-min))
+ (let ((counter 0)
+ (number 1)
+ (total rmail-total-messages)
+ (new-message-number rmail-current-message)
+ (new-summary nil)
+ (buffer-read-only nil)
+ (messages rmail-message-vector)
+ (deleted rmail-deleted-vector)
+ (summary rmail-summary-vector))
+ (setq rmail-total-messages nil
+ rmail-current-message nil
+ rmail-message-vector nil
+ rmail-deleted-vector nil
+ rmail-summary-vector nil)
+ (while (<= number total)
+ (if (= (aref deleted number) ?D)
+ (progn
+ (delete-region
+ (marker-position (aref messages number))
+ (marker-position (aref messages (1+ number))))
+ (move-marker (aref messages number) nil)
+ (if (> new-message-number counter)
+ (setq new-message-number (1- new-message-number))))
+ (setq counter (1+ counter))
+ (setq messages-tail
+ (setcdr messages-tail
+ (cons (aref messages number) nil)))
+ (setq new-summary
+ (cons (if (= counter number) (aref summary (1- number)))
+ new-summary)))
+ (if (zerop (% (setq number (1+ number)) 20))
+ (message "Expunging deleted messages...%d" number)))
+ (setq messages-tail
+ (setcdr messages-tail
+ (cons (aref messages number) nil)))
+ (setq rmail-current-message new-message-number
+ rmail-total-messages counter
+ rmail-message-vector (apply 'vector messages-head)
+ rmail-deleted-vector (make-string (1+ counter) ?\ )
+ rmail-summary-vector (vconcat (nreverse new-summary))
+ win t)))
+ (message "Expunging deleted messages...done")
+ (if (not win)
+ (narrow-to-region (- (buffer-size) omin) (- (buffer-size) omax)))
+ (rmail-show-message
+ (if (zerop rmail-current-message) 1 nil))
+ (forward-char opoint))))
+
+;;;; *** Rmail Mailing Commands ***
+
+(defun rmail-mail ()
+ "Send mail in another window.
+While composing the message, use \\[mail-yank-original] to yank the
+original message into it."
+ (interactive)
+ (mail-other-window nil nil nil nil nil (current-buffer)))
+
+(defun rmail-continue ()
+ "Continue composing outgoing message previously being composed."
+ (interactive)
+ (mail-other-window t))
+
+(defun rmail-reply (just-sender)
+ "Reply to the current message.
+Normally include CC: to all other recipients of original message;
+prefix argument means ignore them.
+While composing the reply, use \\[mail-yank-original] to yank the
+original message into it."
+ (interactive "P")
+ ;;>> this gets set even if we abort. Can't do anything about it, though.
+ (rmail-set-attribute "answered" t)
+ (rmail-display-labels)
+ (let (from reply-to cc subject date to message-id resent-reply-to)
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (rmail-msgbeg rmail-current-message))
+ (forward-line 1)
+ (if (= (following-char) ?0)
+ (narrow-to-region
+ (progn (forward-line 2)
+ (point))
+ (progn (search-forward "\n\n" (rmail-msgend rmail-current-message)
+ 'move)
+ (point)))
+ (narrow-to-region (point)
+ (progn (search-forward "\n*** EOOH ***\n")
+ (beginning-of-line) (point))))
+ (setq resent-reply-to (mail-fetch-field "resent-reply-to" t)
+ from (mail-fetch-field "from")
+ reply-to (or resent-reply-to
+ (mail-fetch-field "reply-to" nil t)
+ from)
+ cc (cond (just-sender nil)
+ (resent-reply-to (mail-fetch-field "resent-cc" t))
+ (t (mail-fetch-field "cc" nil t)))
+ subject (or (and resent-reply-to
+ (mail-fetch-field "resent-subject" t))
+ (mail-fetch-field "subject"))
+ date (cond (resent-reply-to
+ (mail-fetch-field "resent-date" t))
+ ((mail-fetch-field "date")))
+ to (cond (resent-reply-to
+ (mail-fetch-field "resent-to" t))
+ ((mail-fetch-field "to" nil t))
+ ;((mail-fetch-field "apparently-to")) ack gag barf
+ (t ""))
+ message-id (cond (resent-reply-to
+ (mail-fetch-field "resent-message-id" t))
+ ((mail-fetch-field "message-id"))))))
+ (and subject
+ (string-match "\\`Re: " subject)
+ (setq subject (substring subject 4)))
+ (mail-other-window nil
+ (mail-strip-quoted-names reply-to)
+ subject
+ (rmail-make-in-reply-to-field from date message-id)
+ (if just-sender
+ nil
+ (let* ((cc-list (rmail-dont-reply-to
+ (mail-strip-quoted-names
+ (if (null cc) to (concat to ", " cc))))))
+ (if (string= cc-list "") nil cc-list)))
+ (current-buffer))))
+
+(defun rmail-make-in-reply-to-field (from date message-id)
+ (if mail-use-rfc822 (require 'rfc822))
+ (let (field)
+ (if (and mail-use-rfc822 from)
+ (let ((tem (car (rfc822-addresses from))))
+ (and message-id
+ (setq field (if (string-match
+ (regexp-quote
+ (if (string-match "@[^@]*\\'" tem)
+ (substring tem
+ 0 (match-beginning 0))
+ tem))
+ message-id)
+ message-id
+ (concat message-id " \"" tem "\""))
+ message-id nil date nil))
+ (or field
+ (setq field (prin1-to-string tem))))
+; (if message-id
+; (setq field message-id message-id nil date nil)
+; (setq field (car (rfc882-addresses from))))
+ )
+ (or field
+ (not from)
+ ;; Compute the sender for the in-reply-to; prefer full name.
+ (let* ((stop-pos (string-match " *at \\| *@ \\| *<" from))
+ (start-pos (if stop-pos 0
+ ;;>> this loses on nested ()'s
+ (let ((pos (string-match " *(" from)))
+ (if (not pos) nil
+ (setq stop-pos (string-match ")" from pos))
+ (if (zerop pos) 0 (+ 2 pos)))))))
+ (setq field (if stop-pos
+ (substring from start-pos stop-pos)
+ from))))
+ (if date (setq field (concat field "'s message of " date)))
+ (if message-id (setq field (concat field " " message-id)))
+ field))
+
+(defun rmail-forward ()
+ "Forward the current message to another user."
+ (interactive)
+ ;;>> this gets set even if we abort. Can't do anything about it, though.
+ (rmail-set-attribute "forwarded" t)
+ (let ((forward-buffer (current-buffer))
+ (subject (concat "["
+ (let ((from (or (mail-fetch-field "From")
+ (mail-fetch-field ">From"))))
+ (if from
+ (concat (mail-strip-quoted-names from) ": ")
+ ""))
+ (or (mail-fetch-field "Subject") "")
+ "]")))
+ ;; If only one window, use it for the mail buffer.
+ ;; Otherwise, use another window for the mail buffer
+ ;; so that the Rmail buffer remains visible
+ ;; and sending the mail will get back to it.
+ (if (if (one-window-p t)
+ (mail nil nil subject)
+ (mail-other-window nil nil subject))
+ (save-excursion
+ (goto-char (point-max))
+ (forward-line 1)
+ (insert-buffer forward-buffer)))))
+
+;;;; *** Rmail Specify Inbox Files ***
+
+(autoload 'set-rmail-inbox-list "rmailmsc"
+ "Set the inbox list of the current RMAIL file to FILE-NAME.
+This may be a list of file names separated by commas.
+If FILE-NAME is empty, remove any inbox list."
+ t)
+
+;;;; *** Rmail Commands for Labels ***
+
+(autoload 'rmail-add-label "rmailkwd"
+ "Add LABEL to labels associated with current RMAIL message.
+Completion is performed over known labels when reading."
+ t)
+
+(autoload 'rmail-kill-label "rmailkwd"
+ "Remove LABEL from labels associated with current RMAIL message.
+Completion is performed over known labels when reading."
+ t)
+
+(autoload 'rmail-next-labeled-message "rmailkwd"
+ "Show next message with LABEL. Defaults to last label used.
+With prefix argument N moves forward N messages with this label."
+ t)
+
+(autoload 'rmail-previous-labeled-message "rmailkwd"
+ "Show previous message with LABEL. Defaults to last label used.
+With prefix argument N moves backward N messages with this label."
+ t)
+
+;;;; *** Rmail Edit Mode ***
+
+(autoload 'rmail-edit-current-message "rmailedit"
+ "Edit the contents of the current message"
+ t)
+
+;;;; *** Rmail Summary Mode ***
+
+(autoload 'rmail-summary "rmailsum"
+ "Display a summary of all messages, one line per message."
+ t)
+
+(autoload 'rmail-summary-by-labels "rmailsum"
+ "Display a summary of all messages with one or more LABELS.
+LABELS should be a string containing the desired labels, separated by commas."
+ t)
+
+(autoload 'rmail-summary-by-recipients "rmailsum"
+ "Display a summary of all messages with the given RECIPIENTS.
+Normally checks the To, From and Cc fields of headers;
+but if PRIMARY-ONLY is non-nil (prefix arg given),
+ only look in the To and From fields.
+RECIPIENTS is a string of names separated by commas."
+ t)
+
+;;;; *** Rmail output messages to files ***
+
+(autoload 'rmail-output-to-rmail-file "rmailout"
+ "Append the current message to an Rmail file named FILE-NAME.
+If the file does not exist, ask if it should be created.
+If file is being visited, the message is appended to the Emacs
+buffer visiting that file."
+ t)
+
+(autoload 'rmail-output "rmailout"
+ "Append this message to Unix mail file named FILE-NAME."
+ t)
+
+;;;; *** Rmail undigestification ***
+
+(autoload 'undigestify-rmail-message "undigest"
+ "Break up a digest message into its constituent messages.
+Leaves original message, deleted, before the undigestified messages."
+ t)
diff --git a/lisp/rmail.elc b/lisp/rmail.elc
new file mode 100644
index 00000000000..d2f8225c8c1
--- /dev/null
+++ b/lisp/rmail.elc
Binary files differ
diff --git a/lisp/mail/rmailedit.el b/lisp/rmailedit.el
index d5c3dfd3361..1523f529937 100644
--- a/lisp/mail/rmailedit.el
+++ b/lisp/rmailedit.el
@@ -23,7 +23,7 @@
(defvar rmail-edit-map nil)
(if rmail-edit-map
nil
- (setq rmail-edit-map (nconc (make-sparse-keymap) text-mode-map))
+ (setq rmail-edit-map (copy-keymap text-mode-map))
(define-key rmail-edit-map "\C-c\C-c" 'rmail-cease-edit)
(define-key rmail-edit-map "\C-c\C-]" 'rmail-abort-edit))
diff --git a/lisp/rmailedit.elc b/lisp/rmailedit.elc
new file mode 100644
index 00000000000..441d0678a6a
--- /dev/null
+++ b/lisp/rmailedit.elc
Binary files differ
diff --git a/lisp/mail/rmailkwd.el b/lisp/rmailkwd.el
index 11b4cf54813..af48e0f7dec 100644
--- a/lisp/mail/rmailkwd.el
+++ b/lisp/rmailkwd.el
@@ -111,7 +111,7 @@ Completion is performed over known labels when reading."
;; Commented functions aren't used by RMAIL but might be nice for user
;; packages that do stuff with RMAIL. Note that rmail-message-labels-p
-;; is in rmail.el now.
+;; is in rmailsum now.
;(defun rmail-message-attribute-p (attribute &optional n)
; "Returns t if ATTRIBUTE on NTH or current message."
@@ -171,18 +171,14 @@ Completion is performed over known labels when reading."
;; Motion on messages with keywords.
-(defun rmail-previous-labeled-message (n labels)
- "Show previous message with one of the labels LABELS.
-LABELS should be a comma-separated list of label names.
-If LABELS is empty, the last set of labels specified is used.
+(defun rmail-previous-labeled-message (n label)
+ "Show previous message with LABEL. Defaults to last labels used.
With prefix argument N moves backward N messages with these labels."
(interactive "p\nsMove to previous msg with labels: ")
- (rmail-next-labeled-message (- n) labels))
+ (rmail-next-labeled-message (- n) label))
(defun rmail-next-labeled-message (n labels)
- "Show next message with one of the labels LABELS.
-LABELS should be a comma-separated list of label names.
-If LABELS is empty, the last set of labels specified is used.
+ "Show next message with LABEL. Defaults to last labels used.
With prefix argument N moves forward N messages with these labels."
(interactive "p\nsMove to next msg with labels: ")
(if (string= labels "")
diff --git a/lisp/rmailkwd.elc b/lisp/rmailkwd.elc
new file mode 100644
index 00000000000..06c19f50d59
--- /dev/null
+++ b/lisp/rmailkwd.elc
Binary files differ
diff --git a/lisp/mail/rmailmsc.el b/lisp/rmailmsc.el
index c57b15c4c3a..833077c5cc9 100644
--- a/lisp/mail/rmailmsc.el
+++ b/lisp/rmailmsc.el
@@ -18,9 +18,9 @@
(defun set-rmail-inbox-list (file-name)
- "Set the inbox list of the current RMAIL file to FILE-NAME.
-This may be a list of file names separated by commas.
-If FILE-NAME is empty, remove any inbox list."
+ "Set the inbox list of the current RMAIL file to FILE-NAME. This may be
+a list of file names separated by commas. If FILE-NAME is empty, remove
+any inbox list."
(interactive "sSet mailbox list to (comma-separated list of filenames): ")
(save-excursion
(let ((names (rmail-parse-file-inboxes))
diff --git a/lisp/rmailmsc.elc b/lisp/rmailmsc.elc
new file mode 100644
index 00000000000..2a4d648dfaa
--- /dev/null
+++ b/lisp/rmailmsc.elc
Binary files differ
diff --git a/lisp/rmailout.el b/lisp/rmailout.el
new file mode 100644
index 00000000000..f946818f0c2
--- /dev/null
+++ b/lisp/rmailout.el
@@ -0,0 +1,126 @@
+;; "RMAIL" mail reader for Emacs: output message to a file.
+;; Copyright (C) 1985, 1987 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+;; Temporary until Emacs always has this variable.
+(defvar rmail-delete-after-output nil
+ "*Non-nil means automatically delete a message that is copied to a file.")
+
+(defun rmail-output-to-rmail-file (file-name)
+ "Append the current message to an Rmail file named FILE-NAME.
+If the file does not exist, ask if it should be created.
+If file is being visited, the message is appended to the Emacs
+buffer visiting that file."
+ (interactive (list (read-file-name
+ (concat "Output message to Rmail file: (default "
+ (file-name-nondirectory rmail-last-rmail-file)
+ ") ")
+ (file-name-directory rmail-last-rmail-file)
+ rmail-last-rmail-file)))
+ (setq file-name (expand-file-name file-name))
+ (setq rmail-last-rmail-file file-name)
+ (rmail-maybe-set-message-counters)
+ (or (get-file-buffer file-name)
+ (file-exists-p file-name)
+ (if (yes-or-no-p
+ (concat "\"" file-name "\" does not exist, create it? "))
+ (let ((file-buffer (create-file-buffer file-name)))
+ (save-excursion
+ (set-buffer file-buffer)
+ (rmail-insert-rmail-file-header)
+ (let ((require-final-newline nil))
+ (write-region (point-min) (point-max) file-name t 1)))
+ (kill-buffer file-buffer))
+ (error "Output file does not exist")))
+ (save-restriction
+ (widen)
+ ;; Decide whether to append to a file or to an Emacs buffer.
+ (save-excursion
+ (let ((buf (get-file-buffer file-name))
+ (cur (current-buffer))
+ (beg (1+ (rmail-msgbeg rmail-current-message)))
+ (end (1+ (rmail-msgend rmail-current-message))))
+ (if (not buf)
+ (append-to-file beg end file-name)
+ (if (eq buf (current-buffer))
+ (error "Can't output message to same file it's already in"))
+ ;; File has been visited, in buffer BUF.
+ (set-buffer buf)
+ (let ((buffer-read-only nil)
+ (msg (and (boundp 'rmail-current-message)
+ rmail-current-message)))
+ ;; If MSG is non-nil, buffer is in RMAIL mode.
+ (if msg
+ (rmail-maybe-set-message-counters))
+ (widen)
+ (narrow-to-region (point-max) (point-max))
+ (insert-buffer-substring cur beg end)
+ (if msg
+ (progn
+ (goto-char (point-min))
+ (widen)
+ (search-backward "\^_")
+ (narrow-to-region (point) (point-max))
+ (goto-char (1+ (point-min)))
+ (rmail-count-new-messages t)
+ (rmail-show-message msg))))))))
+ (rmail-set-attribute "filed" t)
+ (and rmail-delete-after-output (rmail-delete-forward)))
+
+(defun rmail-output (file-name)
+ "Append this message to Unix mail file named FILE-NAME."
+ (interactive
+ (list
+ (read-file-name
+ (concat "Output message to Unix mail file"
+ (if rmail-last-file
+ (concat " (default "
+ (file-name-nondirectory rmail-last-file)
+ "): " )
+ ": "))
+ (and rmail-last-file (file-name-directory rmail-last-file))
+ rmail-last-file)))
+ (setq file-name (expand-file-name file-name))
+ (setq rmail-last-file file-name)
+ (let ((rmailbuf (current-buffer))
+ (tembuf (get-buffer-create " rmail-output"))
+ (case-fold-search t))
+ (save-excursion
+ (set-buffer tembuf)
+ (erase-buffer)
+ (insert-buffer-substring rmailbuf)
+ (insert "\n")
+ (goto-char (point-min))
+ (insert "From "
+ (if (mail-fetch-field "from")
+ (mail-strip-quoted-names (mail-fetch-field "from"))
+ "unknown")
+ " " (current-time-string) "\n")
+ ;; ``Quote'' "\nFrom " as "\n>From "
+ ;; (note that this isn't really quoting, as there is no requirement
+ ;; that "\n[>]+From " be quoted in the same transparent way.)
+ (while (search-forward "\nFrom " nil t)
+ (forward-char -5)
+ (insert ?>))
+ (append-to-file (point-min) (point-max) file-name))
+ (kill-buffer tembuf))
+ (if (equal major-mode 'rmail-mode)
+ (progn
+ (rmail-set-attribute "filed" t)
+ (and rmail-delete-after-output (rmail-delete-forward)))))
diff --git a/lisp/rmailout.elc b/lisp/rmailout.elc
new file mode 100644
index 00000000000..8362ea92fe7
--- /dev/null
+++ b/lisp/rmailout.elc
Binary files differ
diff --git a/lisp/mail/rmailsum.el b/lisp/rmailsum.el
index fc8854f153d..aa32363f1ce 100644
--- a/lisp/mail/rmailsum.el
+++ b/lisp/rmailsum.el
@@ -59,28 +59,6 @@ RECIPIENTS is a string of names separated by commas."
(if (not primary-only)
(string-match recipients (or (mail-fetch-field "Cc") ""))))))
-(defun rmail-summary-by-regexp (regexp)
- "Display a summary of all messages according to regexp REGEXP.
-If the regular expression is found in the header of the message
-\(including in the date and other lines, as well as the subject line),
-Emacs will list the header line in the RMAIL-summary."
- (interactive "sRegexp to summarize by: ")
- (if (string= regexp "")
- (setq regexp (or rmail-last-regexp
- (error "No regexp specified"))))
- (setq rmail-last-regexp regexp)
- (rmail-new-summary (concat "regexp " regexp)
- 'rmail-message-regexp-p
- regexp))
-
-(defun rmail-message-regexp-p (msg regexp)
- "Return t, if for message number MSG, regexp REGEXP matches in the header."
- (goto-char (rmail-msgbeg msg))
- (let ((end
- (save-excursion
- (search-forward "*** EOOH ***" (point-max)) (point))))
- (re-search-forward regexp end t)))
-
(defun rmail-new-summary (description function &rest args)
"Create a summary of selected messages.
DESCRIPTION makes part of the mode line of the summary buffer.
@@ -112,9 +90,6 @@ nil for FUNCTION means all messages."
(total rmail-total-messages)
(mesg rmail-current-message))
(pop-to-buffer sbuf)
- ;; Our scroll command should always scroll the Rmail buffer.
- (make-local-variable 'other-window-scroll-buffer)
- (setq other-window-scroll-buffer rbuf)
(let ((buffer-read-only nil))
(erase-buffer)
(cond (summary-msgs
@@ -315,20 +290,6 @@ nil for FUNCTION means all messages."
(insert "D"))
(rmail-summary-next-msg 1)))
-(defun rmail-summary-delete-backward ()
- (interactive)
- (let (end)
- (rmail-summary-goto-msg)
- (pop-to-buffer rmail-buffer)
- (rmail-delete-message)
- (pop-to-buffer rmail-summary-buffer)
- (let ((buffer-read-only nil))
- (skip-chars-forward " ")
- (skip-chars-forward "[0-9]")
- (delete-char 1)
- (insert "D"))
- (rmail-summary-next-msg -1)))
-
(defun rmail-summary-undelete ()
(interactive)
(let ((buffer-read-only nil))
@@ -354,11 +315,10 @@ mail message is displayed in the rmail buffer.
n Move to next undeleted message, or arg messages.
p Move to previous undeleted message, or arg messages.
-M-n Move to next, or forward arg messages.
-M-p Move to previous, or previous arg messages.
+C-n Move to next, or forward arg messages.
+C-p Move to previous, or previous arg messages.
j Jump to the message at the cursor location.
d Delete the message at the cursor location and move to next message.
-C-d Delete the message at the cursor location and move to previous message.
u Undelete this or previous deleted message.
q Quit Rmail.
x Exit and kill the summary window.
@@ -423,15 +383,14 @@ Entering this mode calls value of hook variable rmail-summary-mode-hook."
(define-key rmail-summary-mode-map "j" 'rmail-summary-goto-msg)
(define-key rmail-summary-mode-map "n" 'rmail-summary-next-msg)
(define-key rmail-summary-mode-map "p" 'rmail-summary-previous-msg)
- (define-key rmail-summary-mode-map "\en" 'rmail-summary-next-all)
- (define-key rmail-summary-mode-map "\ep" 'rmail-summary-previous-all)
+ (define-key rmail-summary-mode-map "\C-n" 'rmail-summary-next-all)
+ (define-key rmail-summary-mode-map "\C-p" 'rmail-summary-previous-all)
(define-key rmail-summary-mode-map " " 'rmail-summary-scroll-msg-up)
(define-key rmail-summary-mode-map "q" 'rmail-summary-quit)
(define-key rmail-summary-mode-map "u" 'rmail-summary-undelete)
(define-key rmail-summary-mode-map "x" 'rmail-summary-exit)
(define-key rmail-summary-mode-map "\177" 'rmail-summary-scroll-msg-down)
- (define-key rmail-summary-mode-map "d" 'rmail-summary-delete-forward)
- (define-key rmail-summary-mode-map "\C-d" 'rmail-summary-delete-backward))
+ (define-key rmail-summary-mode-map "d" 'rmail-summary-delete-forward))
(defun rmail-summary-scroll-msg-up (&optional dist)
"Scroll other window forward."
diff --git a/lisp/rmailsum.elc b/lisp/rmailsum.elc
new file mode 100644
index 00000000000..d39f5a4e28c
--- /dev/null
+++ b/lisp/rmailsum.elc
Binary files differ
diff --git a/lisp/mail/rnews.el b/lisp/rnews.el
index 64b98ca407b..821c5f4e8f0 100644
--- a/lisp/mail/rnews.el
+++ b/lisp/rnews.el
@@ -72,11 +72,6 @@ While composing the reply, use \\[mail-yank-original] to yank the original
message into it."
t)
-(defvar news-group-hook-alist nil
- "Alist of (GROUP-REGEXP . HOOK) pairs.
-Just before displaying a message, each HOOK is called
-if its GROUP-REGEXP matches the current newsgroup name.")
-
(defvar rmail-last-file (expand-file-name "~/mbox.news"))
;Now in paths.el.
@@ -500,7 +495,7 @@ to a list (a . b)"
(defun news-select-news-group (gp)
(let ((grp (assoc gp news-group-article-assoc)))
(if (null grp)
- (error "Group %s not subscribed to" gp)
+ (error "Group not subscribed to in file %s." news-startup-file)
(progn
(news-update-message-read news-current-news-group
(news-cdar news-point-pdl))
@@ -519,15 +514,16 @@ to a list (a . b)"
(let ((file (concat news-path
(string-subst-char ?/ ?. news-current-news-group)
"/" arg)))
+ (if (= arg
+ (or (news-cadr (memq (news-cdar news-point-pdl) news-list-of-files))
+ 0))
+ (setcdr (car news-point-pdl) arg))
+ (setq news-current-message-number arg)
(if (file-exists-p file)
- (let ((buffer-read-only ()))
- (if (= arg
- (or (news-cadr (memq (news-cdar news-point-pdl) news-list-of-files))
- 0))
- (setcdr (car news-point-pdl) arg))
- (setq news-current-message-number arg)
- (news-read-in-file file)
- (news-set-mode-line))
+ (let ((buffer-read-only nil))
+ (news-read-in-file file)
+ (news-set-mode-line))
+ (news-set-mode-line)
(error "Article %d nonexistent" arg))))
(defun news-force-update ()
@@ -613,13 +609,6 @@ one for moving forward and one for moving backward."
(let ((start (point)))
(insert-file-contents filename)
(news-convert-format)
- ;; Run each hook that applies to the current newsgroup.
- (let ((hooks news-group-hook-alist))
- (while hooks
- (goto-char start)
- (if (string-match (car (car hooks)) news-group-name)
- (funcall (cdr (car hooks))))
- (setq hooks (cdr hooks))))
(goto-char start)
(forward-line 1)
(if (eobp)
@@ -691,10 +680,11 @@ one for moving forward and one for moving backward."
(save-excursion
(if (not (null news-current-news-group))
(news-update-message-read news-current-news-group
- (news-cdar news-point-pdl)))
- (set-buffer newsrcbuf)
+ (news-cdar news-point-pdl)))
+ (switch-to-buffer newsrcbuf)
(while tem
- (setq group (assoc (car tem) news-group-article-assoc))
+ (setq group (assoc (car tem)
+ news-group-article-assoc))
(if (= (news-cadr (news-cadr group)) (news-caddr (news-cadr group)))
nil
(goto-char 0)
diff --git a/lisp/rnews.elc b/lisp/rnews.elc
new file mode 100644
index 00000000000..1dab31f99da
--- /dev/null
+++ b/lisp/rnews.elc
Binary files differ
diff --git a/lisp/mail/rnewspost.el b/lisp/rnewspost.el
index adb65e6f3ab..000520fcd39 100644
--- a/lisp/mail/rnewspost.el
+++ b/lisp/rnewspost.el
@@ -116,13 +116,8 @@ and don't delete any header fields."
(interactive "P")
(mail-yank-original arg)
(exchange-point-and-mark)
- (run-hooks 'news-reply-header-hook))
-
-(defvar news-reply-header-hook
- '(lambda ()
- (insert "In article " news-reply-yank-message-id
- " " news-reply-yank-from " writes:\n\n"))
- "Hook for inserting a header at the top of a yanked message.")
+ (insert "In article " news-reply-yank-message-id
+ " " news-reply-yank-from " writes:\n\n"))
(defun news-reply-newsgroups ()
"Move point to end of Newsgroups: field.
@@ -192,11 +187,11 @@ news-reply-mode."
;; the fcc: and bcc: fields
(let ((mail-self-blind nil)
(mail-archive-file-name nil))
- (mail-setup to subject in-reply-to nil replybuffer nil)
+ (mail-setup to subject in-reply-to nil replybuffer)
(beginning-of-line)
- (kill-line 1)
+ (delete-region (point) (progn (forward-line 1) (point)))
(goto-char (point-max)))
- (mail-setup to subject in-reply-to nil replybuffer nil))
+ (mail-setup to subject in-reply-to nil replybuffer))
;;;(mail-position-on-field "Posting-Front-End")
;;;(insert (emacs-version))
(goto-char (point-max))
diff --git a/lisp/rnewspost.elc b/lisp/rnewspost.elc
new file mode 100644
index 00000000000..f05445290f1
--- /dev/null
+++ b/lisp/rnewspost.elc
Binary files differ
diff --git a/lisp/saveconf.el b/lisp/saveconf.el
new file mode 100644
index 00000000000..68d34fca8d6
--- /dev/null
+++ b/lisp/saveconf.el
@@ -0,0 +1,240 @@
+;;; Save Emacs buffer and window configuration between editing sessions.
+;;; Copyright (C) 1987, 1988 Kyle E. Jones
+;;;
+;;; 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.
+
+(provide 'saveconf)
+
+(defconst save-context-version "Norma Jean"
+ "A unique string which is placed at the beginning of every saved context
+file. If the string at the beginning of the context file doesn't match the
+value of this variable the `recover-context' command will ignore the file's
+contents.")
+
+(defvar auto-save-and-recover-context nil
+ "*If non-nil the `save-context' command will always be run before Emacs is
+exited. Also upon Emacs startup, if this variable is non-nil and Emacs is
+passed no command line arguments, `recover-context' will be run.")
+
+(defvar save-buffer-context nil
+ "*If non-nil the `save-context' command will save the context
+of buffers that are visiting files, as well as the contexts of buffers
+that have windows.")
+
+(defvar save-context-predicate
+ (function (lambda (w)
+ (and (buffer-file-name (window-buffer w))
+ (not (string-match "^\\(/usr\\)?/tmp/"
+ (buffer-file-name (window-buffer w)))))))
+ "*Value is a predicate function which determines which windows' contexts
+are saved. When the `save-context' command is invoked, this function will
+be called once for each existing Emacs window. The function should accept
+one argument which will be a window object, and should return non-nil if
+the window's context should be saved.")
+
+
+;; kill-emacs' function definition must be saved
+(if (not (fboundp 'just-kill-emacs))
+ (fset 'just-kill-emacs (symbol-function 'kill-emacs)))
+
+;; Make Emacs call recover-context at startup if appropriate.
+(setq top-level
+ (list 'let '((starting-up (not command-line-processed)))
+ (list 'prog1
+ top-level
+ '(and starting-up auto-save-and-recover-context
+ (null (cdr command-line-args)) (recover-context)))))
+
+(defun kill-emacs (&optional query)
+ "End this Emacs session.
+Prefix ARG or optional first ARG non-nil means exit with no questions asked,
+even if there are unsaved buffers. If Emacs is running non-interactively
+and ARG is an integer, then Emacs exits with ARG as its exit code.
+
+If the variable `auto-save-and-restore-context' is non-nil,
+the function save-context will be called first."
+ (interactive "P")
+ ;; check the purify flag. try to save only if this is a dumped Emacs.
+ ;; saving context from a undumped Emacs caused a NULL pointer to be
+ ;; referenced through. I'm not sure why.
+ (if (and auto-save-and-recover-context (null purify-flag))
+ (save-context))
+ (just-kill-emacs query))
+
+(defun save-context ()
+ "Save context of all Emacs windows (files visited and position of point).
+The information goes into a file called .emacs_<username> in the directory
+where the Emacs session was started. The context can be recovered with the
+`recover-context' command, provided you are in the same directory where
+the context was saved.
+
+If the variable `save-buffer-context' is non-nil, the context of all buffers
+visiting files will be saved as well.
+
+Window sizes and shapes are not saved, since these may not be recoverable
+on terminals with a different number of rows and columns."
+ (interactive)
+ (condition-case error-data
+ (let (context-buffer mark save-file-name)
+ (setq save-file-name (concat (original-working-directory)
+ ".emacs_" (user-login-name)))
+ (if (not (file-writable-p save-file-name))
+ (if (file-writable-p (original-working-directory))
+ (error "context is write-protected, %s" save-file-name)
+ (error "can't access directory, %s"
+ (original-working-directory))))
+ ;;
+ ;; set up a buffer for the saved context information
+ ;; Note that we can't set the visited file yet, because by
+ ;; giving the buffer a file to visit we are making it
+ ;; eligible to have it's context saved.
+ ;;
+ (setq context-buffer (get-buffer-create " *Context Info*"))
+ (set-buffer context-buffer)
+ (erase-buffer)
+ (set-buffer-modified-p nil)
+ ;;
+ ;; record the context information
+ ;;
+ (mapcar
+ (function
+ (lambda (w)
+ (cond ((funcall save-context-predicate w)
+ (prin1 (buffer-file-name (window-buffer w)) context-buffer)
+ (princ " " context-buffer)
+ (prin1 (window-point w) context-buffer)
+ (princ "\n" context-buffer)))))
+ (window-list))
+
+ ;;
+ ;; nil is the data sentinel. We will insert it later if we
+ ;; need it but for now just remember where the last line of
+ ;; window context ended.
+ ;;
+ (setq mark (point))
+
+ ;;
+ ;; If `save-buffer-context' is non-nil we save buffer contexts.
+ ;;
+ (if save-buffer-context
+ (mapcar
+ (function
+ (lambda (b)
+ (set-buffer b)
+ (cond (buffer-file-name
+ (prin1 buffer-file-name context-buffer)
+ (princ " " context-buffer)
+ (prin1 (point) context-buffer)
+ (princ "\n" context-buffer)))))
+ (buffer-list)))
+
+ ;;
+ ;; If the context-buffer contains information, we add the version
+ ;; string and sentinels, and write out the saved context.
+ ;; If the context-buffer is empty, we don't create a file at all.
+ ;; If there's an old saved context in this directory we attempt
+ ;; to delete it.
+ ;;
+ (cond ((buffer-modified-p context-buffer)
+ (set-buffer context-buffer)
+ (setq buffer-offer-save nil)
+ ;; sentinel for EOF
+ (insert "nil\n")
+ ;; sentinel for end of window contexts
+ (goto-char mark)
+ (insert "nil\n")
+ ;; version string
+ (goto-char (point-min))
+ (prin1 save-context-version context-buffer)
+ (insert "\n\n")
+ ;; so kill-buffer won't need confirmation later
+ (set-buffer-modified-p nil)
+ ;; save it
+ (write-region (point-min) (point-max) save-file-name
+ nil 'quiet))
+ (t (condition-case data
+ (delete-file save-file-name) (error nil))))
+
+ (kill-buffer context-buffer))
+ (error nil)))
+
+(defun recover-context ()
+ "Recover an Emacs context saved by `save-context' command.
+Files that were visible in windows when the context was saved are visited and
+point is set in each window to what is was when the context was saved."
+ (interactive)
+ ;;
+ ;; Set up some local variables.
+ ;;
+ (condition-case error-data
+ (let (sexpr context-buffer recover-file-name)
+ (setq recover-file-name (concat (original-working-directory)
+ ".emacs_" (user-login-name)))
+ (if (not (file-readable-p recover-file-name))
+ (error "can't access context, %s" recover-file-name))
+ ;;
+ ;; create a temp buffer and copy the saved context into it.
+ ;;
+ (setq context-buffer (get-buffer-create " *Recovered Context*"))
+ (set-buffer context-buffer)
+ (erase-buffer)
+ (insert-file-contents recover-file-name nil)
+ ;; so kill-buffer won't need confirmation later
+ (set-buffer-modified-p nil)
+ ;;
+ ;; If it's empty forget it.
+ ;;
+ (if (zerop (buffer-size))
+ (error "context file is empty, %s" recover-file-name))
+ ;;
+ ;; check the version and make sure it matches ours
+ ;;
+ (setq sexpr (read context-buffer))
+ (if (not (equal sexpr save-context-version))
+ (error "version string incorrect, %s" sexpr))
+ ;;
+ ;; Recover the window contexts
+ ;;
+ (while (setq sexpr (read context-buffer))
+ (select-window (get-largest-window))
+ (if (buffer-file-name)
+ (split-window))
+ (other-window 1)
+ (find-file sexpr)
+ (goto-char (read context-buffer)))
+ ;;
+ ;; Recover buffer contexts, if any.
+ ;;
+ (while (setq sexpr (read context-buffer))
+ (set-buffer (find-file-noselect sexpr))
+ (goto-char (read context-buffer)))
+ (bury-buffer "*scratch*")
+ (kill-buffer context-buffer))
+ (error nil)))
+
+(defun original-working-directory ()
+ (save-excursion
+ (set-buffer (get-buffer-create "*scratch*"))
+ default-directory))
+
+(defun window-list (&optional mini)
+ "Returns a list of Lisp window objects for all Emacs windows.
+Optional first arg MINIBUF t means include the minibuffer window
+in the list, even if it is not active. If MINIBUF is neither t
+nor nil it means to not count the minibuffer window even if it is active."
+ (let* ((first-window (next-window (previous-window (selected-window)) mini))
+ (windows (cons first-window nil))
+ (current-cons windows)
+ (w (next-window first-window mini)))
+ (while (not (eq w first-window))
+ (setq current-cons (setcdr current-cons (cons w nil)))
+ (setq w (next-window w mini)))
+ windows))
+
diff --git a/lisp/progmodes/scheme.el b/lisp/scheme.el
index 9cf1595b7e4..733696eddd3 100644
--- a/lisp/progmodes/scheme.el
+++ b/lisp/scheme.el
@@ -1,5 +1,5 @@
;; Scheme mode, and its idiosyncratic commands.
-;; Copyright (C) 1986, 1987, 1988 Free Software Foundation, Inc.
+;; Copyright (C) 1986, 1987, 1988, 1990 Free Software Foundation, Inc.
;; Adapted from Lisp mode by Bill Rozas, jinx@prep.
;; This file is part of GNU Emacs.
@@ -65,20 +65,20 @@
(modify-syntax-entry ?] ")[ ")
(modify-syntax-entry ?{ "(} ")
(modify-syntax-entry ?} "){ ")
- (modify-syntax-entry ?\| " 23")
+ (modify-syntax-entry ?\| " ")
;; Other atom delimiters
(modify-syntax-entry ?\( "() ")
(modify-syntax-entry ?\) ")( ")
(modify-syntax-entry ?\; "< ")
(modify-syntax-entry ?\" "\" ")
- (modify-syntax-entry ?' " p")
- (modify-syntax-entry ?` " p")
+ (modify-syntax-entry ?' "' ")
+ (modify-syntax-entry ?` "' ")
;; Special characters
- (modify-syntax-entry ?, "_ p")
- (modify-syntax-entry ?@ "_ p")
- (modify-syntax-entry ?# "_ p14")
+ (modify-syntax-entry ?, "' ")
+ (modify-syntax-entry ?@ "' ")
+ (modify-syntax-entry ?# "' ")
(modify-syntax-entry ?\\ "\\ ")))
(defvar scheme-mode-abbrev-table nil "")
@@ -163,7 +163,7 @@ Set this to nil if you normally use another dialect.")
comment-column)))))
(defvar scheme-indent-offset nil "")
-(defvar scheme-indent-function 'scheme-indent-function "")
+(defvar scheme-indent-hook 'scheme-indent-hook "")
(defun scheme-indent-line (&optional whole-exp)
"Indent current line as Scheme code.
@@ -276,17 +276,17 @@ of the start of the containing expression."
(goto-char containing-sexp)
(setq desired-indent (+ scheme-indent-offset (current-column))))
((not (or desired-indent
- (and (boundp 'scheme-indent-function)
- scheme-indent-function
+ (and (boundp 'scheme-indent-hook)
+ scheme-indent-hook
(not retry)
(setq desired-indent
- (funcall scheme-indent-function
+ (funcall scheme-indent-hook
indent-point state)))))
;; Use default indentation if not computed yet
(setq desired-indent (current-column))))
desired-indent)))
-(defun scheme-indent-function (indent-point state)
+(defun scheme-indent-hook (indent-point state)
(let ((normal-indent (current-column)))
(save-excursion
(goto-char (1+ (car (cdr state))))
@@ -298,7 +298,7 @@ of the start of the containing expression."
;; Who cares about this, really?
;(if (not (string-match "\\\\\\||" function)))
(setq function (downcase function))
- (setq method (get (intern-soft function) 'scheme-indent-function))
+ (setq method (get (intern-soft function) 'scheme-indent-hook))
(cond ((integerp method)
(scheme-indent-specform method state indent-point))
(method
@@ -314,7 +314,7 @@ of the start of the containing expression."
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
+ ;; function symbol. scheme-indent-hook guarantees that there is at
;; least one word or symbol character following open paren of containing
;; form.
(goto-char containing-form-start)
@@ -381,70 +381,70 @@ of the start of the containing expression."
(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
+;; (put 'begin 'scheme-indent-hook 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)
+(put 'begin 'scheme-indent-hook 0)
+(put 'case 'scheme-indent-hook 1)
+(put 'delay 'scheme-indent-hook 0)
+(put 'do 'scheme-indent-hook 2)
+(put 'lambda 'scheme-indent-hook 1)
+(put 'let 'scheme-indent-hook 'scheme-let-indent)
+(put 'let* 'scheme-indent-hook 1)
+(put 'letrec 'scheme-indent-hook 1)
+(put 'sequence 'scheme-indent-hook 0)
+
+(put 'call-with-input-file 'scheme-indent-hook 1)
+(put 'with-input-from-file 'scheme-indent-hook 1)
+(put 'with-input-from-port 'scheme-indent-hook 1)
+(put 'call-with-output-file 'scheme-indent-hook 1)
+(put 'with-output-to-file 'scheme-indent-hook 1)
+(put 'with-output-to-port 'scheme-indent-hook 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)))
+ (put 'fluid-let 'scheme-indent-hook 1)
+ (put 'in-package 'scheme-indent-hook 1)
+ (put 'let-syntax 'scheme-indent-hook 1)
+ (put 'local-declare 'scheme-indent-hook 1)
+ (put 'macro 'scheme-indent-hook 1)
+ (put 'make-environment 'scheme-indent-hook 0)
+ (put 'named-lambda 'scheme-indent-hook 1)
+ (put 'using-syntax 'scheme-indent-hook 1)
+
+ (put 'with-input-from-string 'scheme-indent-hook 1)
+ (put 'with-output-to-string 'scheme-indent-hook 0)
+ (put 'with-values 'scheme-indent-hook 1)
+
+ (put 'syntax-table-define 'scheme-indent-hook 2)
+ (put 'list-transform-positive 'scheme-indent-hook 1)
+ (put 'list-transform-negative 'scheme-indent-hook 1)
+ (put 'list-search-positive 'scheme-indent-hook 1)
+ (put 'list-search-negative 'scheme-indent-hook 1)
+
+ (put 'access-components 'scheme-indent-hook 1)
+ (put 'assignment-components 'scheme-indent-hook 1)
+ (put 'combination-components 'scheme-indent-hook 1)
+ (put 'comment-components 'scheme-indent-hook 1)
+ (put 'conditional-components 'scheme-indent-hook 1)
+ (put 'disjunction-components 'scheme-indent-hook 1)
+ (put 'declaration-components 'scheme-indent-hook 1)
+ (put 'definition-components 'scheme-indent-hook 1)
+ (put 'delay-components 'scheme-indent-hook 1)
+ (put 'in-package-components 'scheme-indent-hook 1)
+ (put 'lambda-components 'scheme-indent-hook 1)
+ (put 'lambda-components* 'scheme-indent-hook 1)
+ (put 'lambda-components** 'scheme-indent-hook 1)
+ (put 'open-block-components 'scheme-indent-hook 1)
+ (put 'pathname-components 'scheme-indent-hook 1)
+ (put 'procedure-components 'scheme-indent-hook 1)
+ (put 'sequence-components 'scheme-indent-hook 1)
+ (put 'unassigned\?-components 'scheme-indent-hook 1)
+ (put 'unbound\?-components 'scheme-indent-hook 1)
+ (put 'variable-components 'scheme-indent-hook 1)))
(defun scheme-indent-sexp ()
"Indent each line of the list starting just after point."
diff --git a/lisp/scheme.elc b/lisp/scheme.elc
new file mode 100644
index 00000000000..fca6c89a168
--- /dev/null
+++ b/lisp/scheme.elc
Binary files differ
diff --git a/lisp/textmodes/scribe.el b/lisp/scribe.el
index 48002bd4029..257c93efd5a 100644
--- a/lisp/textmodes/scribe.el
+++ b/lisp/scribe.el
@@ -1,21 +1,21 @@
;; scribe mode, and its ideosyncratic commands.
;; Copyright (C) 1985 Free Software Foundation, Inc.
-;; This file might become part of GNU Emacs.
+;; 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 1, or (at your option)
+;; any later version.
;; 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.
+;; 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, 675 Mass Ave, Cambridge, MA 02139, USA.
(defvar scribe-mode-syntax-table nil
diff --git a/lisp/scribe.elc b/lisp/scribe.elc
new file mode 100644
index 00000000000..e54d4364876
--- /dev/null
+++ b/lisp/scribe.elc
Binary files differ
diff --git a/lisp/sendmail.el b/lisp/sendmail.el
new file mode 100644
index 00000000000..18a153d24ed
--- /dev/null
+++ b/lisp/sendmail.el
@@ -0,0 +1,469 @@
+;; Mail sending commands for Emacs.
+;; Copyright (C) 1985, 1986 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+(provide 'sendmail)
+
+;(defconst 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.")
+
+;(defconst 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.")
+
+;(defconst 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.")
+;(defvar send-mail-function 'sendmail-send-it
+; "Function to call to send the current buffer as mail.
+;The headers are be delimited by a line which is mail-header-separator"")
+
+; really defined in loaddefs for emacs 17.17+
+;(defvar mail-header-separator "--text follows this line--"
+; "*Line used to separate headers from text in messages being composed.")
+; really defined in loaddefs for emacs 17.17+
+;(defvar mail-archive-file-name nil
+; "*Name of file to write all outgoing messages in, or nil for none.")
+; really defined in loaddefs for emacs 17.17+
+(defvar mail-aliases t
+ "Alias of mail address aliases,
+or t meaning should be initialized from .mailrc.")
+
+(defvar mail-default-reply-to nil
+ "*Address to insert as default Reply-to field of outgoing messages.")
+
+(defvar mail-abbrevs-loaded nil)
+(defvar mail-mode-map nil)
+
+(autoload 'build-mail-aliases "mailalias"
+ "Read mail aliases from ~/.mailrc and set mail-aliases."
+ nil)
+
+(autoload 'expand-mail-aliases "mailalias"
+ "Expand all mail aliases in suitable header fields found between BEG and END.
+Suitable header fields are To, CC and BCC."
+ nil)
+
+(defun mail-setup (to subject in-reply-to cc replybuffer)
+ (if (eq mail-aliases t)
+ (progn
+ (setq mail-aliases nil)
+ (if (file-exists-p "~/.mailrc")
+ (build-mail-aliases))))
+ (setq mail-reply-buffer replybuffer)
+ (goto-char (point-min))
+ (insert "To: ")
+ (save-excursion
+ (if to
+ (progn
+ (insert to "\n")
+ ;;; 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"))
+ (fill-region (point-min) (point-max))))
+ (newline))
+ (if cc
+ (let ((opos (point))
+ (fill-prefix "\t"))
+ (insert "CC: " cc "\n")
+ (fill-region-as-paragraph opos (point-max))))
+ (if in-reply-to
+ (insert "In-reply-to: " in-reply-to "\n"))
+ (insert "Subject: " (or subject "") "\n")
+ (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"))
+ (if to (goto-char (point-max)))
+ (or to subject in-reply-to
+ (set-buffer-modified-p nil))
+ (run-hooks 'mail-setup-hook))
+
+(defun mail-mode ()
+ "Major mode for editing mail to be sent.
+Separate names of recipients (in To: and Cc: fields) with commas.
+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-w mail-signature (insert ~/.signature at end).
+C-c C-y mail-yank-original (insert current message, in Rmail).
+C-c C-q mail-fill-yanked-message (fill what was yanked)."
+ (interactive)
+ (kill-all-local-variables)
+ (make-local-variable 'mail-reply-buffer)
+ (setq mail-reply-buffer nil)
+ (set-syntax-table text-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)
+ (make-local-variable 'paragraph-separate)
+ (make-local-variable 'paragraph-start)
+ (setq paragraph-start (concat "^" mail-header-separator
+ "$\\|^[ \t]*[-_][-_][-_]+$\\|"
+ paragraph-start))
+ (setq paragraph-separate (concat "^" mail-header-separator
+ "$\\|^[ \t]*[-_][-_][-_]+$\\|"
+ paragraph-separate))
+ (run-hooks 'text-mode-hook 'mail-mode-hook))
+
+(if mail-mode-map
+ nil
+ (setq mail-mode-map (make-sparse-keymap))
+ (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-c" 'mail-cc)
+ (define-key mail-mode-map "\C-c\C-f\C-s" 'mail-subject)
+ (define-key mail-mode-map "\C-c\C-w" 'mail-signature) ; who
+ (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-c" 'mail-send-and-exit)
+ (define-key mail-mode-map "\C-c\C-s" 'mail-send))
+
+(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)
+ (bury-buffer (current-buffer))
+ (if (and (not arg)
+ (not (one-window-p))
+ (save-excursion
+ (set-buffer (window-buffer (next-window (selected-window) 'not)))
+ (eq major-mode 'rmail-mode)))
+ (delete-window)
+ (switch-to-buffer (other-buffer (current-buffer)))))
+
+(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)
+ (message "Sending...")
+ (funcall send-mail-function)
+ (set-buffer-modified-p nil)
+ (delete-auto-save-file-if-necessary)
+ (message "Sending...done"))
+
+(defun sendmail-send-it ()
+ (let ((errbuf (if mail-interactive
+ (generate-new-buffer " sendmail errors")
+ 0))
+ (tembuf (generate-new-buffer " sendmail temp"))
+ (case-fold-search nil)
+ delimline
+ (mailbuf (current-buffer)))
+ (unwind-protect
+ (save-excursion
+ (set-buffer tembuf)
+ (setq buffer-undo-list t)
+ (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))
+ (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))
+ ;; Find and handle any FCC fields.
+ (goto-char (point-min))
+ (if (re-search-forward "^FCC:" delimline t)
+ (mail-do-fcc delimline))
+ ;; If there is a From and no Sender, put it a Sender.
+ (goto-char (point-min))
+ (and (re-search-forward "^From:" delimline t)
+ (not (save-excursion
+ (goto-char (point-min))
+ (re-search-forward "^Sender:" delimline t)))
+ (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" delimline t)
+ (replace-match ""))
+ (if mail-interactive
+ (save-excursion
+ (set-buffer errbuf)
+ (erase-buffer))))
+ (apply 'call-process-region
+ (append (list (point-min) (point-max)
+ (if (boundp 'sendmail-program)
+ sendmail-program
+ "/usr/lib/sendmail")
+ nil errbuf nil
+ "-oi" "-t")
+ ;; 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)))
+ ;; These mean "report errors by mail"
+ ;; and "deliver in background".
+ (if (null mail-interactive) '("-oem" "-odb"))))
+ (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)))))
+
+(defun mail-do-fcc (header-end)
+ (let (fcc-list
+ (rmailbuf (current-buffer))
+ timezone
+ (tembuf (generate-new-buffer " rmail output"))
+ (case-fold-search t))
+ (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)
+ (call-process "date" nil t nil)
+ (goto-char (point-min))
+ (re-search-forward
+ "[0-9] \\([A-Za-z][A-Za-z ]*[A-Za-z]\\)[0-9 ]*$")
+ (setq timezone (buffer-substring (match-beginning 1) (match-end 1)))
+ (erase-buffer)
+ (insert "\nFrom " (user-login-name) " "
+ (current-time-string) "\n")
+ ;; Insert the time zone before the year.
+ (forward-char -1)
+ (forward-word -1)
+ (insert timezone " ")
+ (goto-char (point-max))
+ (insert-buffer-substring rmailbuf)
+ ;; Make sure messages are separated.
+ (goto-char (point-max))
+ (insert ?\n)
+ (goto-char 2)
+ ;; ``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 ?>)))
+ (while fcc-list
+ (let ((buffer (get-file-buffer (car fcc-list))))
+ (if buffer
+ ;; File is present in a buffer => append to that buffer.
+ (let ((curbuf (current-buffer))
+ (beg (point-min)) (end (point-max)))
+ (save-excursion
+ (set-buffer buffer)
+ (goto-char (point-max))
+ (insert-buffer-substring curbuf beg end)))
+ ;; Else append to the file directly.
+ (write-region (point-min) (point-max) (car fcc-list) t)))
+ (setq fcc-list (cdr fcc-list))))
+ (kill-buffer tembuf)))
+
+(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-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) "\n"))
+ (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")
+ (skip-chars-backward "\n")))
+ nil)))
+
+(defun mail-signature ()
+ "Sign letter with contents of ~/.signature file."
+ (interactive)
+ (save-excursion
+ (goto-char (point-max))
+ (insert-file-contents (expand-file-name "~/.signature"))))
+
+(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-yank-original (arg)
+ "Insert the message being replied to, if any (in rmail).
+Puts point before the text and mark after.
+Indents each nonblank line ARG spaces (default 3).
+Just \\[universal-argument] as argument means don't indent
+and don't delete any header fields."
+ (interactive "P")
+ (if mail-reply-buffer
+ (let ((start (point)))
+ (delete-windows-on mail-reply-buffer)
+ (insert-buffer mail-reply-buffer)
+ (if (consp arg)
+ nil
+ (mail-yank-clear-headers start (mark))
+ (indent-rigidly start (mark)
+ (if arg (prefix-numeric-value arg) 3)))
+ (exchange-point-and-mark)
+ (if (not (eolp)) (insert ?\n)))))
+
+(defun mail-yank-clear-headers (start end)
+ (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.
+
+(defun mail (&optional noerase to subject in-reply-to cc replybuffer)
+ "Edit a message to be sent. Argument means resume editing (don't erase).
+Returns with message buffer selected; value t if message freshly initialized.
+While editing message, type C-c C-c to send the message and exit.
+
+Separate names of recipients with commas.
+
+Various special commands starting with C-c are available in sendmail mode
+to move to message header fields:
+\\{mail-mode-map}
+
+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.
+
+If mail-setup-hook is bound, its value is run by means of run-hooks
+after the message is initialized. It can add more default fields.
+See the documentation of run-hooks.
+
+When calling from a program, 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."
+ (interactive "P")
+ (switch-to-buffer "*mail*")
+ (setq default-directory (expand-file-name "~/"))
+ (auto-save-mode auto-save-default)
+ (mail-mode)
+ (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)
+ t)))
+
+(defun mail-other-window (&optional noerase to subject in-reply-to cc replybuffer)
+ "Like `mail' command, but display mail buffer in another window."
+ (interactive "P")
+ (let ((pop-up-windows t))
+ (pop-to-buffer "*mail*"))
+ (mail noerase to subject in-reply-to cc replybuffer))
+
+;;; Do not add anything but external entries on this page.
diff --git a/lisp/sendmail.elc b/lisp/sendmail.elc
new file mode 100644
index 00000000000..37b2436f202
--- /dev/null
+++ b/lisp/sendmail.elc
Binary files differ
diff --git a/lisp/server.el b/lisp/server.el
index f6518777d2c..7ea05841441 100644
--- a/lisp/server.el
+++ b/lisp/server.el
@@ -1,5 +1,5 @@
;; Lisp code for GNU Emacs running as server process.
-;; Copyright (C) 1986, 1987 Free Software Foundation, Inc.
+;; Copyright (C) 1986, 1987, 1990 Free Software Foundation, Inc.
;; Author William Sommerfeld, wesommer@athena.mit.edu.
;; Changes by peck@sun.com and by rms.
@@ -24,7 +24,7 @@
;;; a server for other processes.
;;; Load this library and do M-x server-edit to enable Emacs as a server.
-;;; Emacs runs the program ../etc/emacsserver as a subprocess
+;;; Emacs runs the program ../etc/server as a subprocess
;;; for communication with clients. If there are no client buffers to edit,
;;; server-edit acts like (switch-to-buffer (other-buffer))
@@ -44,34 +44,22 @@
;;; Your editing commands and Emacs's display output go to and from
;;; the terminal in the usual way. Thus, server operation is possible
;;; only when Emacs can talk to the terminal at the time you invoke
-;;; the client. This is possible in four cases:
+;;; the client. This is possible in two cases:
;;; 1. On a window system, where Emacs runs in one window and the
;;; program that wants to use "the editor" runs in another.
-;;; 2. On a multi-terminal system, where Emacs runs on one terminal and the
-;;; program that wants to use "the editor" runs on another.
-
-;;; 3. When the program that wants to use "the editor" is running
+;;; 2. When the program that wants to use "the editor" is running
;;; as a subprocess of Emacs.
-;;; 4. On a system with job control, when Emacs is suspended, the program
-;;; that wants to use "the editor" will stop and display
-;;; "Waiting for Emacs...". It can then be suspended, and Emacs can be
-;;; brought into the foreground for editing. When done editing, Emacs is
-;;; suspended again, and the client program is brought into the foreground.
-
;;; The buffer local variable "server-buffer-clients" lists
;;; the clients who are waiting for this buffer to be edited.
;;; The global variable "server-clients" lists all the waiting clients,
;;; and which files are yet to be edited for each.
-(defvar server-program "emacsserver"
+(defvar server-program "server"
"*The program to use as the edit server")
-(defvar server-visit-hook nil
- "*List of hooks to call when switching to a buffer for the Emacs server.")
-
(defvar server-process nil
"the current server process")
@@ -85,13 +73,6 @@ When a buffer is marked as \"done\", it is removed from this list.")
(defvar server-buffer-clients nil
"List of clientids for clients requesting editing of current buffer.")
-;; Changing major modes should not erase this local.
-(put 'server-buffer-clients 'permanent-local t)
-
-(defvar server-temp-file-regexp "^/tmp/Re\\|/draft$"
- "*Regexp which should match filenames of temporary files
-which are deleted and reused after each edit
-by the programs that invoke the emacs server.")
(make-variable-buffer-local 'server-buffer-clients)
(setq-default server-buffer-clients nil)
@@ -129,6 +110,9 @@ Prefix arg means just kill any existing server communications subprocess."
(set-process-sentinel server-process nil)
(condition-case () (delete-process server-process) (error nil))))
(condition-case () (delete-file "~/.emacs_server") (error nil))
+ (condition-case ()
+ (delete-file (format "/tmp/esrv%d-%s" (user-uid) (system-name)))
+ (error nil))
;; If we already had a server, clear out associated status.
(while server-clients
(let ((buffer (nth 1 (car server-clients))))
@@ -137,7 +121,8 @@ Prefix arg means just kill any existing server communications subprocess."
nil
(if server-process
(server-log (message "Restarting server")))
- (setq server-process (start-process "server" nil server-program))
+ (let ((process-connection-type nil))
+ (setq server-process (start-process "server" nil server-program)))
(set-process-sentinel server-process 'server-sentinel)
(set-process-filter server-process 'server-process-filter)
(process-kill-without-query server-process)))
@@ -196,8 +181,7 @@ FILES is an alist whose elements are (FILENAME LINENUMBER)."
filen
", write buffer to file? "))
(write-file filen)))
- (set-buffer (find-file-noselect filen))
- (run-hooks 'server-visit-hook)))
+ (set-buffer (find-file-noselect filen))))
(goto-line (nth 1 (car files)))
(setq server-buffer-clients (cons (car client) server-buffer-clients))
(setq client-record (cons (current-buffer) client-record)))
@@ -233,15 +217,11 @@ as a suggestion for what to select next."
(bury-buffer buffer)
next-buffer))
-(defun server-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 `server-temp-file-regexp' controls which filenames
-are considered temporary."
- (and (buffer-file-name buffer)
- (string-match server-temp-file-regexp (buffer-file-name buffer))))
+(defun mh-draft-p (buffer)
+ "Return non-nil if this BUFFER is an mh <draft> file.
+Since MH deletes draft *BEFORE* it is edited, the server treats them specially."
+ ;; This may not be appropriately robust for all cases.
+ (string= (buffer-name buffer) "draft"))
(defun server-done ()
"Offer to save current buffer, mark it as \"done\" for clients,
@@ -249,7 +229,7 @@ bury it, and return a suggested buffer to select next."
(let ((buffer (current-buffer)))
(if server-buffer-clients
(progn
- (if (server-temp-file-p buffer)
+ (if (mh-draft-p buffer)
(progn (save-buffer)
(write-region (point-min) (point-max)
(concat buffer-file-name "~"))
@@ -262,15 +242,11 @@ bury it, and return a suggested buffer to select next."
(defun server-edit (&optional arg)
"Switch to next server editing buffer; say \"Done\" for current buffer.
If a server buffer is current, it is marked \"done\" and optionally saved.
+MH <draft> files are always saved and backed up, no questions asked.
When all of a client's buffers are marked as \"done\", the client is notified.
-Temporary files such as MH <draft> files are always saved and backed up,
-no questions asked. The variable `server-temp-file-regexp' controls
-which filenames are considered temporary.
-
If invoked with a prefix argument, or if there is no server process running,
starts server process and that is all. Invoked by \\[server-edit]."
-
(interactive "P")
(if (or arg
(not server-process)
diff --git a/lisp/server.elc b/lisp/server.elc
new file mode 100644
index 00000000000..0a8e8888ed4
--- /dev/null
+++ b/lisp/server.elc
Binary files differ
diff --git a/lisp/shell.el b/lisp/shell.el
index 64c069bf05d..9198a11c535 100644
--- a/lisp/shell.el
+++ b/lisp/shell.el
@@ -1,6 +1,6 @@
-;; -*-Emacs-Lisp-*- run a shell in an Emacs window
-;; Copyright (C) 1985, 1986, 1987, 1990 Free Software Foundation, Inc.
-
+;; Run subshell under Emacs
+;; Copyright (C) 1985, 1986, 1987, 1988 Free Software Foundation, Inc.
+
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
@@ -17,23 +17,18 @@
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-;;; Hacked from tea.el and shell.el by Olin Shivers (shivers@cs.cmu.edu). 8/88
-;;; Since this mode is built on top of the general command-interpreter-in-
-;;; a-buffer mode (comint mode), it shares a common base functionality,
-;;; and a common set of bindings, with all modes derived from comint mode.
+(provide 'shell)
-;;; For documentation on the functionality provided by comint mode, and
-;;; the hooks available for customising it, see the file comint.el.
+(defvar last-input-start nil
+ "In a shell-mode buffer, marker for start of last unit of input.")
+(defvar last-input-end nil
+ "In a shell-mode buffer, marker for end of last unit of input.")
-;;; Needs fixin:
-;;; When sending text from a source file to a subprocess, the process-mark can
-;;; move off the window, so you can lose sight of the process interactions.
-;;; Maybe I should ensure the process mark is in the window when I send
-;;; text to the process? Switch selectable?
+(defvar shell-mode-map nil)
-(require 'comint)
-(provide 'shell)
+(defvar shell-directory-stack nil
+ "List of directories saved by pushd in this buffer's shell.")
(defvar shell-popd-regexp "popd"
"*Regexp to match subshell commands equivalent to popd.")
@@ -47,346 +42,409 @@
(defvar explicit-shell-file-name nil
"*If non-nil, is file name to use for explicitly requested inferior shell.")
-(defvar explicit-csh-args
- (if (eq system-type 'hpux)
- ;; -T persuades HP's csh not to think it is smarter
- ;; than us about what terminal modes to use.
- '("-i" "-T")
- '("-i"))
- "*Args passed to inferior shell by M-x shell, if the shell is csh.
-Value is a list of strings, which may be nil.")
-
-(defvar shell-dirstack nil
- "List of directories saved by pushd in this buffer's shell.")
-
-(defvar shell-dirstack-query "dirs"
- "Command used by shell-resync-dirlist to query shell.")
-
-(defvar shell-mode-map ())
-(cond ((not shell-mode-map)
- (setq shell-mode-map (copy-keymap comint-mode-map))
- (define-key shell-mode-map "\t" 'comint-dynamic-complete)
- (define-key shell-mode-map "\M-?" 'comint-dynamic-list-completions)))
-
-(defvar shell-mode-hook '()
- "*Hook for customising shell mode")
-
-
-;;; Basic Procedures
-;;; ===========================================================================
-;;;
+;In loaddefs.el now.
+;(defconst shell-prompt-pattern
+; "^[^#$%>]*[#$%>] *"
+; "*Regexp used by Newline command to match subshell prompts.
+;Anything from beginning of line up to the end of what this pattern matches
+;is deemed to be prompt, and is not reexecuted.")
(defun shell-mode ()
"Major mode for interacting with an inferior shell.
-Return after the end of the process' output sends the text from the
- end of process to the end of the current line.
-Return before end of process output copies rest of line to end (skipping
- the prompt) and sends it.
-M-x send-invisible reads a line of text without echoing it, and sends it to
- the shell.
-
-If you accidentally suspend your process, use \\[comint-continue-subjob]
-to continue it.
-
-cd, pushd and popd commands given to the shell are watched by Emacs to keep
-this buffer's default directory the same as the shell's working directory.
-M-x dirs queries the shell and resyncs Emacs' idea of what the current
- directory stack is.
-M-x dirtrack-toggle turns directory tracking on and off.
+Shell name is same as buffer name, sans the asterisks.
+Return at end of buffer sends line as input.
+Return not at end copies rest of line to end and sends it.
+The following commands imitate the usual Unix interrupt and
+editing control characters:
\\{shell-mode-map}
-Customisation: Entry to this mode runs the hooks on comint-mode-hook and
-shell-mode-hook (in that order).
-Variables shell-cd-regexp, shell-pushd-regexp and shell-popd-regexp are used
-to match their respective commands."
+Entry to this mode calls the value of shell-mode-hook with no args,
+if that value is non-nil.
+
+cd, pushd and popd commands given to the shell are watched
+by Emacs to keep this buffer's default directory
+the same as the shell's working directory.
+Variables shell-cd-regexp, shell-pushd-regexp and shell-popd-regexp
+are used to match these command names.
+
+You can send text to the shell (or its subjobs) from other buffers
+using the commands process-send-region, process-send-string
+and lisp-send-defun."
(interactive)
- (comint-mode)
- (setq major-mode 'shell-mode
- mode-name "Shell"
- comint-prompt-regexp shell-prompt-pattern
- comint-input-sentinel 'shell-directory-tracker)
+ (kill-all-local-variables)
+ (setq major-mode 'shell-mode)
+ (setq mode-name "Shell")
+ (setq mode-line-process '(": %s"))
(use-local-map shell-mode-map)
- (make-local-variable 'shell-dirstack)
- (set (make-local-variable 'shell-dirtrackp) t)
+ (make-local-variable 'shell-directory-stack)
+ (setq shell-directory-stack nil)
+ (make-local-variable 'last-input-start)
+ (setq last-input-start (make-marker))
+ (make-local-variable 'last-input-end)
+ (setq last-input-end (make-marker))
(run-hooks 'shell-mode-hook))
+(if shell-mode-map
+ nil
+ (setq shell-mode-map (make-sparse-keymap))
+ (define-key shell-mode-map "\C-m" 'shell-send-input)
+ (define-key shell-mode-map "\C-c\C-d" 'shell-send-eof)
+ (define-key shell-mode-map "\C-c\C-u" 'kill-shell-input)
+ (define-key shell-mode-map "\C-c\C-w" 'backward-kill-word)
+ (define-key shell-mode-map "\C-c\C-c" 'interrupt-shell-subjob)
+ (define-key shell-mode-map "\C-c\C-z" 'stop-shell-subjob)
+ (define-key shell-mode-map "\C-c\C-\\" 'quit-shell-subjob)
+ (define-key shell-mode-map "\C-c\C-o" 'kill-output-from-shell)
+ (define-key shell-mode-map "\C-c\C-r" 'show-output-from-shell)
+ (define-key shell-mode-map "\C-c\C-y" 'copy-last-shell-input))
+(defvar explicit-csh-args
+ (if (eq system-type 'hpux)
+ ;; -T persuades HP's csh not to think it is smarter
+ ;; than us about what terminal modes to use.
+ '("-i" "-T")
+ '("-i"))
+ "Args passed to inferior shell by M-x shell, if the shell is csh.
+Value is a list of strings, which may be nil.")
+
(defun shell ()
"Run an inferior shell, with I/O through buffer *shell*.
If buffer exists but shell process is not running, make new shell.
-If buffer exists and shell process is running, just switch to buffer *shell*.
-
-The shell to use comes from the first non-nil variable found from these:
-explicit-shell-file-name in Emacs, ESHELL in the environment or SHELL in the
-environment. If none is found, /bin/sh is used.
-
-If a file ~/.emacs_SHELLNAME exists, it is given as initial input, simulating
-a start-up file for the shell like .profile or .cshrc. Note that this may
-lose due to a timing error if the shell discards input when it starts up.
-
+Program used comes from variable explicit-shell-file-name,
+ or (if that is nil) from the ESHELL environment variable,
+ or else from SHELL if there is no ESHELL.
+If a file ~/.emacs_SHELLNAME exists, it is given as initial input
+ (Note that this may lose due to a timing error if the shell
+ discards input when it starts up.)
The buffer is put in shell-mode, giving commands for sending input
-and controlling the subjobs of the shell.
+and controlling the subjobs of the shell. See shell-mode.
+See also variable shell-prompt-pattern.
-The shell file name, sans directories, is used to make a symbol name
+The shell file name (sans directories) is used to make a symbol name
such as `explicit-csh-arguments'. If that symbol is a variable,
its value is used as a list of arguments when invoking the shell.
Otherwise, one argument `-i' is passed to the shell.
-\(Type \\[describe-mode] in the shell buffer for a list of commands.)"
+Note that many people's .cshrc files unconditionally clear the prompt.
+If yours does, you will probably want to change it."
+ (interactive)
+ (let* ((prog (or explicit-shell-file-name
+ (getenv "ESHELL")
+ (getenv "SHELL")
+ "/bin/sh"))
+ (name (file-name-nondirectory prog)))
+ (switch-to-buffer
+ (apply 'make-shell "shell" prog
+ (if (file-exists-p (concat "~/.emacs_" name))
+ (concat "~/.emacs_" name))
+ (let ((symbol (intern-soft (concat "explicit-" name "-args"))))
+ (if (and symbol (boundp symbol))
+ (symbol-value symbol)
+ '("-i")))))))
+
+(defun make-shell (name program &optional startfile &rest switches)
+ (let ((buffer (get-buffer-create (concat "*" name "*")))
+ proc status size)
+ (setq proc (get-buffer-process buffer))
+ (if proc (setq status (process-status proc)))
+ (save-excursion
+ (set-buffer buffer)
+ ;; (setq size (buffer-size))
+ (if (memq status '(run stop))
+ nil
+ (if proc (delete-process proc))
+ (setq proc (apply 'start-process name buffer
+ (concat exec-directory "env")
+ (format "TERMCAP=emacs:co#%d:tc=unknown:"
+ (screen-width))
+ "TERM=emacs"
+ "EMACS=t"
+ "-"
+ (or program explicit-shell-file-name
+ (getenv "ESHELL")
+ (getenv "SHELL")
+ "/bin/sh")
+ switches))
+ (cond (startfile
+ ;;This is guaranteed to wait long enough
+ ;;but has bad results if the shell does not prompt at all
+ ;; (while (= size (buffer-size))
+ ;; (sleep-for 1))
+ ;;I hope 1 second is enough!
+ (sleep-for 1)
+ (goto-char (point-max))
+ (insert-file-contents startfile)
+ (setq startfile (buffer-substring (point) (point-max)))
+ (delete-region (point) (point-max))
+ (process-send-string proc startfile)))
+ (setq name (process-name proc)))
+ (goto-char (point-max))
+ (set-marker (process-mark proc) (point))
+ (or (eq major-mode 'shell-mode) (shell-mode)))
+ buffer))
+
+(defvar shell-set-directory-error-hook 'ignore
+ "Function called with no arguments when shell-send-input
+recognizes a change-directory command but gets an error
+trying to change Emacs's default directory.")
+
+(defun shell-send-input ()
+ "Send input to subshell.
+At end of buffer, sends all text after last output
+ as input to the subshell, including a newline inserted at the end.
+When not at end, copies current line to the end of the buffer and sends it,
+after first attempting to discard any prompt at the beginning of the line
+by matching the regexp that is the value of shell-prompt-pattern if possible.
+This regexp should start with \"^\"."
+ (interactive)
+ (or (get-buffer-process (current-buffer))
+ (error "Current buffer has no process"))
+ (end-of-line)
+ (if (eobp)
+ (progn
+ (move-marker last-input-start
+ (process-mark (get-buffer-process (current-buffer))))
+ (insert ?\n)
+ (move-marker last-input-end (point)))
+ (beginning-of-line)
+ ;; Exclude the shell prompt, if any.
+ (re-search-forward shell-prompt-pattern
+ (save-excursion (end-of-line) (point))
+ t)
+ (let ((copy (buffer-substring (point)
+ (progn (forward-line 1) (point)))))
+ (goto-char (point-max))
+ (move-marker last-input-start (point))
+ (insert copy)
+ (move-marker last-input-end (point))))
+ ;; Even if we get an error trying to hack the working directory,
+ ;; still send the input to the subshell.
+ (condition-case ()
+ (save-excursion
+ (goto-char last-input-start)
+ (shell-set-directory))
+ (error (funcall shell-set-directory-error-hook)))
+ (let ((process (get-buffer-process (current-buffer))))
+ (process-send-region process last-input-start last-input-end)
+ (set-marker (process-mark process) (point))))
+
+;;; If this code changes (shell-send-input and shell-set-directory),
+;;; the customization tutorial in
+;;; info/customizing-tutorial must also change, since it explains this
+;;; code. Please let marick@gswd-vms.arpa know of any changes you
+;;; make.
+
+(defun shell-set-directory ()
+ (cond ((and (looking-at shell-popd-regexp)
+ (memq (char-after (match-end 0)) '(?\; ?\n)))
+ (if shell-directory-stack
+ (progn
+ (cd (car shell-directory-stack))
+ (setq shell-directory-stack (cdr shell-directory-stack)))))
+ ((looking-at shell-pushd-regexp)
+ (cond ((memq (char-after (match-end 0)) '(?\; ?\n))
+ (if shell-directory-stack
+ (let ((old default-directory))
+ (cd (car shell-directory-stack))
+ (setq shell-directory-stack
+ (cons old (cdr shell-directory-stack))))))
+ ((memq (char-after (match-end 0)) '(?\ ?\t))
+ (let (dir)
+ (skip-chars-forward "^ ")
+ (skip-chars-forward " \t")
+ (if (file-directory-p
+ (setq dir
+ (expand-file-name
+ (substitute-in-file-name
+ (buffer-substring
+ (point)
+ (progn
+ (skip-chars-forward "^\n \t;")
+ (point)))))))
+ (progn
+ (setq shell-directory-stack
+ (cons default-directory shell-directory-stack))
+ (cd dir)))))))
+ ((looking-at shell-cd-regexp)
+ (cond ((memq (char-after (match-end 0)) '(?\; ?\n))
+ (cd (getenv "HOME")))
+ ((memq (char-after (match-end 0)) '(?\ ?\t))
+ (let (dir)
+ (forward-char 3)
+ (skip-chars-forward " \t")
+ (if (file-directory-p
+ (setq dir
+ (expand-file-name
+ (substitute-in-file-name
+ (buffer-substring
+ (point)
+ (progn
+ (skip-chars-forward "^\n \t;")
+ (point)))))))
+ (cd dir))))))))
+
+(defun shell-send-eof ()
+ "Send eof to subshell (or to the program running under it)."
+ (interactive)
+ (process-send-eof))
+
+(defun kill-output-from-shell ()
+ "Kill all output from shell since last input."
+ (interactive)
+ (goto-char (point-max))
+ (beginning-of-line)
+ (kill-region last-input-end (point))
+ (insert "*** output flushed ***\n")
+ (goto-char (point-max)))
+
+(defun show-output-from-shell ()
+ "Display start of this batch of shell output at top of window.
+Also put cursor there."
+ (interactive)
+ (set-window-start (selected-window) last-input-end)
+ (goto-char last-input-end))
+
+(defun copy-last-shell-input ()
+ "Copy previous shell input, sans newline, and insert before point."
(interactive)
- (cond ((not (comint-check-proc "*shell*"))
- (let* ((prog (or explicit-shell-file-name
- (getenv "ESHELL")
- (getenv "SHELL")
- "/bin/sh"))
- (name (file-name-nondirectory prog))
- (startfile (concat "~/.emacs_" name))
- (xargs-name (intern-soft (concat "explicit-" name "-args"))))
- (set-buffer (apply 'make-comint "shell" prog
- (if (file-exists-p startfile) startfile)
- (if (and xargs-name (boundp xargs-name))
- (symbol-value xargs-name)
- '("-i"))))
- (shell-mode))))
- (switch-to-buffer "*shell*"))
+ (insert (buffer-substring last-input-end last-input-start))
+ (delete-char -1))
+(defun interrupt-shell-subjob ()
+ "Interrupt this shell's current subjob."
+ (interactive)
+ (interrupt-process nil t))
+
+(defun kill-shell-subjob ()
+ "Send kill signal to this shell's current subjob."
+ (interactive)
+ (kill-process nil t))
+
+(defun quit-shell-subjob ()
+ "Send quit signal to this shell's current subjob."
+ (interactive)
+ (quit-process nil t))
+
+(defun stop-shell-subjob ()
+ "Stop this shell's current subjob."
+ (interactive)
+ (stop-process nil t))
+
+(defun kill-shell-input ()
+ "Kill all text since last stuff output by the shell or its subjobs."
+ (interactive)
+ (kill-region (process-mark (get-buffer-process (current-buffer)))
+ (point)))
-;;; Directory tracking
-;;; ===========================================================================
-;;; This code provides the shell mode input sentinel
-;;; SHELL-DIRECTORY-TRACKER
-;;; that tracks cd, pushd, and popd commands issued to the shell, and
-;;; changes the current directory of the shell buffer accordingly.
-;;;
-;;; This is basically a fragile hack, although it's more accurate than
-;;; the original version in shell.el. It has the following failings:
-;;; 1. It doesn't know about the cdpath shell variable.
-;;; 2. It only spots the first command in a command sequence. E.g., it will
-;;; miss the cd in "ls; cd foo"
-;;; 3. More generally, any complex command (like ";" sequencing) is going to
-;;; throw it. Otherwise, you'd have to build an entire shell interpreter in
-;;; emacs lisp. Failing that, there's no way to catch shell commands where
-;;; cd's are buried inside conditional expressions, aliases, and so forth.
-;;;
-;;; The whole approach is a crock. Shell aliases mess it up. File sourcing
-;;; messes it up. You run other processes under the shell; these each have
-;;; separate working directories, and some have commands for manipulating
-;;; their w.d.'s (e.g., the lcd command in ftp). Some of these programs have
-;;; commands that do *not* effect the current w.d. at all, but look like they
-;;; do (e.g., the cd command in ftp). In shells that allow you job
-;;; control, you can switch between jobs, all having different w.d.'s. So
-;;; simply saying %3 can shift your w.d..
-;;;
-;;; The solution is to relax, not stress out about it, and settle for
-;;; a hack that works pretty well in typical circumstances. Remember
-;;; that a half-assed solution is more in keeping with the spirit of Unix,
-;;; anyway. Blech.
-;;;
-;;; One good hack not implemented here for users of programmable shells
-;;; is to program up the shell w.d. manipulation commands to output
-;;; a coded command sequence to the tty. Something like
-;;; ESC | <cwd> |
-;;; where <cwd> is the new current working directory. Then trash the
-;;; directory tracking machinery currently used in this package, and
-;;; replace it with a process filter that watches for and strips out
-;;; these messages.
-
-;;; REGEXP is a regular expression. STR is a string. START is a fixnum.
-;;; Returns T if REGEXP matches STR where the match is anchored to start
-;;; at position START in STR. Sort of like LOOKING-AT for strings.
-(defun shell-front-match (regexp str start)
- (eq start (string-match regexp str start)))
-
-(defun shell-directory-tracker (str)
- "Tracks cd, pushd and popd commands issued to the shell.
-This function is called on each input passed to the shell.
-It watches for cd, pushd and popd commands and sets the buffer's
-default directory to track these commands.
-
-You may toggle this tracking on and off with M-x dirtrack-toggle.
-If emacs gets confused, you can resync with the shell with M-x dirs.
-
-See variables shell-cd-regexp, shell-pushd-regexp, and shell-popd-regexp.
-Environment variables are expanded, see function substitute-in-file-name."
- (condition-case err
- (cond (shell-dirtrackp
- (string-match "^\\s *" str) ; skip whitespace
- (let ((bos (match-end 0))
- (x nil))
- (cond ((setq x (shell-match-cmd-w/optional-arg shell-popd-regexp
- str bos))
- (shell-process-popd (substitute-in-file-name x)))
- ((setq x (shell-match-cmd-w/optional-arg shell-pushd-regexp
- str bos))
- (shell-process-pushd (substitute-in-file-name x)))
- ((setq x (shell-match-cmd-w/optional-arg shell-cd-regexp
- str bos))
- (shell-process-cd (substitute-in-file-name x)))))))
- (error (message (car (cdr err))))))
-
-
-;;; Try to match regexp CMD to string, anchored at position START.
-;;; CMD may be followed by a single argument. If a match, then return
-;;; the argument, if there is one, or the empty string if not. If
-;;; no match, return nil.
-
-(defun shell-match-cmd-w/optional-arg (cmd str start)
- (and (shell-front-match cmd str start)
- (let ((eoc (match-end 0))) ; end of command
- (cond ((shell-front-match "\\s *\\(\;\\|$\\)" str eoc)
- "") ; no arg
- ((shell-front-match "\\s +\\([^ \t\;]+\\)\\s *\\(\;\\|$\\)"
- str eoc)
- (substring str (match-beginning 1) (match-end 1))) ; arg
- (t nil))))) ; something else.
-;;; The first regexp is [optional whitespace, (";" or the end of string)].
-;;; The second regexp is [whitespace, (an arg), optional whitespace,
-;;; (";" or end of string)].
-
-
-;;; popd [+n]
-(defun shell-process-popd (arg)
- (let ((num (if (zerop (length arg)) 0 ; no arg means +0
- (shell-extract-num arg))))
- (if (and num (< num (length shell-dirstack)))
- (if (= num 0) ; condition-case because the CD could lose.
- (condition-case nil (progn (cd (car shell-dirstack))
- (setq shell-dirstack
- (cdr shell-dirstack))
- (shell-dirstack-message))
- (error (message "Couldn't cd.")))
- (let* ((ds (cons nil shell-dirstack))
- (cell (nthcdr (- num 1) ds)))
- (rplacd cell (cdr (cdr cell)))
- (setq shell-dirstack (cdr ds))
- (shell-dirstack-message)))
- (message "Bad popd."))))
-
-
-;;; cd [dir]
-(defun shell-process-cd (arg)
- (condition-case nil (progn (cd (if (zerop (length arg)) (getenv "HOME")
- arg))
- (shell-dirstack-message))
- (error (message "Couldn't cd."))))
-
-
-;;; pushd [+n | dir]
-(defun shell-process-pushd (arg)
- (if (zerop (length arg))
- ;; no arg -- swap pwd and car of shell stack
- (condition-case nil (if shell-dirstack
- (let ((old default-directory))
- (cd (car shell-dirstack))
- (setq shell-dirstack
- (cons old (cdr shell-dirstack)))
- (shell-dirstack-message))
- (message "Directory stack empty."))
- (message "Couldn't cd."))
-
- (let ((num (shell-extract-num arg)))
- (if num ; pushd +n
- (if (> num (length shell-dirstack))
- (message "Directory stack not that deep.")
- (let* ((ds (cons default-directory shell-dirstack))
- (dslen (length ds))
- (front (nthcdr num ds))
- (back (reverse (nthcdr (- dslen num) (reverse ds))))
- (new-ds (append front back)))
- (condition-case nil
- (progn (cd (car new-ds))
- (setq shell-dirstack (cdr new-ds))
- (shell-dirstack-message))
- (error (message "Couldn't cd.")))))
-
- ;; pushd <dir>
- (let ((old-wd default-directory))
- (condition-case nil
- (progn (cd arg)
- (setq shell-dirstack
- (cons old-wd shell-dirstack))
- (shell-dirstack-message))
- (error (message "Couldn't cd."))))))))
-
-;; If STR is of the form +n, for n>0, return n. Otherwise, nil.
-(defun shell-extract-num (str)
- (and (string-match "^\\+[1-9][0-9]*$" str)
- (string-to-int str)))
-
-
-(defun shell-dirtrack-toggle ()
- "Turn directory tracking on and off in a shell buffer."
+(defvar inferior-lisp-mode-map nil)
+(if inferior-lisp-mode-map
+ nil
+ (setq inferior-lisp-mode-map (copy-alist shell-mode-map))
+ (lisp-mode-commands inferior-lisp-mode-map)
+ (define-key inferior-lisp-mode-map "\e\C-x" 'lisp-send-defun))
+
+(defvar inferior-lisp-program "lisp"
+ "*Program name for invoking an inferior Lisp with `run-lisp'.")
+
+(defvar inferior-lisp-load-command "(load \"%s\")\n"
+ "*Format-string for building a Lisp expression to load a file.
+This format string should use %s to substitute a file name
+and should result in a Lisp expression that will command the inferior Lisp
+to load that file. The default works acceptably on most Lisps.
+The string \"(progn (load \\\"%s\\\" :verbose nil :print t) (values))\\\n\"
+produces cosmetically superior output for this application,
+but it works only in Common Lisp.")
+
+(defvar inferior-lisp-prompt "^.*>:? *$"
+ "*Regexp to recognize prompts from the inferior Lisp.
+Default is right for Franz Lisp and kcl.")
+
+(defun inferior-lisp-mode ()
+ "Major mode for interacting with an inferior Lisp process.
+Runs a Lisp interpreter as a subprocess of Emacs, with Lisp I/O
+through an Emacs buffer. Variable inferior-lisp-program controls
+which Lisp interpreter is run. Variables inferior-lisp-prompt
+and inferior-lisp-load-command can customize this mode for different
+Lisp interpreters.
+
+Commands:
+DELETE converts tabs to spaces as it moves back.
+TAB indents for Lisp; with argument, shifts rest
+ of expression rigidly with the current line.
+Meta-Control-Q does TAB on each line starting within following expression.
+Paragraphs are separated only by blank lines. Semicolons start comments.
+
+Return at end of buffer sends line as input.
+Return not at end copies rest of line to end and sends it.
+
+The following commands imitate the usual Unix interrupt and
+editing control characters:
+\\{shell-mode-map}
+
+Entry to this mode calls the value of lisp-mode-hook with no arguments,
+if that value is non-nil. Likewise with the value of shell-mode-hook.
+lisp-mode-hook is called after shell-mode-hook.
+
+You can send text to the inferior Lisp from other buffers
+using the commands process-send-region, process-send-string
+and \\[lisp-send-defun]."
+ (interactive)
+ (kill-all-local-variables)
+ (setq major-mode 'inferior-lisp-mode)
+ (setq mode-name "Inferior Lisp")
+ (setq mode-line-process '(": %s"))
+ (lisp-mode-variables t)
+ (use-local-map inferior-lisp-mode-map)
+ (make-local-variable 'last-input-start)
+ (setq last-input-start (make-marker))
+ (make-local-variable 'last-input-end)
+ (setq last-input-end (make-marker))
+ (run-hooks 'shell-mode-hook 'lisp-mode-hook))
+
+(defun run-lisp ()
+ "Run an inferior Lisp process, input and output via buffer *lisp*."
(interactive)
- (setq shell-dirtrackp (not shell-dirtrackp))
- (message "directory tracking %s."
- (if shell-dirtrackp "ON" "OFF")))
-
-;;; For your typing convenience:
-(fset 'dirtrack-toggle 'shell-dirtrack-toggle)
-
-
-(defun shell-resync-dirs ()
- "Resync the buffer's idea of the current directory stack.
-This command queries the shell with the command bound to
-shell-dirstack-query (default \"dirs\"), reads the next
-line output and parses it to form the new directory stack.
-DON'T issue this command unless the buffer is at a shell prompt.
-Also, note that if some other subprocess decides to do output
-immediately after the query, its output will be taken as the
-new directory stack -- you lose. If this happens, just do the
-command again."
+ (switch-to-buffer (make-shell "lisp" inferior-lisp-program))
+ (inferior-lisp-mode))
+
+(defun lisp-send-defun (display-flag)
+ "Send the current defun to the Lisp process made by M-x run-lisp.
+With argument, force redisplay and scrolling of the *lisp* buffer.
+Variable `inferior-lisp-load-command' controls formatting of
+the `load' form that is set to the Lisp process."
+ (interactive "P")
+ (or (get-process "lisp")
+ (error "No current lisp process"))
+ (save-excursion
+ (end-of-defun)
+ (let ((end (point))
+ (filename (format "/tmp/emlisp%d" (process-id (get-process "lisp")))))
+ (beginning-of-defun)
+ (write-region (point) end filename nil 'nomessage)
+ (process-send-string "lisp" (format inferior-lisp-load-command filename)))
+ (if display-flag
+ (let* ((process (get-process "lisp"))
+ (buffer (process-buffer process))
+ (w (or (get-buffer-window buffer) (display-buffer buffer)))
+ (height (window-height w))
+ (end))
+ (save-excursion
+ (set-buffer buffer)
+ (setq end (point-max))
+ (while (progn
+ (accept-process-output process)
+ (goto-char (point-max))
+ (beginning-of-line)
+ (or (= (point-max) end)
+ (not (looking-at inferior-lisp-prompt)))))
+ (setq end (point-max))
+ (vertical-motion (- 4 height))
+ (set-window-start w (point)))
+ (set-window-point w end)))))
+
+(defun lisp-send-defun-and-go ()
+ "Send the current defun to the inferior Lisp, and switch to *lisp* buffer."
(interactive)
- (let* ((proc (get-buffer-process (current-buffer)))
- (pmark (process-mark proc)))
- (goto-char pmark)
- (insert shell-dirstack-query) (insert "\n")
- (sit-for 0) ; force redisplay
- (comint-send-string proc shell-dirstack-query)
- (comint-send-string proc "\n")
- (set-marker pmark (point))
- (let ((pt (point))) ; wait for 1 line
- ;; This extra newline prevents the user's pending input from spoofing us.
- (insert "\n") (backward-char 1)
- (while (not (looking-at ".+\n"))
- (accept-process-output proc)
- (goto-char pt)))
- (goto-char pmark) (delete-char 1) ; remove the extra newline
- ;; That's the dirlist. grab it & parse it.
- (let* ((dl (buffer-substring (match-beginning 0) (- (match-end 0) 1)))
- (dl-len (length dl))
- (ds '()) ; new dir stack
- (i 0))
- (while (< i dl-len)
- ;; regexp = optional whitespace, (non-whitespace), optional whitespace
- (string-match "\\s *\\(\\S +\\)\\s *" dl i) ; pick off next dir
- (setq ds (cons (substring dl (match-beginning 1) (match-end 1))
- ds))
- (setq i (match-end 0)))
- (let ((ds (reverse ds)))
- (condition-case nil
- (progn (cd (car ds))
- (setq shell-dirstack (cdr ds))
- (shell-dirstack-message))
- (error (message "Couldn't cd.")))))))
-
-;;; For your typing convenience:
-(fset 'dirs 'shell-resync-dirs)
-
-
-;;; Show the current dirstack on the message line.
-;;; Pretty up dirs a bit by changing "/usr/jqr/foo" to "~/foo".
-;;; (This isn't necessary if the dirlisting is generated with a simple "dirs".)
-;;; All the commands that mung the buffer's dirstack finish by calling
-;;; this guy.
-(defun shell-dirstack-message ()
- (let ((msg "")
- (ds (cons default-directory shell-dirstack)))
- (while ds
- (let ((dir (car ds)))
- (if (string-match (format "^%s\\(/\\|$\\)" (getenv "HOME")) dir)
- (setq dir (concat "~/" (substring dir (match-end 0)))))
- (if (string-equal dir "~/") (setq dir "~"))
- (setq msg (concat msg dir " "))
- (setq ds (cdr ds))))
- (message msg)))
+ (lisp-send-defun nil)
+ (switch-to-buffer "*lisp*"))
diff --git a/lisp/shell.elc b/lisp/shell.elc
new file mode 100644
index 00000000000..103b284f564
--- /dev/null
+++ b/lisp/shell.elc
Binary files differ
diff --git a/lisp/simple.el b/lisp/simple.el
new file mode 100644
index 00000000000..c1d5db50fc4
--- /dev/null
+++ b/lisp/simple.el
@@ -0,0 +1,1431 @@
+;; Basic editing commands for Emacs
+;; Copyright (C) 1985, 1986, 1987, 1992 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+(defun open-line (arg)
+ "Insert a newline and leave point before it.
+With arg, inserts that many newlines."
+ (interactive "*p")
+ (let ((flag (and (bolp) (not (bobp)))))
+ (if flag (forward-char -1))
+ (while (> arg 0)
+ (insert ?\n)
+ (goto-char (1- (point)))
+ (setq arg (1- arg)))
+ (if flag (forward-char 1))))
+
+(defun split-line ()
+ "Split current line, moving portion beyond point vertically down."
+ (interactive "*")
+ (skip-chars-forward " \t")
+ (let ((col (current-column))
+ (pos (point)))
+ (insert ?\n)
+ (indent-to col 0)
+ (goto-char pos)))
+
+(defun quoted-insert (arg)
+ "Read next input character and insert it.
+Useful for inserting control characters.
+You may also type up to 3 octal digits, to insert a character with that code"
+ (interactive "*p")
+ (let ((char (read-quoted-char)))
+ (while (> arg 0)
+ (insert char)
+ (setq arg (1- arg)))))
+
+(defun delete-indentation (&optional arg)
+ "Join this line to previous and fix up whitespace at join.
+With argument, join this line to following line."
+ (interactive "*P")
+ (beginning-of-line)
+ (if arg (forward-line 1))
+ (if (eq (preceding-char) ?\n)
+ (progn
+ (delete-region (point) (1- (point)))
+ (fixup-whitespace))))
+
+(defun fixup-whitespace ()
+ "Fixup white space between objects around point.
+Leave one space or none, according to the context."
+ (interactive "*")
+ (save-excursion
+ (delete-horizontal-space)
+ (if (or (looking-at "^\\|\\s)\\|$")
+ (save-excursion (forward-char -1)
+ (looking-at "\\s(\\|\\s'")))
+ nil
+ (insert ?\ ))))
+
+(defun delete-horizontal-space ()
+ "Delete all spaces and tabs around point."
+ (interactive "*")
+ (skip-chars-backward " \t")
+ (delete-region (point) (progn (skip-chars-forward " \t") (point))))
+
+(defun just-one-space ()
+ "Delete all spaces and tabs around point, leaving one space."
+ (interactive "*")
+ (skip-chars-backward " \t")
+ (if (= (following-char) ? )
+ (forward-char 1)
+ (insert ? ))
+ (delete-region (point) (progn (skip-chars-forward " \t") (point))))
+
+(defun delete-blank-lines ()
+ "On blank line, delete all surrounding blank lines, leaving just one.
+On isolated blank line, delete that one.
+On nonblank line, delete all blank lines that follow it."
+ (interactive "*")
+ (let (thisblank singleblank)
+ (save-excursion
+ (beginning-of-line)
+ (setq thisblank (looking-at "[ \t]*$"))
+ (setq singleblank
+ (and thisblank
+ (not (looking-at "[ \t]*\n[ \t]*$"))
+ (or (bobp)
+ (progn (forward-line -1)
+ (not (looking-at "[ \t]*$")))))))
+ (if thisblank
+ (progn
+ (beginning-of-line)
+ (if singleblank (forward-line 1))
+ (delete-region (point)
+ (if (re-search-backward "[^ \t\n]" nil t)
+ (progn (forward-line 1) (point))
+ (point-min)))))
+ (if (not (and thisblank singleblank))
+ (save-excursion
+ (end-of-line)
+ (forward-line 1)
+ (delete-region (point)
+ (if (re-search-forward "[^ \t\n]" nil t)
+ (progn (beginning-of-line) (point))
+ (point-max)))))))
+
+(defun back-to-indentation ()
+ "Move point to the first non-whitespace character on this line."
+ (interactive)
+ (beginning-of-line 1)
+ (skip-chars-forward " \t"))
+
+(defun newline-and-indent ()
+ "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."
+ (interactive "*")
+ (delete-region (point) (progn (skip-chars-backward " \t") (point)))
+ (newline)
+ (indent-according-to-mode))
+
+(defun reindent-then-newline-and-indent ()
+ "Reindent current line, insert newline, then indent the new line.
+Indentation of both lines is done according to the current major mode,
+which means that the current value of indent-line-function is called.
+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."
+ (interactive "*")
+ (save-excursion
+ (delete-region (point) (progn (skip-chars-backward " \t") (point)))
+ (indent-according-to-mode))
+ (newline)
+ (indent-according-to-mode))
+
+(defun kill-forward-chars (arg)
+ (if (listp arg) (setq arg (car arg)))
+ (if (eq arg '-) (setq arg -1))
+ (kill-region (point) (+ (point) arg)))
+
+(defun kill-backward-chars (arg)
+ (if (listp arg) (setq arg (car arg)))
+ (if (eq arg '-) (setq arg -1))
+ (kill-region (point) (- (point) arg)))
+
+(defun backward-delete-char-untabify (arg &optional killp)
+ "Delete characters backward, changing tabs into spaces.
+Delete ARG chars, and kill (save in kill ring) if KILLP is non-nil.
+Interactively, ARG is the prefix arg (default 1)
+and KILLP is t if prefix arg is was specified."
+ (interactive "*p\nP")
+ (let ((count arg))
+ (save-excursion
+ (while (and (> count 0) (not (bobp)))
+ (if (= (preceding-char) ?\t)
+ (let ((col (current-column)))
+ (forward-char -1)
+ (setq col (- col (current-column)))
+ (insert-char ?\ col)
+ (delete-char 1)))
+ (forward-char -1)
+ (setq count (1- count)))))
+ (delete-backward-char arg killp))
+
+(defun zap-to-char (arg char)
+ "Kill up to (but not including) ARG'th occurrence of CHAR.
+Goes backward if ARG is negative; goes to end of buffer if CHAR not found."
+ (interactive "*p\ncZap to char: ")
+ (kill-region (point) (if (search-forward (char-to-string char) nil t arg)
+ (progn (goto-char (if (> arg 0) (1- (point)) (1+ (point))))
+ (point))
+ (if (> arg 0) (point-max) (point-min)))))
+
+(defun beginning-of-buffer (&optional arg)
+ "Move point to the beginning of the buffer; leave mark at previous position.
+With arg N, put point N/10 of the way from the true beginning.
+Don't use this in Lisp programs!
+\(goto-char (point-min)) is faster and does not set the mark."
+ (interactive "P")
+ (push-mark)
+ (goto-char (if arg
+ (if (> (buffer-size) 10000)
+ ;; Avoid overflow for large buffer sizes!
+ (* (prefix-numeric-value arg)
+ (/ (buffer-size) 10))
+ (/ (+ 10 (* (buffer-size) (prefix-numeric-value arg))) 10))
+ (point-min)))
+ (if arg (forward-line 1)))
+
+(defun end-of-buffer (&optional arg)
+ "Move point to the end of the buffer; leave mark at previous position.
+With arg N, put point N/10 of the way from the true end.
+Don't use this in Lisp programs!
+\(goto-char (point-max)) is faster and does not set the mark."
+ (interactive "P")
+ (push-mark)
+ (goto-char (if arg
+ (- (1+ (buffer-size))
+ (if (> (buffer-size) 10000)
+ ;; Avoid overflow for large buffer sizes!
+ (* (prefix-numeric-value arg)
+ (/ (buffer-size) 10))
+ (/ (* (buffer-size) (prefix-numeric-value arg)) 10)))
+ (point-max)))
+ (if arg (forward-line 1)))
+
+(defun mark-whole-buffer ()
+ "Put point at beginning and mark at end of buffer."
+ (interactive)
+ (push-mark (point))
+ (push-mark (point-max))
+ (goto-char (point-min)))
+
+(defun count-lines-region (start end)
+ "Print number of lines in the region."
+ (interactive "r")
+ (message "Region has %d lines" (count-lines start end)))
+
+(defun what-line ()
+ "Print the current line number (in the buffer) of point."
+ (interactive)
+ (save-restriction
+ (widen)
+ (save-excursion
+ (beginning-of-line)
+ (message "Line %d"
+ (1+ (count-lines 1 (point)))))))
+
+(defun count-lines (start end)
+ "Return number of newlines between START and END."
+ (save-excursion
+ (save-restriction
+ (narrow-to-region start end)
+ (goto-char (point-min))
+ (- (buffer-size) (forward-line (buffer-size))))))
+
+(defun what-cursor-position ()
+ "Print info on cursor position (on screen and within buffer)."
+ (interactive)
+ (let* ((char (following-char))
+ (beg (point-min))
+ (end (point-max))
+ (pos (point))
+ (total (buffer-size))
+ (percent (if (> total 50000)
+ ;; Avoid overflow from multiplying by 100!
+ (/ (+ (/ total 200) (1- pos)) (max (/ total 100) 1))
+ (/ (+ (/ total 2) (* 100 (1- pos))) (max total 1))))
+ (hscroll (if (= (window-hscroll) 0)
+ ""
+ (format " Hscroll=%d" (window-hscroll))))
+ (col (current-column)))
+ (if (= pos end)
+ (if (or (/= beg 1) (/= end (1+ total)))
+ (message "point=%d of %d(%d%%) <%d - %d> column %d %s"
+ pos total percent beg end col hscroll)
+ (message "point=%d of %d(%d%%) column %d %s"
+ pos total percent col hscroll))
+ (if (or (/= beg 1) (/= end (1+ total)))
+ (message "Char: %s (0%o) point=%d of %d(%d%%) <%d - %d> column %d %s"
+ (single-key-description char) char pos total percent beg end col hscroll)
+ (message "Char: %s (0%o) point=%d of %d(%d%%) column %d %s"
+ (single-key-description char) char pos total percent col hscroll)))))
+
+(defun fundamental-mode ()
+ "Major mode not specialized for anything in particular.
+Other major modes are defined by comparison with this one."
+ (interactive)
+ (kill-all-local-variables))
+
+(put 'eval-expression 'disabled t)
+
+;; We define this, rather than making eval interactive,
+;; for the sake of completion of names like eval-region, eval-current-buffer.
+(defun eval-expression (expression)
+ "Evaluate EXPRESSION and print value in minibuffer.
+Value is also consed on to front of variable values 's value."
+ (interactive "xEval: ")
+ (setq values (cons (eval expression) values))
+ (prin1 (car values) t))
+
+(defun edit-and-eval-command (prompt command)
+ "Prompting with PROMPT, let user edit COMMAND and eval result.
+COMMAND is a Lisp expression. Let user edit that expression in
+the minibuffer, then read and evaluate the result."
+ (eval (read-minibuffer prompt
+ (prin1-to-string command))))
+
+(defvar repeat-complex-command-map (copy-alist minibuffer-local-map))
+(define-key repeat-complex-command-map "\ep" 'previous-complex-command)
+(define-key repeat-complex-command-map "\en" 'next-complex-command)
+(defun repeat-complex-command (repeat-complex-command-arg)
+ "Edit and re-evaluate last complex command, or ARGth from last.
+A complex command is one which used the minibuffer.
+The command is placed in the minibuffer as a Lisp form for editing.
+The result is executed, repeating the command as changed.
+If the command has been changed or is not the most recent previous command
+it is added to the front of the command history.
+Whilst editing the command, the following commands are available:
+\\{repeat-complex-command-map}"
+ (interactive "p")
+ (let ((elt (nth (1- repeat-complex-command-arg) command-history))
+ newcmd)
+ (if elt
+ (progn
+ (setq newcmd (read-from-minibuffer "Redo: "
+ (prin1-to-string elt)
+ repeat-complex-command-map
+ t))
+ ;; If command to be redone does not match front of history,
+ ;; add it to the history.
+ (or (equal newcmd (car command-history))
+ (setq command-history (cons newcmd command-history)))
+ (eval newcmd))
+ (ding))))
+
+(defun next-complex-command (n)
+ "Inserts the next element of `command-history' into the minibuffer."
+ (interactive "p")
+ (let ((narg (min (max 1 (- repeat-complex-command-arg n))
+ (length command-history))))
+ (if (= repeat-complex-command-arg narg)
+ (error (if (= repeat-complex-command-arg 1)
+ "No following item in command history"
+ "No preceeding item command history"))
+ (erase-buffer)
+ (setq repeat-complex-command-arg narg)
+ (insert (prin1-to-string (nth (1- repeat-complex-command-arg)
+ command-history)))
+ (goto-char (point-min)))))
+
+(defun previous-complex-command (n)
+ "Inserts the previous element of `command-history' into the minibuffer."
+ (interactive "p")
+ (next-complex-command (- n)))
+
+(defun goto-line (arg)
+ "Goto line ARG, counting from line 1 at beginning of buffer."
+ (interactive "NGoto line: ")
+ (save-restriction
+ (widen)
+ (goto-char 1)
+ (if (eq selective-display t)
+ (re-search-forward "[\n\C-m]" nil 'end (1- arg))
+ (forward-line (1- arg)))))
+
+;Put this on C-x u, so we can force that rather than C-_ into startup msg
+(fset 'advertised-undo 'undo)
+
+(defun undo (&optional arg)
+ "Undo some previous changes.
+Repeat this command to undo more changes.
+A numeric argument serves as a repeat count."
+ (interactive "*p")
+ (let ((modified (buffer-modified-p)))
+ (or (eq (selected-window) (minibuffer-window))
+ (message "Undo!"))
+ (or (eq last-command 'undo)
+ (progn (undo-start)
+ (undo-more 1)))
+ (setq this-command 'undo)
+ (undo-more (or arg 1))
+ (and modified (not (buffer-modified-p))
+ (delete-auto-save-file-if-necessary))))
+
+(defun shell-command (command &optional flag)
+ "Execute string COMMAND in inferior shell; display output, if any.
+Optional second arg non-nil (prefix arg, if interactive)
+means insert output in current buffer after point (leave mark after it)."
+ (interactive "sShell command: \nP")
+ (if flag
+ (progn (barf-if-buffer-read-only)
+ (push-mark)
+ (call-process shell-file-name nil t nil
+ "-c" command)
+ (exchange-point-and-mark))
+ (shell-command-on-region (point) (point) command nil)))
+
+(defun shell-command-on-region (start end command &optional flag interactive)
+ "Execute string COMMAND in inferior shell with region as input.
+Normally display output (if any) in temp buffer;
+Prefix arg means replace the region with it.
+Noninteractive args are START, END, COMMAND, FLAG.
+Noninteractively FLAG means insert output in place of text from START to END,
+and put point at the end, but don't alter the mark."
+ (interactive "r\nsShell command on region: \nP\np")
+ (if flag
+ ;; Replace specified region with output from command.
+ (let ((swap (and interactive (< (point) (mark)))))
+ ;; Don't muck with mark
+ ;; unless called interactively.
+ (and interactive (push-mark))
+ (call-process-region start end shell-file-name t t nil
+ "-c" command)
+ (and interactive swap (exchange-point-and-mark)))
+ (let ((buffer (get-buffer-create "*Shell Command Output*")))
+ (if (eq buffer (current-buffer))
+ ;; If the input is the same buffer as the output,
+ ;; delete everything but the specified region,
+ ;; then replace that region with the output.
+ (progn (delete-region end (point-max))
+ (delete-region (point-min) start)
+ (call-process-region (point-min) (point-max)
+ shell-file-name t t nil
+ "-c" command))
+ ;; Clear the output buffer, then run the command with output there.
+ (save-excursion
+ (set-buffer buffer)
+ (erase-buffer))
+ (call-process-region start end shell-file-name
+ nil buffer nil
+ "-c" command))
+ (if (save-excursion
+ (set-buffer buffer)
+ (> (buffer-size) 0))
+ (set-window-start (display-buffer buffer) 1)
+ (message "(Shell command completed with no output)")))))
+
+(defun universal-argument ()
+ "Begin a numeric argument for the following command.
+Digits or minus sign following \\[universal-argument] make up the numeric argument.
+\\[universal-argument] following the digits or minus sign ends the argument.
+\\[universal-argument] without digits or minus sign provides 4 as argument.
+Repeating \\[universal-argument] without digits or minus sign
+ multiplies the argument by 4 each time."
+ (interactive nil)
+ (let ((c-u 4) (argstartchar last-command-char)
+ char)
+; (describe-arg (list c-u) 1)
+ (setq char (read-char))
+ (while (= char argstartchar)
+ (setq c-u (* 4 c-u))
+; (describe-arg (list c-u) 1)
+ (setq char (read-char)))
+ (prefix-arg-internal char c-u nil)))
+
+(defun prefix-arg-internal (char c-u value)
+ (let ((sign 1))
+ (if (and (numberp value) (< value 0))
+ (setq sign -1 value (- value)))
+ (if (eq value '-)
+ (setq sign -1 value nil))
+; (describe-arg value sign)
+ (while (= ?- char)
+ (setq sign (- sign) c-u nil)
+; (describe-arg value sign)
+ (setq char (read-char)))
+ (while (and (>= char ?0) (<= char ?9))
+ (setq value (+ (* (if (numberp value) value 0) 10) (- char ?0)) c-u nil)
+; (describe-arg value sign)
+ (setq char (read-char)))
+ ;; Repeating the arg-start char after digits
+ ;; terminates the argument but is ignored.
+ (if (eq (lookup-key global-map (make-string 1 char)) 'universal-argument)
+ (setq char (read-char)))
+ (setq prefix-arg
+ (cond (c-u (list c-u))
+ ((numberp value) (* value sign))
+ ((= sign -1) '-)))
+ (setq unread-command-char char)))
+
+;(defun describe-arg (value sign)
+; (cond ((numberp value)
+; (message "Arg: %d" (* value sign)))
+; ((consp value)
+; (message "Arg: C-u factor %d" (car value)))
+; ((< sign 0)
+; (message "Arg: -"))))
+
+(defun digit-argument (arg)
+ "Part of the numeric argument for the next command.
+\\[universal-argument] following digits or minus sign ends the argument."
+ (interactive "P")
+ (prefix-arg-internal last-command-char nil arg))
+
+(defun negative-argument (arg)
+ "Begin a negative numeric argument for the next command.
+\\[universal-argument] following digits or minus sign ends the argument."
+ (interactive "P")
+ (prefix-arg-internal ?- nil arg))
+
+(defun forward-to-indentation (arg)
+ "Move forward ARG lines and position at first nonblank character."
+ (interactive "p")
+ (forward-line arg)
+ (skip-chars-forward " \t"))
+
+(defun backward-to-indentation (arg)
+ "Move backward ARG lines and position at first nonblank character."
+ (interactive "p")
+ (forward-line (- arg))
+ (skip-chars-forward " \t"))
+
+(defun kill-line (&optional arg)
+ "Kill the rest of the current line; if no nonblanks there, kill thru newline.
+With prefix argument, kill that many lines from point.
+Negative arguments kill lines backward.
+
+When calling from a program, nil means \"no arg\",
+a number counts as a prefix arg."
+ (interactive "*P")
+ (kill-region (point)
+ (progn
+ (if arg
+ (forward-line (prefix-numeric-value arg))
+ (if (eobp)
+ (signal 'end-of-buffer nil))
+ (if (looking-at "[ \t]*$")
+ (forward-line 1)
+ (end-of-line)))
+ (point))))
+
+;;;; The kill ring
+
+(defvar kill-ring nil
+ "List of killed text sequences.")
+
+(defconst kill-ring-max 30
+ "*Maximum length of kill ring before oldest elements are thrown away.")
+
+(defvar kill-ring-yank-pointer nil
+ "The tail of the kill ring whose car is the last thing yanked.")
+
+(defun kill-append (string before-p)
+ (setcar kill-ring
+ (if before-p
+ (concat string (car kill-ring))
+ (concat (car kill-ring) string))))
+
+(defun kill-region (beg end)
+ "Kill between point and mark.
+The text is deleted but saved in the kill ring.
+The command \\[yank] can retrieve it from there.
+\(If you want to kill and then yank immediately, use \\[copy-region-as-kill].)
+
+This is the primitive for programs to kill text (as opposed to deleting it).
+Supply two arguments, character numbers indicating the stretch of text
+ to be killed.
+Any command that calls this function is a \"kill command\".
+If the previous command was also a kill command,
+the text killed this time appends to the text killed last time
+to make one entry in the kill ring."
+ (interactive "*r")
+ (if (and (not (eq buffer-undo-list t))
+ (not (eq last-command 'kill-region))
+ (not (eq beg end))
+ ;; This test is here in case someone wants to remove the `*'
+ ;; above, so that the text gets stored in the kill ring
+ ;; even though it doesn't get deleted.
+ (not buffer-read-only))
+ ;; Don't let the undo list be truncated before we can even access it.
+ (let ((undo-high-threshold (+ (- (max beg end) (min beg end)) 100)))
+ (delete-region beg end)
+ ;; Take the same string recorded for undo
+ ;; and put it in the kill-ring.
+ (setq kill-ring (cons (car (car buffer-undo-list)) kill-ring))
+ (if (> (length kill-ring) kill-ring-max)
+ (setcdr (nthcdr (1- kill-ring-max) kill-ring) nil))
+ (setq this-command 'kill-region)
+ (setq kill-ring-yank-pointer kill-ring))
+ (copy-region-as-kill beg end)
+ (delete-region beg end)))
+
+(fset 'kill-ring-save 'copy-region-as-kill)
+
+(defun copy-region-as-kill (beg end)
+ "Save the region as if killed, but don't kill it."
+ (interactive "r")
+ (if (eq last-command 'kill-region)
+ (kill-append (buffer-substring beg end) (< end beg))
+ (setq kill-ring (cons (buffer-substring beg end) kill-ring))
+ (if (> (length kill-ring) kill-ring-max)
+ (setcdr (nthcdr (1- kill-ring-max) kill-ring) nil)))
+ (setq this-command 'kill-region)
+ (setq kill-ring-yank-pointer kill-ring))
+
+(defun append-next-kill ()
+ "Cause following command, if kill, to append to previous kill."
+ (interactive)
+ (if (interactive-p)
+ (setq this-command 'kill-region)
+ (setq last-command 'kill-region)))
+
+(defun rotate-yank-pointer (arg)
+ "Rotate the yanking point in the kill ring."
+ (interactive "p")
+ (let ((length (length kill-ring)))
+ (if (zerop length)
+ (error "Kill ring is empty")
+ (setq kill-ring-yank-pointer
+ (nthcdr (% (+ arg (- length (length kill-ring-yank-pointer)))
+ length)
+ kill-ring)))))
+
+(defun yank-pop (arg)
+ "Replace just-yanked stretch of killed-text with a different stretch.
+This command is allowed only immediately after a yank or a yank-pop.
+At such a time, the region contains a stretch of reinserted
+previously-killed text. yank-pop deletes that text and inserts in its
+place a different stretch of killed text.
+
+With no argument, the previous kill is inserted.
+With argument n, the n'th previous kill is inserted.
+If n is negative, this is a more recent kill.
+
+The sequence of kills wraps around, so that after the oldest one
+comes the newest one."
+ (interactive "*p")
+ (if (not (eq last-command 'yank))
+ (error "Previous command was not a yank"))
+ (setq this-command 'yank)
+ (let ((before (< (point) (mark))))
+ (delete-region (point) (mark))
+ (rotate-yank-pointer arg)
+ (set-mark (point))
+ (insert (car kill-ring-yank-pointer))
+ (if before (exchange-point-and-mark))))
+
+(defun yank (&optional arg)
+ "Reinsert the last stretch of killed text.
+More precisely, reinsert the stretch of killed text most recently
+killed OR yanked.
+With just C-U as argument, same but put point in front (and mark at end).
+With argument n, reinsert the nth most recently killed stretch of killed
+text.
+See also the command \\[yank-pop]."
+ (interactive "*P")
+ (rotate-yank-pointer (if (listp arg) 0
+ (if (eq arg '-) -1
+ (1- arg))))
+ (push-mark (point))
+ (insert (car kill-ring-yank-pointer))
+ (if (consp arg)
+ (exchange-point-and-mark)))
+
+(defun insert-buffer (buffer)
+ "Insert after point the contents of BUFFER.
+Puts mark after the inserted text.
+BUFFER may be a buffer or a buffer name."
+ (interactive "*bInsert buffer: ")
+ (or (bufferp buffer)
+ (setq buffer (get-buffer buffer)))
+ (let (start end newmark)
+ (save-excursion
+ (save-excursion
+ (set-buffer buffer)
+ (setq start (point-min) end (point-max)))
+ (insert-buffer-substring buffer start end)
+ (setq newmark (point)))
+ (push-mark newmark)))
+
+(defun append-to-buffer (buffer start end)
+ "Append to specified buffer the text of the region.
+It is inserted into that buffer before its point.
+
+When calling from a program, give three arguments:
+a buffer or the name of one, and two character numbers
+specifying the portion of the current buffer to be copied."
+ (interactive "BAppend to buffer: \nr")
+ (let ((oldbuf (current-buffer)))
+ (save-excursion
+ (set-buffer (get-buffer-create buffer))
+ (insert-buffer-substring oldbuf start end))))
+
+(defun prepend-to-buffer (buffer start end)
+ "Prepend to specified buffer the text of the region.
+It is inserted into that buffer after its point.
+
+When calling from a program, give three arguments:
+a buffer or the name of one, and two character numbers
+specifying the portion of the current buffer to be copied."
+ (interactive "BPrepend to buffer: \nr")
+ (let ((oldbuf (current-buffer)))
+ (save-excursion
+ (set-buffer (get-buffer-create buffer))
+ (save-excursion
+ (insert-buffer-substring oldbuf start end)))))
+
+(defun copy-to-buffer (buffer start end)
+ "Copy to specified buffer the text of the region.
+It is inserted into that buffer, replacing existing text there.
+
+When calling from a program, give three arguments:
+a buffer or the name of one, and two character numbers
+specifying the portion of the current buffer to be copied."
+ (interactive "BCopy to buffer: \nr")
+ (let ((oldbuf (current-buffer)))
+ (save-excursion
+ (set-buffer (get-buffer-create buffer))
+ (erase-buffer)
+ (save-excursion
+ (insert-buffer-substring oldbuf start end)))))
+
+(defun mark ()
+ "Return this buffer's mark value as integer, or nil if no mark.
+If you are using this in an editing command, you are most likely making
+a mistake; see the documentation of `set-mark'."
+ (marker-position (mark-marker)))
+
+(defun set-mark (pos)
+ "Set this buffer's mark to POS. Don't use this function!
+That is to say, don't use this function unless you want
+the user to see that the mark has moved, and you want the previous
+mark position to be lost.
+
+Normally, when a new mark is set, the old one should go on the stack.
+This is why most applications should use push-mark, not set-mark.
+
+Novice emacs-lisp programmers often try to use the mark for the wrong
+purposes. The mark saves a location for the user's convenience.
+Most editing commands should not alter the mark.
+To remember a location for internal use in the Lisp program,
+store it in a Lisp variable. Example:
+
+ (let ((beg (point))) (forward-line 1) (delete-region beg (point)))."
+
+ (set-marker (mark-marker) pos (current-buffer)))
+
+(defvar mark-ring nil
+ "The list of saved former marks of the current buffer,
+most recent first.")
+(make-variable-buffer-local 'mark-ring)
+
+(defconst mark-ring-max 16
+ "*Maximum size of mark ring. Start discarding off end if gets this big.")
+
+(defun set-mark-command (arg)
+ "Set mark at where point is, or jump to mark.
+With no prefix argument, set mark, and push previous mark on mark ring.
+With argument, jump to mark, and pop into mark off the mark ring.
+
+Novice emacs-lisp programmers often try to use the mark for the wrong
+purposes. See the documentation of `set-mark' for more information."
+ (interactive "P")
+ (if (null arg)
+ (push-mark)
+ (if (null (mark))
+ (error "No mark set in this buffer")
+ (goto-char (mark))
+ (pop-mark))))
+
+(defun push-mark (&optional location nomsg)
+ "Set mark at LOCATION (point, by default) and push old mark on mark ring.
+Displays \"Mark set\" unless the optional second arg NOMSG is non-nil.
+
+Novice emacs-lisp programmers often try to use the mark for the wrong
+purposes. See the documentation of `set-mark' for more information."
+ (if (null (mark))
+ nil
+ (setq mark-ring (cons (copy-marker (mark-marker)) mark-ring))
+ (if (> (length mark-ring) mark-ring-max)
+ (progn
+ (move-marker (car (nthcdr mark-ring-max mark-ring)) nil)
+ (setcdr (nthcdr (1- mark-ring-max) mark-ring) nil))))
+ (set-mark (or location (point)))
+ (or nomsg executing-macro (> (minibuffer-depth) 0)
+ (message "Mark set")))
+
+(defun pop-mark ()
+ "Pop off mark ring into the buffer's actual mark.
+Does not set point. Does nothing if mark ring is empty."
+ (if mark-ring
+ (progn
+ (setq mark-ring (nconc mark-ring (list (copy-marker (mark-marker)))))
+ (set-mark (+ 0 (car mark-ring)))
+ (move-marker (car mark-ring) nil)
+ (if (null (mark)) (ding))
+ (setq mark-ring (cdr mark-ring)))))
+
+(fset 'exchange-dot-and-mark 'exchange-point-and-mark)
+(defun exchange-point-and-mark ()
+ "Put the mark where point is now, and point where the mark is now."
+ (interactive nil)
+ (let ((omark (mark)))
+ (if (null omark)
+ (error "No mark set in this buffer"))
+ (set-mark (point))
+ (goto-char omark)
+ nil))
+
+(defun next-line (arg)
+ "Move cursor vertically down ARG lines.
+If there is no character in the target line exactly under the current column,
+the cursor is positioned after the character in that line which spans this
+column, or at the end of the line if it is not long enough.
+If there is no line in the buffer after this one,
+a newline character is inserted to create a line
+and the cursor moves to that line.
+
+The command \\[set-goal-column] can be used to create
+a semipermanent goal column to which this command always moves.
+Then it does not try to move vertically.
+
+If you are thinking of using this in a Lisp program, consider
+using `forward-line' instead. It is usually easier to use
+and more reliable (no dependence on goal column, etc.)."
+ (interactive "p")
+ (if (= arg 1)
+ (let ((opoint (point)))
+ (forward-line 1)
+ (if (or (= opoint (point))
+ (not (eq (preceding-char) ?\n)))
+ (insert ?\n)
+ (goto-char opoint)
+ (next-line-internal arg)))
+ (next-line-internal arg))
+ nil)
+
+(defun previous-line (arg)
+ "Move cursor vertically up ARG lines.
+If there is no character in the target line exactly over the current column,
+the cursor is positioned after the character in that line which spans this
+column, or at the end of the line if it is not long enough.
+
+The command \\[set-goal-column] can be used to create
+a semipermanent goal column to which this command always moves.
+Then it does not try to move vertically.
+
+If you are thinking of using this in a Lisp program, consider using
+`forward-line' with negative argument instead.. It is usually easier
+to use and more reliable (no dependence on goal column, etc.)."
+ (interactive "p")
+ (next-line-internal (- arg))
+ nil)
+
+(defconst track-eol nil
+ "*Non-nil means vertical motion starting at the end of a line should keep to ends of lines.
+This means moving to the end of each line moved onto.")
+
+(defvar goal-column nil
+ "*Semipermanent goal column for vertical motion, as set by \\[set-goal-column], or nil.")
+
+(defvar temporary-goal-column 0
+ "Current goal column for vertical motion.
+It is the column where point was at the start of current run of vertical motion commands.")
+
+(defun next-line-internal (arg)
+ (if (not (or (eq last-command 'next-line)
+ (eq last-command 'previous-line)))
+ (setq temporary-goal-column
+ (if (and track-eol (eolp))
+ t
+ (current-column))))
+ (if (not (integerp selective-display))
+ (forward-line arg)
+ ;; Move by arg lines, but ignore invisible ones.
+ (while (> arg 0)
+ (vertical-motion 1)
+ (forward-char -1)
+ (forward-line 1)
+ (setq arg (1- arg)))
+ (while (< arg 0)
+ (vertical-motion -1)
+ (beginning-of-line)
+ (setq arg (1+ arg))))
+ (if (eq (or goal-column temporary-goal-column) t)
+ (end-of-line)
+ (move-to-column (or goal-column temporary-goal-column)))
+ nil)
+
+
+(defun set-goal-column (arg)
+ "Set the current horizontal position as a goal for \\[next-line] and \\[previous-line].
+Those commands will move to this position in the line moved to
+rather than trying to keep the same horizontal position.
+With a non-nil argument, clears out the goal column
+so that \\[next-line] and \\[previous-line] resume vertical motion."
+ (interactive "P")
+ (if arg
+ (progn
+ (setq goal-column nil)
+ (message "No goal column"))
+ (setq goal-column (current-column))
+ (message (substitute-command-keys
+ "Goal column %d (use \\[set-goal-column] with an arg to unset it)")
+ goal-column))
+ nil)
+
+(defun transpose-chars (arg)
+ "Interchange characters around point, moving forward one character.
+With prefix arg ARG, effect is to take character before point
+and drag it forward past ARG other characters (backward if ARG negative).
+If no argument and at end of line, the previous two chars are exchanged."
+ (interactive "*P")
+ (and (null arg) (eolp) (forward-char -1))
+ (transpose-subr 'forward-char (prefix-numeric-value arg)))
+
+(defun transpose-words (arg)
+ "Interchange words around point, leaving point at end of them.
+With prefix arg ARG, effect is to take word before or around point
+and drag it forward past ARG other words (backward if ARG negative).
+If ARG is zero, the words around or after point and around or after mark
+are interchanged."
+ (interactive "*p")
+ (transpose-subr 'forward-word arg))
+
+(defun transpose-sexps (arg)
+ "Like \\[transpose-words] but applies to sexps.
+Does not work on a sexp that point is in the middle of
+if it is a list or string."
+ (interactive "*p")
+ (transpose-subr 'forward-sexp arg))
+
+(defun transpose-lines (arg)
+ "Exchange current line and previous line, leaving point after both.
+With argument ARG, takes previous line and moves it past ARG lines.
+With argument 0, interchanges line point is in with line mark is in."
+ (interactive "*p")
+ (transpose-subr (function
+ (lambda (arg)
+ (if (= arg 1)
+ (progn
+ ;; Move forward over a line,
+ ;; but create a newline if none exists yet.
+ (end-of-line)
+ (if (eobp)
+ (newline)
+ (forward-char 1)))
+ (forward-line arg))))
+ arg))
+
+(defun transpose-subr (mover arg)
+ (let (start1 end1 start2 end2)
+ (if (= arg 0)
+ (progn
+ (save-excursion
+ (funcall mover 1)
+ (setq end2 (point))
+ (funcall mover -1)
+ (setq start2 (point))
+ (goto-char (mark))
+ (funcall mover 1)
+ (setq end1 (point))
+ (funcall mover -1)
+ (setq start1 (point))
+ (transpose-subr-1))
+ (exchange-point-and-mark)))
+ (while (> arg 0)
+ (funcall mover -1)
+ (setq start1 (point))
+ (funcall mover 1)
+ (setq end1 (point))
+ (funcall mover 1)
+ (setq end2 (point))
+ (funcall mover -1)
+ (setq start2 (point))
+ (transpose-subr-1)
+ (goto-char end2)
+ (setq arg (1- arg)))
+ (while (< arg 0)
+ (funcall mover -1)
+ (setq start2 (point))
+ (funcall mover -1)
+ (setq start1 (point))
+ (funcall mover 1)
+ (setq end1 (point))
+ (funcall mover 1)
+ (setq end2 (point))
+ (transpose-subr-1)
+ (setq arg (1+ arg)))))
+
+(defun transpose-subr-1 ()
+ (if (> (min end1 end2) (max start1 start2))
+ (error "Don't have two things to transpose"))
+ (let ((word1 (buffer-substring start1 end1))
+ (word2 (buffer-substring start2 end2)))
+ (delete-region start2 end2)
+ (goto-char start2)
+ (insert word1)
+ (goto-char (if (< start1 start2) start1
+ (+ start1 (- (length word1) (length word2)))))
+ (delete-char (length word1))
+ (insert word2)))
+
+(defconst comment-column 32
+ "*Column to indent right-margin comments to.
+Setting this variable automatically makes it local to the current buffer.")
+(make-variable-buffer-local 'comment-column)
+
+(defconst comment-start nil
+ "*String to insert to start a new comment, or nil if no comment syntax defined.")
+
+(defconst comment-start-skip nil
+ "*Regexp to match the start of a comment plus everything up to its body.
+If there are any \\(...\\) pairs, the comment delimiter text is held to begin
+at the place matched by the close of the first pair.")
+
+(defconst comment-end ""
+ "*String to insert to end a new comment.
+Should be an empty string if comments are terminated by end-of-line.")
+
+(defconst comment-indent-hook
+ '(lambda () comment-column)
+ "Function to compute desired indentation for a comment
+given the character number it starts at.")
+
+(defun indent-for-comment ()
+ "Indent this line's comment to comment column, or insert an empty comment."
+ (interactive "*")
+ (beginning-of-line 1)
+ (if (null comment-start)
+ (error "No comment syntax defined")
+ (let* ((eolpos (save-excursion (end-of-line) (point)))
+ cpos indent begpos)
+ (if (re-search-forward comment-start-skip eolpos 'move)
+ (progn (setq cpos (point-marker))
+ ;; Find the start of the comment delimiter.
+ ;; If there were paren-pairs in comment-start-skip,
+ ;; position at the end of the first pair.
+ (if (match-end 1)
+ (goto-char (match-end 1))
+ ;; If comment-start-skip matched a string with internal
+ ;; whitespace (not final whitespace) then the delimiter
+ ;; start at the end of that whitespace.
+ ;; Otherwise, it starts at the beginning of what was matched.
+ (skip-chars-backward " \t" (match-beginning 0))
+ (skip-chars-backward "^ \t" (match-beginning 0)))))
+ (setq begpos (point))
+ ;; Compute desired indent.
+ (if (= (current-column)
+ (setq indent (funcall comment-indent-hook)))
+ (goto-char begpos)
+ ;; If that's different from current, change it.
+ (skip-chars-backward " \t")
+ (delete-region (point) begpos)
+ (indent-to indent))
+ ;; An existing comment?
+ (if cpos
+ (progn (goto-char cpos)
+ (set-marker cpos nil))
+ ;; No, insert one.
+ (insert comment-start)
+ (save-excursion
+ (insert comment-end))))))
+
+(defun set-comment-column (arg)
+ "Set the comment column based on point.
+With no arg, set the comment column to the current column.
+With just minus as arg, kill any comment on this line.
+With any other arg, set comment column to indentation of the previous comment
+ and then align or create a comment on this line at that column."
+ (interactive "P")
+ (if (eq arg '-)
+ (kill-comment nil)
+ (if arg
+ (progn
+ (save-excursion
+ (beginning-of-line)
+ (re-search-backward comment-start-skip)
+ (beginning-of-line)
+ (re-search-forward comment-start-skip)
+ (goto-char (match-beginning 0))
+ (setq comment-column (current-column))
+ (message "Comment column set to %d" comment-column))
+ (indent-for-comment))
+ (setq comment-column (current-column))
+ (message "Comment column set to %d" comment-column))))
+
+(defun kill-comment (arg)
+ "Kill the comment on this line, if any.
+With argument, kill comments on that many lines starting with this one."
+ (interactive "P")
+ (barf-if-buffer-read-only)
+ (let ((count (prefix-numeric-value arg)))
+ (beginning-of-line)
+ (while (> count 0)
+ (let ((eolpos (save-excursion (end-of-line) (point))))
+ (if (re-search-forward comment-start-skip eolpos t)
+ (progn
+ (goto-char (match-beginning 0))
+ (skip-chars-backward " \t")
+ (kill-region (point) eolpos))))
+ (if arg
+ (forward-line 1))
+ (setq count (1- count)))))
+
+(defun backward-word (arg)
+ "Move backward until encountering the end of a word.
+With argument, do this that many times.
+In programs, it is faster to call forward-word with negative arg."
+ (interactive "p")
+ (forward-word (- arg)))
+
+(defun mark-word (arg)
+ "Set mark arg words away from point."
+ (interactive "p")
+ (push-mark
+ (save-excursion
+ (forward-word arg)
+ (point))))
+
+(defun kill-word (arg)
+ "Kill characters forward until encountering the end of a word.
+With argument, do this that many times."
+ (interactive "*p")
+ (kill-region (point) (progn (forward-word arg) (point))))
+
+(defun backward-kill-word (arg)
+ "Kill characters backward until encountering the end of a word.
+With argument, do this that many times."
+ (interactive "*p")
+ (kill-word (- arg)))
+
+(defconst fill-prefix nil
+ "*String for filling to insert at front of new line, or nil for none.
+Setting this variable automatically makes it local to the current buffer.")
+(make-variable-buffer-local 'fill-prefix)
+
+(defun do-auto-fill ()
+ (let ((fill-point
+ (let ((opoint (point)))
+ (save-excursion
+ (move-to-column (1+ fill-column))
+ (skip-chars-backward "^ \t\n")
+ (if (bolp)
+ (re-search-forward "[ \t]" opoint t))
+ (skip-chars-backward " \t")
+ (point)))))
+ ;; If there is a space on the line before fill-point,
+ ;; and nonspaces precede it, break the line there.
+ (if (save-excursion
+ (goto-char fill-point)
+ (not (bolp)))
+ ;; If point is at the fill-point, do not `save-excursion'.
+ ;; Otherwise, if a comment prefix or fill-prefix is inserted,
+ ;; point will end up before it rather than after it.
+ (if (save-excursion
+ (skip-chars-backward " \t")
+ (= (point) fill-point))
+ (indent-new-comment-line)
+ (save-excursion
+ (goto-char fill-point)
+ (indent-new-comment-line))))))
+
+(defconst comment-multi-line nil
+ "*Non-nil means \\[indent-new-comment-line] should continue same comment
+on new line, with no new terminator or starter.")
+
+(defun indent-new-comment-line ()
+ "Break line at point and indent, continuing comment if presently within one.
+The body of the continued comment is indented under the previous comment line."
+ (interactive "*")
+ (let (comcol comstart)
+ (skip-chars-backward " \t")
+ (delete-region (point)
+ (progn (skip-chars-forward " \t")
+ (point)))
+ (insert ?\n)
+ (save-excursion
+ (if (and comment-start-skip
+ (let ((opoint (point)))
+ (forward-line -1)
+ (re-search-forward comment-start-skip opoint t)))
+ ;; The old line is a comment.
+ ;; Set WIN to the pos of the comment-start.
+ ;; But if the comment is empty, look at preceding lines
+ ;; to find one that has a nonempty comment.
+ (let ((win (match-beginning 0)))
+ (while (and (eolp) (not (bobp))
+ (let (opoint)
+ (beginning-of-line)
+ (setq opoint (point))
+ (forward-line -1)
+ (re-search-forward comment-start-skip opoint t)))
+ (setq win (match-beginning 0)))
+ ;; Indent this line like what we found.
+ (goto-char win)
+ (setq comcol (current-column))
+ (setq comstart (buffer-substring (point) (match-end 0))))))
+ (if comcol
+ (let ((comment-column comcol)
+ (comment-start comstart)
+ (comment-end comment-end))
+ (and comment-end (not (equal comment-end ""))
+ (if (not comment-multi-line)
+ (progn
+ (forward-char -1)
+ (insert comment-end)
+ (forward-char 1))
+ (setq comment-column (+ comment-column (length comment-start))
+ comment-start "")))
+ (if (not (eolp))
+ (setq comment-end ""))
+ (insert ?\n)
+ (forward-char -1)
+ (indent-for-comment)
+ (delete-char 1))
+ (if fill-prefix
+ (insert fill-prefix)
+ (indent-according-to-mode)))))
+
+(defun auto-fill-mode (arg)
+ "Toggle auto-fill mode.
+With arg, turn auto-fill mode on iff arg is positive.
+In auto-fill mode, inserting a space at a column beyond fill-column
+automatically breaks the line at a previous space."
+ (interactive "P")
+ (prog1 (setq auto-fill-hook
+ (if (if (null arg)
+ (not auto-fill-hook)
+ (> (prefix-numeric-value arg) 0))
+ 'do-auto-fill
+ nil))
+ ;; update mode-line
+ (set-buffer-modified-p (buffer-modified-p))))
+
+(defun turn-on-auto-fill ()
+ "Unconditionally turn on Auto Fill mode."
+ (auto-fill-mode 1))
+
+(defun set-fill-column (arg)
+ "Set fill-column to current column, or to argument if given.
+fill-column's value is separate for each buffer."
+ (interactive "P")
+ (setq fill-column (if (integerp arg) arg (current-column)))
+ (message "fill-column set to %d" fill-column))
+
+(defun set-selective-display (arg)
+ "Set selective-display to ARG; clear it if no arg.
+When selective-display is a number > 0,
+lines whose indentation is >= selective-display are not displayed.
+selective-display's value is separate for each buffer."
+ (interactive "P")
+ (if (eq selective-display t)
+ (error "selective-display already in use for marked lines"))
+ (setq selective-display
+ (and arg (prefix-numeric-value arg)))
+ (set-window-start (selected-window) (window-start (selected-window)))
+ (princ "selective-display set to " t)
+ (prin1 selective-display t)
+ (princ "." t))
+
+(defun overwrite-mode (arg)
+ "Toggle overwrite mode.
+With arg, turn overwrite mode on iff arg is positive.
+In overwrite mode, printing characters typed in replace existing text
+on a one-for-one basis, rather than pushing it to the right."
+ (interactive "P")
+ (setq overwrite-mode
+ (if (null arg) (not overwrite-mode)
+ (> (prefix-numeric-value arg) 0)))
+ (set-buffer-modified-p (buffer-modified-p))) ;No-op, but updates mode line.
+
+(defconst blink-matching-paren t
+ "*Non-nil means show matching open-paren when close-paren is inserted.")
+
+(defconst blink-matching-paren-distance 4000
+ "*If non-nil, is maximum distance to search for matching open-paren
+when close-paren is inserted.")
+
+(defun blink-matching-open ()
+ "Move cursor momentarily to the beginning of the sexp before point."
+ (and (> (point) (1+ (point-min)))
+ (/= (char-syntax (char-after (- (point) 2))) ?\\ )
+ blink-matching-paren
+ (let* ((oldpos (point))
+ (blinkpos)
+ (mismatch))
+ (save-excursion
+ (save-restriction
+ (if blink-matching-paren-distance
+ (narrow-to-region (max (point-min)
+ (- (point) blink-matching-paren-distance))
+ oldpos))
+ (condition-case ()
+ (setq blinkpos (scan-sexps oldpos -1))
+ (error nil)))
+ (and blinkpos (/= (char-syntax (char-after blinkpos))
+ ?\$)
+ (setq mismatch
+ (/= (char-after (1- oldpos))
+ (logand (lsh (aref (syntax-table)
+ (char-after blinkpos))
+ -8)
+ 255))))
+ (if mismatch (setq blinkpos nil))
+ (if blinkpos
+ (progn
+ (goto-char blinkpos)
+ (if (pos-visible-in-window-p)
+ (sit-for 1)
+ (goto-char blinkpos)
+ (message
+ "Matches %s"
+ (if (save-excursion
+ (skip-chars-backward " \t")
+ (not (bolp)))
+ (buffer-substring (progn (beginning-of-line) (point))
+ (1+ blinkpos))
+ (buffer-substring blinkpos
+ (progn
+ (forward-char 1)
+ (skip-chars-forward "\n \t")
+ (end-of-line)
+ (point)))))))
+ (cond (mismatch
+ (message "Mismatched parentheses"))
+ ((not blink-matching-paren-distance)
+ (message "Unmatched parenthesis"))))))))
+
+;Turned off because it makes dbx bomb out.
+(setq blink-paren-hook 'blink-matching-open)
+
+; this is just something for the luser to see in a keymap -- this is not
+; how quitting works normally!
+(defun keyboard-quit ()
+ "Signal a quit condition."
+ (interactive)
+ (signal 'quit nil))
+
+(define-key global-map "\C-g" 'keyboard-quit)
+
+(defun set-variable (var val)
+ "Set VARIABLE to VALUE. VALUE is a Lisp object.
+When using this interactively, supply a Lisp expression for VALUE.
+If you want VALUE to be a string, you must surround it with doublequotes."
+ (interactive
+ (let* ((var (read-variable "Set variable: "))
+ (minibuffer-help-form
+ '(funcall myhelp))
+ (myhelp
+ (function
+ (lambda ()
+ (with-output-to-temp-buffer "*Help*"
+ (prin1 var)
+ (princ "\nDocumentation:\n")
+ (princ (substring (documentation-property var 'variable-documentation)
+ 1))
+ (if (boundp var)
+ (let ((print-length 20))
+ (princ "\n\nCurrent value: ")
+ (prin1 (symbol-value var))))
+ nil)))))
+ (list var
+ (eval-minibuffer (format "Set %s to value: " var)))))
+ (set var val))
+
+;These commands are defined in editfns.c
+;but they are not assigned to keys there.
+(put 'narrow-to-region 'disabled t)
+(define-key ctl-x-map "n" 'narrow-to-region)
+(define-key ctl-x-map "w" 'widen)
+
+(define-key global-map "\C-j" 'newline-and-indent)
+(define-key global-map "\C-m" 'newline)
+(define-key global-map "\C-o" 'open-line)
+(define-key esc-map "\C-o" 'split-line)
+(define-key global-map "\C-q" 'quoted-insert)
+(define-key esc-map "^" 'delete-indentation)
+(define-key esc-map "\\" 'delete-horizontal-space)
+(define-key esc-map "m" 'back-to-indentation)
+(define-key ctl-x-map "\C-o" 'delete-blank-lines)
+(define-key esc-map " " 'just-one-space)
+(define-key esc-map "z" 'zap-to-char)
+(define-key esc-map "=" 'count-lines-region)
+(define-key ctl-x-map "=" 'what-cursor-position)
+(define-key esc-map "\e" 'eval-expression)
+(define-key ctl-x-map "\e" 'repeat-complex-command)
+(define-key ctl-x-map "u" 'advertised-undo)
+(define-key global-map "\C-_" 'undo)
+(define-key esc-map "!" 'shell-command)
+(define-key esc-map "|" 'shell-command-on-region)
+
+(define-key global-map "\C-u" 'universal-argument)
+(let ((i ?0))
+ (while (<= i ?9)
+ (define-key esc-map (char-to-string i) 'digit-argument)
+ (setq i (1+ i))))
+(define-key esc-map "-" 'negative-argument)
+
+(define-key global-map "\C-k" 'kill-line)
+(define-key global-map "\C-w" 'kill-region)
+(define-key esc-map "w" 'copy-region-as-kill)
+(define-key esc-map "\C-w" 'append-next-kill)
+(define-key global-map "\C-y" 'yank)
+(define-key esc-map "y" 'yank-pop)
+
+(define-key ctl-x-map "a" 'append-to-buffer)
+
+(define-key global-map "\C-@" 'set-mark-command)
+(define-key ctl-x-map "\C-x" 'exchange-point-and-mark)
+
+(define-key global-map "\C-n" 'next-line)
+(define-key global-map "\C-p" 'previous-line)
+(define-key ctl-x-map "\C-n" 'set-goal-column)
+
+(define-key global-map "\C-t" 'transpose-chars)
+(define-key esc-map "t" 'transpose-words)
+(define-key esc-map "\C-t" 'transpose-sexps)
+(define-key ctl-x-map "\C-t" 'transpose-lines)
+
+(define-key esc-map ";" 'indent-for-comment)
+(define-key esc-map "j" 'indent-new-comment-line)
+(define-key esc-map "\C-j" 'indent-new-comment-line)
+(define-key ctl-x-map ";" 'set-comment-column)
+(define-key ctl-x-map "f" 'set-fill-column)
+(define-key ctl-x-map "$" 'set-selective-display)
+
+(define-key esc-map "@" 'mark-word)
+(define-key esc-map "f" 'forward-word)
+(define-key esc-map "b" 'backward-word)
+(define-key esc-map "d" 'kill-word)
+(define-key esc-map "\177" 'backward-kill-word)
+
+(define-key esc-map "<" 'beginning-of-buffer)
+(define-key esc-map ">" 'end-of-buffer)
+(define-key ctl-x-map "h" 'mark-whole-buffer)
+(define-key esc-map "\\" 'delete-horizontal-space)
+
+(fset 'mode-specific-command-prefix (make-sparse-keymap))
+(defconst mode-specific-map (symbol-function 'mode-specific-command-prefix)
+ "Keymap for characters following C-c.")
+(define-key global-map "\C-c" 'mode-specific-command-prefix)
diff --git a/lisp/simple.elc b/lisp/simple.elc
new file mode 100644
index 00000000000..86a7623607e
--- /dev/null
+++ b/lisp/simple.elc
Binary files differ
diff --git a/lisp/simula.defns b/lisp/simula.defns
new file mode 100644
index 00000000000..935e9b4eb72
--- /dev/null
+++ b/lisp/simula.defns
@@ -0,0 +1,185 @@
+(define-abbrev-table 'simula-mode-abbrev-table '(
+ ("putreal" "PutReal" nil 0)
+ ("printfile" "Printfile" nil 0)
+ ("location" "Location" nil 0)
+ ("abs" "Abs" nil 0)
+ ("value" "VALUE" nil 0)
+ ("tanh" "Tanh" nil 0)
+ ("sinh" "Sinh" nil 0)
+ ("digit" "Digit" nil 0)
+ ("arctan" "ArcTan" nil 0)
+ ("arcsin" "ArcSin" nil 0)
+ ("cardinal" "Cardinal" nil 0)
+ ("linkage" "Linkage" nil 0)
+ ("cos" "Cos" nil 0)
+ ("virtual" "VIRTUAL" nil 0)
+ ("outimage" "OutImage" nil 0)
+ ("or" "OR" nil 0)
+ ("false" "FALSE" nil 0)
+ ("outreal" "OutReal" nil 0)
+ ("more" "More" nil 0)
+ ("if" "IF" nil 0)
+ ("histd" "Histd" nil 0)
+ ("getchar" "GetChar" nil 0)
+ ("not" "NOT" nil 0)
+ ("letter" "Letter" nil 0)
+ ("external" "EXTERNAL" nil 0)
+ ("text" "TEXT" nil 0)
+ ("intext" "InText" nil 0)
+ ("gt" "GT" nil 0)
+ ("boolean" "BOOLEAN" nil 0)
+ ("suc" "Suc" nil 0)
+ ("putfrac" "PutFrac" nil 0)
+ ("label" "LABEL" nil 0)
+ ("infile" "InFile" nil 0)
+ ("sub" "Sub" nil 0)
+ ("step" "STEP" nil 0)
+ ("poisson" "Poisson" nil 0)
+ ("locate" "Locate" nil 0)
+ ("accum" "Accum" nil 0)
+ ("out" "Out" nil 0)
+ ("go" "GO" nil 0)
+ ("endfile" "Endfile" nil 0)
+ ("inimage" "InImage" nil 0)
+ ("image" "Image" nil 0)
+ ("hidden" "HIDDEN" nil 0)
+ ("open" "Open" nil 0)
+ ("lastitem" "Lastitem" nil 0)
+ ("array" "ARRAY" nil 0)
+ ("prev" "Prev" nil 0)
+ ("outfrac" "OutFrac" nil 0)
+ ("name" "NAME" nil 0)
+ ("long" "LONG" nil 0)
+ ("getreal" "GetReal" nil 0)
+ ("end" "END" nil 0)
+ ("detach" "Detach" nil 0)
+ ("linear" "Linear" nil 0)
+ ("isorank" "ISORank" nil 0)
+ ("putfix" "PutFix" nil 0)
+ ("hold" "Hold" nil 0)
+ ("delay" "DELAY" nil 0)
+ ("comment" "COMMENT" nil 0)
+ ("while" "WHILE" nil 0)
+ ("rank" "Rank" nil 0)
+ ("randint" "RandInt" nil 0)
+ ("erlang" "Erlang" nil 0)
+ ("constant" "Constant" nil 0)
+ ("strip" "Strip" nil 0)
+ ("setpos" "Setpos" nil 0)
+ ("protected" "PROTECTED" nil 0)
+ ("main" "Main" nil 0)
+ ("ref" "REF" nil 0)
+ ("qua" "QUA" nil 0)
+ ("precede" "Precede" nil 0)
+ ("passivate" "Passivate" nil 0)
+ ("ge" "GE" nil 0)
+ ("discrete" "Discrete" nil 0)
+ ("before" "BEFORE" nil 0)
+ ("options" "OPTIONS" nil 0)
+ ("new" "NEW" nil 0)
+ ("length" "Length" nil 0)
+ ("procedure" "PROCEDURE" nil 0)
+ ("ne" "NE" nil 0)
+ ("to" "TO" nil 0)
+ ("short" "SHORT" nil 0)
+ ("putint" "PutInt" nil 0)
+ ("lt" "LT" nil 0)
+ ("into" "Into" nil 0)
+ ("eq" "EQ" nil 0)
+ ("character" "CHARACTER" nil 0)
+ ("wait" "Wait" nil 0)
+ ("until" "UNTIL" nil 0)
+ ("mod" "Mod" nil 0)
+ ("getfrac" "GetFrac" nil 0)
+ ("current" "Current" nil 0)
+ ("simset" "SimSet" nil 0)
+ ("outtext" "OutText" nil 0)
+ ("arccos" "ArcCos" nil 0)
+ ("start" "Start" nil 0)
+ ("resume" "Resume" nil 0)
+ ("inner" "INNER" nil 0)
+ ("when" "WHEN" nil 0)
+ ("terminate_pogram" "Terminate_Program" nil 0)
+ ("outfile" "OutFile" nil 0)
+ ("isochar" "ISOChar" nil 0)
+ ("time" "Time" nil 0)
+ ("integer" "INTEGER" nil 0)
+ ("then" "THEN" nil 0)
+ ("nextev" "Nextev" nil 0)
+ ("ln" "Ln" nil 0)
+ ("inchar" "InChar" nil 0)
+ ("idle" "Idle" nil 0)
+ ("empty" "Empty" nil 0)
+ ("char" "Char" nil 0)
+ ("last" "Last" nil 0)
+ ("eqv" "EQV" nil 0)
+ ("pred" "Pred" nil 0)
+ ("class" "CLASS" nil 0)
+ ("tan" "Tan" nil 0)
+ ("sqrt" "Sqrt" nil 0)
+ ("sin" "Sin" nil 0)
+ ("blanks" "Blanks" nil 0)
+ ("do" "DO" nil 0)
+ ("and" "AND" nil 0)
+ ("else" "ELSE" nil 0)
+ ("close" "Close" nil 0)
+ ("breakoutimage" "BreakOutImage" nil 0)
+ ("activate" "ACTIVATE" nil 0)
+ ("switch" "SWITCH" nil 0)
+ ("head" "Head" nil 0)
+ ("otherwise" "OTHERWISE" nil 0)
+ ("inint" "InInt" nil 0)
+ ("true" "TRUE" nil 0)
+ ("normal" "Normal" nil 0)
+ ("cosh" "Cosh" nil 0)
+ ("begin" "BEGIN" nil 0)
+ ("outfix" "OutFix" nil 0)
+ ("le" "LE" nil 0)
+ ("evtime" "Evtime" nil 0)
+ ("clear" "Clear" nil 0)
+ ("link" "Link" nil 0)
+ ("goto" "GOTO" nil 0)
+ ("exp" "Exp" nil 0)
+ ("uniform" "Uniform" nil 0)
+ ("real" "REAL" nil 0)
+ ("inreal" "InReal" nil 0)
+ ("getint" "GetInt" nil 0)
+ ("notext" "NOTEXT" nil 0)
+ ("call" "Call" nil 0)
+ ("spacing" "Spacing" nil 0)
+ ("putchar" "PutChar" nil 0)
+ ("sysout" "SysOut" nil 0)
+ ("copy" "Copy" nil 0)
+ ("after" "AFTER" nil 0)
+ ("line" "Line" nil 0)
+ ("for" "FOR" nil 0)
+ ("reactivate" "REACTIVATE" nil 0)
+ ("outint" "OutInt" nil 0)
+ ("directfile" "Directfile" nil 0)
+ ("terminated" "Terminated" nil 0)
+ ("sign" "Sign" nil 0)
+ ("process" "Process" nil 0)
+ ("negexp" "NegExp" nil 0)
+ ("is" "IS" nil 0)
+ ("imp" "IMP" nil 0)
+ ("follow" "Follow" nil 0)
+ ("prior" "PRIOR" nil 0)
+ ("first" "First" nil 0)
+ ("sysin" "SysIn" nil 0)
+ ("simulation" "Simulation" nil 0)
+ ("outchar" "OutChar" nil 0)
+ ("lowten" "LowTen" nil 0)
+ ("inspect" "INSPECT" nil 0)
+ ("histo" "Histo" nil 0)
+ ("eject" "Eject" nil 0)
+ ("this" "THIS" nil 0)
+ ("infrac" "InFrac" nil 0)
+ ("cancel" "Cancel" nil 0)
+ ("linesperpage" "LinesPerPage" nil 0)
+ ("draw" "Draw" nil 0)
+ ("at" "AT" nil 0)
+ ("pos" "Pos" nil 0)
+ ("none" "NONE" nil 0)
+ ("in" "IN" nil 0)
+ ("entier" "Entier" nil 0)
+ ))
diff --git a/lisp/simula.el b/lisp/simula.el
new file mode 100644
index 00000000000..206b639cb5e
--- /dev/null
+++ b/lisp/simula.el
@@ -0,0 +1,827 @@
+;; --- Simula Mode for GNU Emacs
+;; Copyright (C) 1988 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;; Written by Ole Bj|rn Hessen.
+;; Disclaimer: This is my first lisp program > 10 lines, and -- most of
+;; all an experiment using reg-exp to represent forms on the screen.
+;; The parser parses simula backward, an impossible job.
+;; Well, I nearly lost!! Luckily, hhe@ifi.uio.no plan to make a better one.
+
+(defvar simula-label "^[A-Za-z_{|}]+:")
+(defvar simula-CE "else\\b\\|when\\b\\|otherwise\\b")
+(defvar simula-CB "end\\b\\|!\\|comment\\b")
+(defvar simula-BE "end\\b")
+(defvar simula-BB "begin\\b")
+(defvar simula-FB "if\\b\\|while\\b\\|inspect\\b\\|for\\b")
+(defvar simula-eol "\n")
+(defvar simula-eof "@") ;the form is postfixed by this string
+
+(defvar simula-extended-form nil
+ "non-nil if want non-standard slowly (extended) form checking")
+
+(defvar simula-mode-syntax-table nil
+ "Syntax table in simula-mode buffers.")
+
+(defvar simula-mode-abbrev-table nil
+ "abbrev table in simula-mode buffers")
+
+(defvar simula-indent-mode 'simula-Nice-indent-mode)
+;;most users want this feature...
+
+(defvar Read-Simula-Keywords nil
+ "non-nil if read keywords already")
+
+(define-abbrev-table 'simula-mode-abbrev-table ())
+
+(defvar Simula-Keyword-Abbrev-File "simula.defns"
+ "nil if not to load the Capitalize Keywords feature")
+
+(defvar simula-mode-ignore-directives t
+ "Set to non nil if doesn't use % comment type lines.")
+
+(if simula-mode-syntax-table
+ ()
+ (let ((table (make-syntax-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 ?_ "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)
+ (modify-syntax-entry ?\\ "." table)
+ (modify-syntax-entry ?] ")[" table)
+ (modify-syntax-entry ?^ "." table)
+ (modify-syntax-entry ?\| "w" table)
+ (modify-syntax-entry ?\{ "w" table)
+ (modify-syntax-entry ?\} "w" table)
+ (modify-syntax-entry ?! "<" table)
+ (setq simula-mode-syntax-table table)))
+
+(defvar simula-mode-map ()
+ "Keymap used in simula mode.")
+
+(if simula-mode-map
+ ()
+ (setq simula-mode-map (make-sparse-keymap))
+ (define-key simula-mode-map "\t" 'simula-indent)
+ (define-key simula-mode-map "\r" 'simula-abbrev-expand-and-lf)
+ (define-key simula-mode-map "" 'backward-delete-char-untabify))
+
+
+(defun simula-mode ()
+ "This is a mode intended to support program development in Simula.."
+ (interactive)
+ (kill-all-local-variables)
+ (use-local-map simula-mode-map)
+ (setq major-mode 'simula-mode)
+ (setq mode-name "Simula")
+ (make-local-variable 'comment-column)
+ (setq comment-column 40)
+ (make-local-variable 'end-comment-column)
+ (setq end-comment-column 75)
+ (set-syntax-table simula-mode-syntax-table)
+ (make-local-variable 'paragraph-start)
+ (setq paragraph-start "^[ \t]*$\\|\\f")
+ (make-local-variable 'paragraph-separate)
+ (setq paragraph-separate paragraph-start)
+ (make-local-variable 'indent-line-function)
+ (setq indent-line-function 'simula-null-indent)
+ (make-local-variable 'require-final-newline)
+ (setq require-final-newline t) ;put a newline at end!
+ (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 "!+ *")
+ (make-local-variable 'comment-column)
+ (setq comment-start-skip "! *") ;not quite right, but..
+ (make-local-variable 'parse-sexp-ignore-comments)
+ (setq parse-sexp-ignore-comments nil)
+ (make-local-variable 'comment-multi-line)
+ (setq comment-multi-line t)
+ (setq local-abbrev-table simula-mode-abbrev-table)
+ ;;Capitalize-Simula-Keywords ought to run a hook!!!
+ (if Simula-Keyword-Abbrev-File
+ (progn
+ (setq abbrev-mode t)
+ (if Read-Simula-Keywords
+ ()
+ (condition-case err
+ (read-abbrev-file Simula-Keyword-Abbrev-File)
+ (file-error
+ (with-output-to-temp-buffer "*Help*"
+ (princ "Simula Mode can't load the Capitalize Simula ")
+ (princ "Keyword abbrev file\n\n")
+ (princ "Please do one of the following:\n")
+ (princ "1. Include this line in your .emacs file:\n")
+ (princ " (setq Simula-Keyword-Abbrev-File nil)\n")
+ (princ "2. Make a decent abbrev file by your self\n")
+ (princ "3. Mail obh@ifi.uio.no requesting the abbrev file\n"))))
+ (setq Read-Simula-Keywords t))))
+ (funcall simula-indent-mode) ;set indentation
+ (run-hooks 'simula-mode-hook))
+
+(defun simula-null-indent ()
+ (interactive))
+
+(setq simula-seen-FE nil) ;if seen FE during parsing; non-nil
+(setq simula-form-starter nil) ;string, the FB.
+(setq simula-form nil) ;string, the assembled form
+(setq simula-FB-hpos nil) ;FB's Hpos
+(setq simula-BB-hpos nil) ;BB's Hpos
+(setq simula-hpos nil) ;Hpos of preceeding simula form
+(setq simula-lf-count nil) ;A count of lf seen during parsing
+(setq simula-stack nil) ;A stack of regions representing form
+(setq simula-assemble nil) ;non-nil if assembling forms on stack
+(setq simula-debug nil) ;t if debugging forms
+
+
+;; some simple stack routines.
+(defun simula-push (v)
+ (if simula-assemble (setq simula-stack (cons v simula-stack))))
+
+(defun simula-pop ()
+ (prog1 (car simula-stack)
+ (setq simula-stack (cdr simula-stack))))
+;;The concepts of a stack is now obsolete...
+;;Major rewrite is wanted..
+
+(defun simula-inside-simple-string ()
+ ;returns t if inside a simulask simple string
+ (save-excursion
+ (skip-chars-backward "^\"\n'")
+ (if (bolp) nil
+ (let ((count 1))
+ (while (not (bolp))
+ (forward-char -1)
+ (skip-chars-backward "^\"\n'")
+ (setq count (1+ count)))
+ (= (% count 2) 0)))))
+
+
+;;ignore line starting with a %.
+;;form is evaled until line is not a compiler directive
+;;way is t if going forward
+;;returns with value of form
+;;didn't found how to use the right kind of scoping, so shit!!!
+;; -- HELP --
+
+(defun ignore-simula-directives (pedohejform &optional pedohejway)
+ (interactive)
+ (if simula-mode-ignore-directives (funcall pedohejform)
+ (let ((pedohejval (funcall pedohejform)) (pedohejhere (point)))
+ (beginning-of-line)
+ (while ;while directive line
+ (cond
+ ((not (= (following-char) ?%)) nil)
+ ((or (bobp) (eobp)) nil) ;and not beginning(end) of buffer
+ (t))
+ (if pedohejway (forward-line) (forward-char -1))
+ (setq pedohejval (funcall pedohejform)) ;execute form once more
+ (setq pedohejhere (point)) ;and goto beginning of that line.
+ (beginning-of-line))
+ (if (not (= (following-char) ?%)) (goto-char pedohejhere))
+ pedohejval))) ;return FROM if skipped something
+;Have you seen anybody prefixing a variable with my special password?
+;No? Good!
+
+
+;We are on a line which is _not_ a '%'-line directive,
+;and inside or _just_ after a '! blabla ;' or a 'end blabla ;' comment.
+;Our job is to skip that comment, returning position skipping from or
+;just nil if this is no comment
+
+(defun maybe-skip-simula-comment ()
+ (let ((here (point)) last-end tmp tmp1)
+ (ignore-simula-directives
+ (function
+ (lambda ()
+ (search-backward ";" (point-min) 0)
+ (while (simula-inside-simple-string)
+ (search-backward "\"")
+ (search-backward ";" (point-min) 0)))))
+ (re-search-forward
+ "^%\\|\"\\|!\\|\\bcomment\\b\\|\\bend\\b" here 0)
+ (while (or (= (setq tmp (preceding-char)) ?%)
+ (= tmp ?\"))
+ (if (= tmp ?\") (search-forward "\"" here 0)
+ (forward-line 1)
+ (if (> (point) here) (goto-char here)))
+ (re-search-forward
+ "^%\\|\"\\|!\\|\\bcomment\\b\\|\\bend\\b" here 0))
+ (if (= here (point)) nil ;no comment between "; blabla "
+ (if (= (preceding-char) ?!)
+ (progn ;a "; ! blabla " commentt
+ (forward-char -1)
+ here) ;ignore semicolon.
+ (forward-word -1)
+ (if (looking-at "comment")
+ here ;a "; comment blabla " string
+;; this is a end-comment
+ (setq last-end (point)) ;remember where end started
+ (while
+ (and ;skip directive lines
+ (progn ;and strings.
+ (setq tmp1
+ (re-search-forward
+ "^%\\|\"\\|!\\|\\bcomment\\b\\|\\bend\\b\\|\\bwhen\\b\\|\\belse\\b\\|\\botherwise\\b" here 0))
+ (while (and tmp1
+ (or (= (setq tmp (preceding-char)) ?%)
+ (= tmp ?\")))
+ (if (= tmp ?\") (search-forward "\"" here 0)
+ (forward-line 1))
+ (setq tmp1 (re-search-forward
+ "^%\\|\"\\|!\\|\\bcomment\\b\\|\\bend\\b\\|\\bwhen\\b\\|\\belse\\b\\|\\botherwise\\b" here 0)))
+ tmp1)
+ (cond
+ ((= (preceding-char) ?!) ;a "end ! " is part of end-comment
+ (if last-end ;skip it.
+ t
+ (forward-char -1) nil)) ;seen e.g. "end else !"
+ ;skip back over word
+ ((progn (forward-word -1) nil))
+ ((looking-at "comment")
+ (if (not last-end)
+ nil
+ (forward-word 1) t))
+ (t (setq last-end (if (looking-at "end") (point) nil))
+ (forward-word 1) t))))
+ (if (looking-at "!\\|\\bcomment")
+ here
+ (if last-end
+ (progn (goto-char last-end) here)
+ (goto-char here)
+ nil)))))))
+
+
+;;save this block form
+(defun save-simula-BB-BE()
+ (let ((end (point)) (beg nil))
+ (simula-push end)
+ (simula-back-level) ;goto before the begin at this level
+ (if (not simula-BB-hpos) ;save column number if this the first
+ (setq simula-BB-hpos (current-column)))
+ (setq beg (point))
+ (end-of-line)
+ (simula-push ;save unto stack a block level.
+ (concat
+ "BEGIN"
+ (if (> (point) end) ()
+ (setq simula-lf-count (1+ simula-lf-count))
+ simula-eol) ;there is a lf after the begin
+ " o "
+ (progn
+ (forward-line 2)
+ (if (> (point) end) ()
+ (setq simula-lf-count (1+ simula-lf-count))
+ simula-eol)))) ;and before the end.
+ (simula-push beg)
+ (goto-char beg)))
+
+
+
+
+;;assumes we are inside a begin blabla end sentence.
+;;returns _before_ the begin
+(defun simula-back-level()
+ (interactive)
+ (let ((end-comment))
+ (while
+ (and
+ (not (bobp))
+ (ignore-simula-directives
+ (function
+ (lambda ()
+ (re-search-backward "\\bend\\b\\|\\bbegin\\b" (point-min) 0)
+ (while (simula-inside-simple-string)
+ (search-backward "\"")
+ (re-search-backward "\\bend\\b\\|\\bbegin\\b" (point-min) 0))
+ t)))
+ (if (looking-at "begin")
+ (if (maybe-skip-simula-comment) ;ignore begin in (end)comments
+ (progn (if (looking-at "end") (forward-word 1)) t)
+ nil) ;else exit while.
+ (if (setq end-comment (maybe-skip-simula-comment))
+ (if (looking-at "comment\\|!") t ;then not an end-comment
+ (goto-char end-comment)
+ (simula-back-level)
+ t)
+ (simula-back-level)
+ t)))))
+ (if (not (looking-at "begin"))
+ (error "No matching BEGIN !!!")))
+
+
+
+;on entry cursor is on the line we should indent. It indent this line and
+;predicts the next line's hpos at return value!!
+(defun simula-find-indent (&optional predict-next)
+ (interactive)
+ (let
+ ((not-stop t) ;set to nil if stop parsing, 0 at bolp
+ (simexp 0) ;simexp= simula-lf-count, + simula exp.
+ tmp ch ;last read character
+ indent) ;hpos to indent lines line to.
+ (end-of-line)
+ (ignore-simula-directives ;ignore if this is a directive line
+ (function (lambda () (skip-chars-backward " \t"))))
+ (if (maybe-skip-simula-comment)
+ (if (looking-at "end") (forward-word 1)))
+ (setq simula-lf-count 0
+ simula-assemble t
+ simula-BB-hpos nil
+ simula-FB-hpos nil
+ simula-hpos nil
+ simula-seen-FE nil
+ simula-form nil
+ simula-form-starter nil ;string representing the form-starter
+ simula-stack (list (point) ;a stack of regions or strings.
+ simula-eof))
+ (while not-stop
+ (setq simexp (1+ simexp)) ;count up simula expressions seen.
+ (skip-chars-backward " \t") ;skip ignoring whitespace
+ (if (bobp)
+ (setq not-stop nil) ;stop at start og buffer
+ (if (= (char-syntax (setq ch (preceding-char))) ?w)
+ (forward-word -1) ;back over item (ie. word or char.)
+ (forward-char -1))
+ (cond
+ ((eolp) ;passed a new-line
+ (cond
+ ((numberp not-stop) ;if zero, then stop parsing.
+ (setq not-stop nil)
+ (forward-char 1))
+ (t ;else count up lf's
+ (if (/= simula-lf-count (1- simexp))
+ (setq simula-lf-count (1+ simula-lf-count)))
+ (setq simexp simula-lf-count) ;reset simexp.
+ (simula-push (1+ (point))) ;don't assemble newlines in
+ (ignore-simula-directives ;simula-form
+ (function (lambda () (skip-chars-backward " \t\n"))))
+ (simula-push simula-eol) ;save the newline
+ (simula-push (point))))) ;ignore region skipped
+
+ ((= ch ?\")
+ (save-simula-string)) ;skip the string
+
+ ((= ch ?\')
+ (forward-char -1)
+ (if (search-backward "'" (point-min) t)
+ (forward-char -1) ;skip to before '
+ (error "Unbalanced Character Quote")))
+
+ ((= ch ?:) (forward-word -1))
+
+ ((= ch ?\;) ;semicolon
+ (setq tmp (maybe-skip-simula-comment)) ;is this a comment?
+ (if (and tmp (looking-at "!\\|comment"))
+ (simula-parsed-over (1+ tmp)) ;ignore comments
+ (cond
+ ((and (> simula-lf-count 1) ;abort parsing if FE last exp in
+ (= simula-lf-count (1- simexp))) ;line only
+ (setq not-stop nil) ;stop parsing
+ (simula-stack-trick)) ;goto "next-line"
+ ((if (not tmp) nil ;do more parsing, but forget
+ (forward-word 1) ;the end-comment
+ (simula-parsed-over tmp)
+ nil))
+ ((= simexp 1) (setq simula-seen-FE t))
+ ((> simula-lf-count 0)
+ (simula-push (1+ (point)))
+ (setq simula-assemble nil))))) ;assemble only the last form
+
+ ((looking-at simula-BB)
+ (setq simula-seen-FE nil) ;forget the past
+ (if (> simula-lf-count 1)
+ (setq not-stop (simula-stack-trick)) ;stop here!!
+ (if (not simula-assemble)
+ (progn
+ (setq simula-stack (list (point)
+ (concat "/n o " simula-eof))
+ simula-assemble t)))
+ (if (not simula-BB-hpos)
+ (setq simula-BB-hpos (current-column)))))
+
+ ((and (looking-at simula-CE)
+ (setq tmp (maybe-skip-simula-comment)))
+ (forward-word 1) ;skip past end.
+ (simula-parsed-over tmp))
+
+ ((looking-at simula-BE) (save-simula-BB-BE))
+
+ ((and (not indent) ;if already found, skip this FB
+ (looking-at simula-FB))
+ (setq simula-form-starter
+ (buffer-substring (point) (match-end 0)))
+ (setq simula-FB-hpos (current-column))
+ (if (not (setq indent (Simula-Form-Handler)))
+ (setq simula-FB-hpos nil simula-form nil))
+ (if simula-seen-FE () ;if not seen FE, stop parsing
+ (setq not-stop nil) ;and indent from this line
+ (beginning-of-line))))))
+
+ (setq simula-hpos (current-simula-indentation)) ;save indentation
+ (if simula-form
+ (if (and predict-next simula-seen-FE)
+ (setcdr indent (cdr (Simula-Default-Handler))))
+ (setq indent (Simula-Default-Handler)))
+ indent))
+
+
+(defun simula-parsed-over (from)
+ (skip-chars-backward "\t") ;skip whitespace before comment.
+ (simula-push from) ;forget from
+ (save-excursion
+ (end-of-line) ;if passed newline don't forget
+ (if (< (point) from) ;that
+ (progn
+ (simula-push simula-eol)
+ (setq simula-lf-count (1+ simula-lf-count)))))
+ (simula-push (point))) ;mark region to be skipped past
+
+
+;;some better names wanted.
+(defun simula-stack-trick ()
+ ;;axiom: if skipped back over 2-* lines, then use the indentation
+ ;;of the line after the line where the BB was found. Or if skipped past
+ ;;at least two lines and see ";" + newline. Use next lines indentation.
+ ;;that means one must fix the stack..
+ (forward-line 1)
+ (ignore-simula-directives
+ (function
+ (lambda () (skip-chars-forward " \t\n")
+ (while (= (following-char) ?\!)
+ (search-forward ";" (point-max) 0)
+ (skip-chars-forward " \t\n"))))
+ t)
+ (let ((pointer simula-stack))
+ (while pointer
+ (if (and (numberp (car pointer))
+ (> (point) (car pointer)))
+ (setq simula-stack pointer pointer nil)
+ (setq pointer (cdr pointer))))) nil)
+
+
+(defun save-simula-string ()
+ (simula-push (point)) ;skip string contents
+ (skip-chars-backward "^\"\n" (point-min))
+ (if (= (preceding-char) ?\") nil
+ (error "UnBalanced String Quote \". "))
+ (simula-push (point))
+ (forward-char -1)) ;save the "" unto stack.
+
+
+(defun Simula-Form-Handler ()
+ (let ((handler (intern-soft
+ (concat "Simula-" (capitalize simula-form-starter)
+ "-Handler"))))
+ (if handler (funcall handler) nil)))
+
+
+(defun Simula-Default-Handler ()
+ (prog1
+ (if (and simula-seen-FE
+ (not simula-extended-form)
+ (not (or simula-BB-hpos simula-form)))
+ (list simula-hpos '(0 0))
+ (Simula-Default-Form-Handler Simula-Default-Form))
+ (setq simula-form nil)))
+
+
+
+(defun Simula-Default-Form-Handler (form)
+ (simula-collapse-stack) ;get assembled form
+ (let ((indentation (get-indent-amount form)))
+ (if (not indentation) nil
+ (setq simula-hpos
+ (if (not (bolp))
+ (save-excursion
+ (beginning-of-line)
+ (current-simula-indentation))
+ (current-simula-indentation))
+ indentation (cons (simula-indent-calc (car indentation))
+ (cdr indentation)))
+ indentation))) ;return (hpos (abs relhpos))
+
+(defun simula-collapse-stack ()
+ (let ((last-beg (if simula-assemble (point) (simula-pop)))
+ (pointer simula-stack))
+ (while pointer
+ (if (stringp (car pointer)) (setq pointer (cdr pointer))
+ (if last-beg
+ (progn
+ (setcar pointer (buffer-substring last-beg (car pointer)))
+ (setq last-beg nil pointer (cdr pointer)))
+ (setq last-beg (car pointer))
+ (setcar pointer (car (cdr pointer))) ;delete cons-cell
+ (setcdr pointer (cdr (cdr pointer))))))
+ (setq simula-form (apply 'concat simula-stack)
+ simula-stack (list (point) simula-form))))
+
+(defun get-indent-amount (indent-form-list)
+ (if indent-form-list
+ (if (string-match (car (car indent-form-list)) simula-form)
+ (progn
+ (if simula-debug
+ (with-output-to-temp-buffer "* forms *"
+ (print
+ (concat (car (car indent-form-list))"<---->" simula-form))))
+ (cdr (car indent-form-list)))
+ (get-indent-amount (cdr indent-form-list)))
+ nil))
+
+
+
+;axiom: (bolp) eq t
+(defun current-simula-indentation ()
+ (if (looking-at simula-label) ;skip labels
+ (re-search-forward simula-label)) ;ignore labels
+ (skip-chars-forward " \t") ;skip to first non-blank
+ (current-column)) ;and return with column nubmer
+
+
+(defun simula-indent-calc (amount)
+ (if amount
+ (let ((from (car amount)))
+ (+ (car (cdr amount))
+ (cond
+ ((= 0 from) simula-hpos) ;axiom: exists
+ ((and simula-FB-hpos (= 1 from)) simula-FB-hpos)
+ ((and simula-BB-hpos (= 2 from)) simula-BB-hpos)
+ (simula-hpos))))
+ simula-hpos))
+
+
+(defun simula-indent-line (to)
+ (beginning-of-line)
+ (if (= (following-char) ?\%) ()
+ (let ((space (% to tab-width)) (tabs (/ to tab-width)))
+ (if (looking-at simula-label) ;indent line after label
+ (progn
+ (re-search-forward simula-label) ;ignore labels
+ (if (> (current-column) to)
+ (setq tabs 0 space 1)
+ (insert-char ?\t 1) ;try fill to nearest tab position
+ (if (> (current-column) to) ;else fill blanks.
+ (backward-delete-char 1))
+ (setq to (- to (current-column)))
+ (setq tabs (/ to tab-width) space (% to tab-width)))))
+ (insert-char ?\t tabs) ;insert all the necessary tabs and
+ (insert-char ?\ space) ;spaces to indent line
+ (delete-region
+ (point) (progn (skip-chars-forward " \t" (point-max)) (point))))))
+
+
+(defun simula-abbrev-expand-and-lf (arg)
+ (interactive "p")
+ (expand-abbrev)
+ (insert-char ?\n 1)
+ (forward-char -1)
+ (let ((indent (save-excursion (simula-find-indent t))))
+ (if (progn (beginning-of-line)
+ (skip-chars-forward " \t")
+ (/= (following-char) ?!)) ;Only indent lines not starting with
+ ;a comment or something like it..
+ (simula-indent-line (car indent)))
+ (forward-line 1)
+ (simula-indent-line (simula-indent-calc (car (cdr indent))))))
+
+(defun simula-indent ()
+ (interactive)
+ (simula-indent-line (car (save-excursion (simula-find-indent)))))
+
+(defun Simula-While-Handler ()
+ (Simula-Default-Form-Handler Simula-While-Form))
+
+(defun Simula-If-Handler ()
+ (Simula-Default-Form-Handler Simula-If-Form))
+
+(defun Simula-Inspect-Handler ()
+ (Simula-Default-Form-Handler Simula-Inspect-Form))
+
+(defun Simula-For-Handler ()
+ (Simula-Default-Form-Handler Simula-For-Form))
+
+
+;;;;;; Nice Mode..
+(defun simula-Nice-indent-mode ()
+ (interactive)
+ (setq Simula-While-Form
+ '( ("while.*begin.*end;@" (0 0) (1 0))
+ ("while .*do.*begin\n.*\n.*end;@" (1 0) (0 0))
+ ("while .*do.*begin\n.*@" (1 3) (1 3))
+ ("while .*do.*begin.*@" (0 0) (1 3))
+ ("while .*do\n.*begin\n.*\n.*end;@" (2 0) (0 0))
+ ("while .*do\n.*begin\n.*@" (2 3) (2 3))
+ ("while .*do\n.*begin@" (1 3) (2 3))
+ ("while .*do\n.*;@" (1 3) (0 0))
+ ("while .*do\n.*@" (1 3) (1 3))
+ ("while .*do@" (0 0) (1 3))))
+ (setq Simula-Default-Form
+ '( ("begin.*end;@" (0 0) (0 0))
+ ("while .*do.*begin\n.*\n.*end;@" (0 0) (0 0))
+ ("begin.*@" (0 0) (2 3))
+ ("begin\n.*\n.*end.*@" (0 0) (0 0))
+ ("begin\n.*end;@" (2 3) (0 0))
+ ("begin\n.*\n.*end;@" (2 0) (0 0))
+ ("begin\n.*@" (2 3) (2 3))
+ ("begin\n.*\n@" (2 3) (2 3))
+ ("begin\n*.*\n*.*@" (2 3) (2 3))
+ (".*;@" (0 0) (0 0))
+ ("\n.*;@" (0 0) (0 0))
+ ("\n.*@" (0 0) (0 0))
+ ("." (0 0) (0 3))))
+ (setq Simula-If-Form
+ '( ("if.*begin.*end;@" (0 0) (1 0))
+ ("if .*begin.*@" (0 0) (2 3))
+ ("if .*else@" (0 0) (0 0))
+ ("if .*;@" (0 0) (0 0))
+ ("if .*@" (0 0) (0 3))
+ ("if .*begin.*\n.*@" (2 3) (2 3))
+ ("if .*\n.*;@" (0 3) (0 0))
+ ("if .*\n.*begin.*end.*@" (0 3) (0 0))
+ ("if .*\n.*begin.*@" (0 3) (2 3))
+ ("if .*else\n.*@" (0 3) (0 0))
+ ("if .*\n.*begin.*\n.*@" (2 3) (2 3))
+ ("if .*\n.*begin.*\n.*\n.*end.*@" (2 0) (0 0))
+ ("if .*begin.*\n.*\n.*end;.*@" (0 0) (0 0))
+ ("if .*begin.*\n.*\n.*end@" (2 0) (0 0))
+ ("else if.*@" (0 0) (0 3))
+ ("else@" (0 0) (0 3))
+ ("else.*begin.*@" (0 0) (2 3))
+ ("else.*begin.*\n.*@" (2 3) (2 3))
+ ("else.*begin.*\n.*\n.*end;@" (2 0) (0 0))
+ ("else .*;@" (0 0) (0 0))
+ ("else\n.*begin@" (0 3) (2 3))
+ ("else\n.*begin\n.*@" (2 3) (2 3))
+ ("else\n.*begin\n.*\n.*end.*@" (2 0) (0 0))))
+ (setq Simula-For-Form
+ '( ("for .*begin.*end;@" (0 0) (1 0))
+ ("for .*do.*;@" (0 0) (0 0))
+ ("for .*do@" (0 0) (1 3))
+ ("for .*do\n.*begin@" (1 3) (2 3))
+ ("for .*do\n.*begin\n.*@" (2 3) (2 3))
+ ("for .*do\n.*begin\n.*\n.*end.*@" (1 3) (0 0))
+ ("for .*do\n.*;@" (1 3) (0 0))
+ ("for .*do\n.*begin.*\n.*end.*@" (1 3) (0 0))
+ ("for .*do.*begin@" (0 0) (1 3))
+ ("for .*do.*begin\n.*end.*@" (1 3) (0 0))
+ ("for .*do.*begin\n.*@" (1 3) (1 3))
+ ("for .*do.*begin\n.*\n.*end.*@" (1 0) (0 0))))
+ (setq Simula-Inspect-Form
+ '( ("inspect .*do.*;@" (0 0) (0 0))
+ ("inspect .*do@" (0 0) (1 3))
+ ("inspect .*do\n.*begin.*end.*@" (1 3) (0 0))
+ ("inspect .*do\n.*begin.*@" (1 3) (2 3))
+ ("inspect .*do\n.*begin\n.*end.*@" (2 3) (0 0))
+ ("inspect .*do\n.*begin\n.*\n.*end.*@" (2 0) (0 0))
+ ("inspect .*do.*begin@" (0 0) (2 3))
+ ("inspect .*do.*begin\n.*end.*@" (2 3) (0 0))
+ ("inspect .*do.*begin\n.*@" (2 3) (2 3))
+ ("inspect .*do.*begin\n.*\n.*end.*;@" (2 0) (0 0))
+ ("inspect .*;@" (0 0) (0 0))
+ ("inspect .*@" (0 0) (0 3))
+ ("otherwise@" (0 0) (0 3))
+ ("otherwise\n.*begin@" (0 3) (2 3))
+ ("otherwise\n.*begin\n.*end.*@" (2 3) (0 0))
+ ("otherwise\n.*begin\n.*@" (2 3) (2 3))
+ ("otherwise\n.*begin\n.*\n.*end.*@" (2 0) (0 0))
+ ("otherwise .*begin .*end.*@" (0 0) (0 0))
+ ("otherwise .*begin.*@" (0 0) (2 3))
+ ("otherwise .*begin\n.*end.*@" (2 3) (0 0))
+ ("otherwise .*begin\n.*@" (2 3) (2 3))
+ ("otherwise .*begin\n.*\n.*end.*@" (2 0) (0 0))
+ ("when .*do@" (0 3) (0 6))
+ ("when .*do.*;@" (0 3) (0 0))
+ ("when .*do.*@" (0 3) (0 3))
+ ("when .*do\n.*begin@" (0 6) (2 3))
+ ("when .*do\n.*begin\n.*end;@" (2 3) (0 0))
+ ("when .*do\n.*begin\n.*@" (2 3) (2 3))
+ ("when .*do\n.*begin\n.*\n.*end;@" (2 0) (0 0))
+ ("when .*do\n.*begin\n.*\n.*end@" (2 0) (0 3))
+ ("when .*do\n.*begin .*end;@" (0 6) (0 0))
+ ("when .*do\n.*begin .*end@" (0 6) (0 3)))))
+
+(defun simula-Simed-indent-mode ()
+ ;;Should only indent after begin, so this is a overkill
+ ;;Hopefully, I'll do better when I care for it.
+ (interactive)
+ (setq Simula-While-Form
+ '( ("while .*do.*begin\n.*\nend;@" (1 0) (0 0))
+ ("while .*do.*begin\n.*@" (1 3) (1 3))
+ ("while .*do.*begin.*@" (0 0) (1 3))
+ ("while .*do\n.*begin\n.*\n.*end;@" (1 0) (0 0))
+ ("while .*do\n.*begin\n.*@" (2 3) (2 3))
+ ("while .*do\n.*begin@" (1 0) (1 3))
+ ("while .*do\n.*;@" (1 3) (0 0))
+ ("while .*do\n.*@" (1 3) (1 3))
+ ("while .*do@" (0 0) (1 0))))
+ (setq Simula-Default-Form
+ '( ("begin.*end;@" (0 0) (0 0))
+ ("begin.*@" (0 0) (2 3))
+ ("begin\n.*\nend" (0 0) (0 0))
+ ("begin\n.*end;@" (2 3) (0 0))
+ ("begin\n.*@" (2 3) (2 3))
+ ("begin\n*.*\n*.*@" (2 3) (2 3))
+ (".*;@" (0 0) (0 0))
+ ("\n.*;@" (0 0) (0 0))
+ ("\n.*@" (0 0) (0 0))
+ ("." (0 0) (0 3))))
+ (setq Simula-If-Form
+ '( ("if .*begin.*@" (0 0) (0 3))
+ ("if .*else@" (0 0) (0 0))
+ ("if .*;@" (0 0) (0 0))
+ ("if .*@" (0 0) (0 0))
+ ("if .*begin.*\n.*@" (0 3) (0 3))
+ ("if .*\n.*;@" (0 3) (0 0))
+ ("if .*\n.*begin.*end.*@" (0 0) (0 0))
+ ("if .*\n.*begin.*@" (0 0) (0 3))
+ ("if .*else\n.*@" (0 0) (0 0))
+ ("if .*\n.*begin.*\n.*@" (0 3) (0 3))
+ ("if .*\n.*begin.*\n.*\n.*end.*@" (0 0) (0 0))
+ ("if .*begin.*\n.*\n.*end;.*@" (0 0) (0 0))
+ ("if .*begin.*\n.*\n.*end@" (0 0) (0 0))
+ ("else if.*@" (0 0) (0 0))
+ ("else@" (0 0) (0 0))
+ ("else.*begin.*@" (0 0) (0 3))
+ ("else.*begin.*\n.*@" (0 3) (0 3))
+ ("else.*begin.*\n.*\n.*end;@" (0 0) (0 0))
+ ("else .*;@" (0 0) (0 0))
+ ("else\n.*begin@" (0 0) (0 3))
+ ("else\n.*begin\n.*@" (0 3) (0 3))
+ ("else\n.*begin\n.*\n.*end.*@" (0 0) (0 0))))
+ (setq Simula-For-Form
+ '( ("for .*do.*;@" (0 0) (0 0))
+ ("for .*do@" (0 0) (0 0))
+ ("for .*do\n.*begin@" (0 0) (0 3))
+ ("for .*do\n.*begin\n.*@" (0 3) (0 3))
+ ("for .*do\n.*begin\n.*\n.*end.*@" (0 0) (0 0))
+ ("for .*do\n.*;@" (0 3) (0 0))
+ ("for .*do\n.*begin.*\n.*end.*@" (0 0) (0 0))
+ ("for .*do.*begin@" (0 0) (0 3))
+ ("for .*do.*begin\n.*end.*@" (0 3) (0 0))
+ ("for .*do.*begin\n.*@" (0 3) (0 3))
+ ("for .*do.*begin\n.*\n.*end.*@" (0 0) (0 0))))
+ (setq Simula-Inspect-Form
+ '( ("inspect .*do.*;@" (0 0) (0 0))
+ ("inspect .*do@" (0 0) (0 0))
+ ("inspect .*do\n.*begin.*end.*@" (0 3) (0 0))
+ ("inspect .*do\n.*begin.*@" (0 0) (0 3))
+ ("inspect .*do\n.*begin\n.*end.*@" (0 0) (0 0))
+ ("inspect .*do\n.*begin\n.*\n.*end.*@" (0 0) (0 0))
+ ("inspect .*do.*begin@" (0 0) (0 3))
+ ("inspect .*do.*begin\n.*end.*@" (0 3) (0 0))
+ ("inspect .*do.*begin\n.*@" (0 3) (0 3))
+ ("inspect .*do.*begin\n.*\n.*end.*;@" (0 0) (0 0))
+ ("inspect .*;@" (0 0) (0 0))
+ ("inspect .*@" (0 0) (0 0))
+ ("otherwise@" (0 0) (0 0))
+ ("otherwise\n.*begin@" (0 0) (0 3))
+ ("otherwise\n.*begin\n.*end.*@" (0 3) (0 0))
+ ("otherwise\n.*begin\n.*@" (0 3) (0 3))
+ ("otherwise\n.*begin\n.*\n.*end.*@" (0 0) (0 0))
+ ("otherwise .*begin .*end.*@" (0 0) (0 0))
+ ("otherwise .*begin.*@" (0 0) (0 3))
+ ("otherwise .*begin\n.*end.*@" (0 3) (0 0))
+ ("otherwise .*begin\n.*@" (0 3) (0 3))
+ ("otherwise .*begin\n.*\n.*end.*@" (0 0) (0 0))
+ ("when .*do@" (0 0) (0 0))
+ ("when .*do.*;@" (0 0) (0 0))
+ ("when .*do.*@" (0 0) (0 0))
+ ("when .*do\n.*begin@" (0 0) (0 3))
+ ("when .*do\n.*begin\n.*end;@" (0 3) (0 0))
+ ("when .*do\n.*begin\n.*@" (0 3) (0 3))
+ ("when .*do\n.*begin\n.*\n.*end;@" (0 0) (0 0))
+ ("when .*do\n.*begin\n.*\n.*end@" (0 0) (0 0))
+ ("when .*do\n.*begin .*end;@" (0 3) (0 0))
+ ("when .*do\n.*begin .*end@" (0 3) (0 0)))))
diff --git a/lisp/simula.elc b/lisp/simula.elc
new file mode 100644
index 00000000000..76667f4ba64
--- /dev/null
+++ b/lisp/simula.elc
Binary files differ
diff --git a/lisp/sort.el b/lisp/sort.el
index d494b2e757c..5d185174865 100644
--- a/lisp/sort.el
+++ b/lisp/sort.el
@@ -38,7 +38,6 @@ across a sort record. They will be called many times from within sort-subr.
NEXTRECFUN is called with point at the end of the previous record.
It moves point to the start of the next record.
-It should move point to the end of the buffer if there are no more records.
The first record is assumed to start at the position of point when sort-subr
is called.
@@ -52,12 +51,12 @@ STARTKEYFUN and ENDKEYFUN are called. If STARTKEYFUN is nil, the key
starts at the beginning of the record.
ENDKEYFUN moves from the start of the sort key to the end of the sort key.
-ENDKEYFUN may be nil if STARTKEYFUN returns a value or if it would be the
+ENDRECFUN may be nil if STARTKEYFUN returns a value or if it would be the
same as ENDRECFUN."
(save-excursion
(message "Finding sort keys...")
(let* ((sort-lists (sort-build-lists nextrecfun endrecfun
- startkeyfun endkeyfun))
+ startkeyfun endkeyfun))
(old (reverse sort-lists)))
(if (null sort-lists)
()
@@ -67,7 +66,6 @@ same as ENDRECFUN."
(if (fboundp 'sortcar)
(sortcar sort-lists
(cond ((numberp (car (car sort-lists)))
- ;; This handles both ints and floats.
'<)
((consp (car (car sort-lists)))
'buffer-substring-lessp)
@@ -89,11 +87,10 @@ same as ENDRECFUN."
(if reverse (setq sort-lists (nreverse sort-lists)))
(message "Reordering buffer...")
(sort-reorder-buffer sort-lists old)))
- (message "Reordering buffer... Done"))
- nil)
+ (message "Reordering buffer... Done")))
;; Parse buffer into records using the arguments as Lisp expressions;
-;; return a list of records. Each record looks like (KEY STARTPOS . ENDPOS)
+;; return a list of records. Each record looks like (KEY STARTPOS ENDPOS)
;; where KEY is the sort key (a number or string),
;; and STARTPOS and ENDPOS are the bounds of this record in the buffer.
@@ -131,8 +128,8 @@ same as ENDRECFUN."
(equal (car key) start-rec)
(equal (cdr key) (point)))
(cons key key)
- (cons key (cons start-rec (point))))
- sort-lists)))
+ (list key start-rec (point)))
+ sort-lists)))
(and (not done) nextrecfun (funcall nextrecfun)))
sort-lists))
@@ -140,12 +137,6 @@ same as ENDRECFUN."
(let ((inhibit-quit t)
(last (point-min))
(min (point-min)) (max (point-max)))
- ;; Make sure insertions done for reordering
- ;; do not go after any markers at the end of the sorted region,
- ;; by inserting a space to separate them.
- (goto-char (point-max))
- (insert-before-markers " ")
- (narrow-to-region min (1- (point-max)))
(while sort-lists
(goto-char (point-max))
(insert-buffer-substring (current-buffer)
@@ -154,57 +145,49 @@ same as ENDRECFUN."
(goto-char (point-max))
(insert-buffer-substring (current-buffer)
(nth 1 (car sort-lists))
- (cdr (cdr (car sort-lists))))
- (setq last (cdr (cdr (car old)))
+ (nth 2 (car sort-lists)))
+ (setq last (nth 2 (car old))
sort-lists (cdr sort-lists)
old (cdr old)))
(goto-char (point-max))
(insert-buffer-substring (current-buffer)
last
max)
- ;; Delete the original copy of the text.
- (delete-region min max)
- ;; Get rid of the separator " ".
- (goto-char (point-max))
- (narrow-to-region min (1+ (point)))
- (delete-region (point) (1+ (point)))))
+ (delete-region min max))) ;get rid of old version
(defun sort-lines (reverse beg end)
"Sort lines in region alphabetically; argument means descending order.
Called from a program, there are three arguments:
REVERSE (non-nil means reverse order), BEG and END (region to sort)."
(interactive "P\nr")
- (save-excursion
- (save-restriction
- (narrow-to-region beg end)
- (goto-char (point-min))
- (sort-subr reverse 'forward-line 'end-of-line))))
+ (save-restriction
+ (narrow-to-region beg end)
+ (goto-char (point-min))
+ (sort-subr reverse 'forward-line 'end-of-line)))
(defun sort-paragraphs (reverse beg end)
"Sort paragraphs in region alphabetically; argument means descending order.
Called from a program, there are three arguments:
REVERSE (non-nil means reverse order), BEG and END (region to sort)."
(interactive "P\nr")
- (save-excursion
- (save-restriction
- (narrow-to-region beg end)
- (goto-char (point-min))
- (sort-subr reverse
- (function (lambda () (skip-chars-forward "\n \t\f")))
- 'forward-paragraph))))
+ (save-restriction
+ (narrow-to-region beg end)
+ (goto-char (point-min))
+ (sort-subr reverse
+ (function (lambda () (skip-chars-forward "\n \t\f")))
+ 'forward-paragraph)))
(defun sort-pages (reverse beg end)
"Sort pages in region alphabetically; argument means descending order.
Called from a program, there are three arguments:
REVERSE (non-nil means reverse order), BEG and END (region to sort)."
(interactive "P\nr")
- (save-excursion
- (save-restriction
- (narrow-to-region beg end)
- (goto-char (point-min))
- (sort-subr reverse
- (function (lambda () (skip-chars-forward "\n")))
- 'forward-page))))
+ (save-restriction
+ (narrow-to-region beg end)
+ (goto-char (point-min))
+ (sort-subr reverse
+ (function (lambda () (skip-chars-forward "\n")))
+ 'forward-page)))
(defvar sort-fields-syntax-table nil)
(if sort-fields-syntax-table nil
@@ -216,14 +199,13 @@ REVERSE (non-nil means reverse order), BEG and END (region to sort)."
(modify-syntax-entry ?\ " " table)
(modify-syntax-entry ?\t " " table)
(modify-syntax-entry ?\n " " table)
- (modify-syntax-entry ?\. "_" table) ; for floating pt. numbers. -wsr
(setq sort-fields-syntax-table table)))
(defun sort-numeric-fields (field beg end)
"Sort lines in region numerically by the ARGth field of each line.
Fields are separated by whitespace and numbered from 1 up.
Specified field must contain a number in each line of the region.
-With a negative arg, sorts by the ARGth field counted from the right.
+With a negative arg, sorts by the -ARG'th field, in reverse order.
Called from a program, there are three arguments:
FIELD, BEG and END. BEG and END specify region to sort."
(interactive "p\nr")
@@ -234,36 +216,14 @@ FIELD, BEG and END. BEG and END specify region to sort."
(buffer-substring
(point)
(save-excursion
- ;; This is just wrong! Even without floats...
- ;; (skip-chars-forward "[0-9]")
- (forward-sexp 1)
+ (skip-chars-forward "-0-9")
(point))))))
nil))
-(defun sort-float-fields (field beg end)
- "Sort lines in region numerically by the ARGth field of each line.
-Fields are separated by whitespace and numbered from 1 up. Specified field
-must contain a floating point number in each line of the region. With a
-negative arg, sorts by the ARGth field counted from the right. Called from a
-program, there are three arguments: FIELD, BEG and END. BEG and END specify
-region to sort."
- (interactive "p\nr")
- (sort-fields-1 field beg end
- (function (lambda ()
- (sort-skip-fields (1- field))
- (string-to-float
- (buffer-substring
- (point)
- (save-excursion
- (re-search-forward
- "[+-]?[0-9]*\.?[0-9]*\\([eE][+-]?[0-9]+\\)?")
- (point))))))
- nil))
-
(defun sort-fields (field beg end)
"Sort lines in region lexicographically by the ARGth field of each line.
Fields are separated by whitespace and numbered from 1 up.
-With a negative arg, sorts by the ARGth field counted from the right.
+With a negative arg, sorts by the -ARG'th field, in reverse order.
Called from a program, there are three arguments:
FIELD, BEG and END. BEG and END specify region to sort."
(interactive "p\nr")
@@ -274,32 +234,27 @@ FIELD, BEG and END. BEG and END specify region to sort."
(function (lambda () (skip-chars-forward "^ \t\n")))))
(defun sort-fields-1 (field beg end startkeyfun endkeyfun)
- (let ((tbl (syntax-table)))
- (if (zerop field) (setq field 1))
+ (let ((reverse (< field 0))
+ (tbl (syntax-table)))
+ (setq field (max 1 field (- field)))
(unwind-protect
- (save-excursion
- (save-restriction
- (narrow-to-region beg end)
- (goto-char (point-min))
- (set-syntax-table sort-fields-syntax-table)
- (sort-subr nil
- 'forward-line 'end-of-line
- startkeyfun endkeyfun)))
+ (save-restriction
+ (narrow-to-region beg end)
+ (goto-char (point-min))
+ (set-syntax-table sort-fields-syntax-table)
+ (sort-subr reverse
+ 'forward-line 'end-of-line
+ startkeyfun endkeyfun))
(set-syntax-table tbl))))
(defun sort-skip-fields (n)
- (let ((bol (point))
- (eol (save-excursion (end-of-line 1) (point))))
- (if (> n 0) (forward-word n)
- (end-of-line)
- (forward-word (1+ n)))
- (if (or (and (>= (point) eol) (> n 0))
- ;; this is marginally wrong; if the first line of the sort
- ;; at bob has the wrong number of fields the error won't be
- ;; reported until the next short line.
- (and (< (point) bol) (< n 0)))
+ (let ((eol (save-excursion (end-of-line 1) (point))))
+ (forward-word n)
+ (if (> (point) eol)
(error "Line has too few fields: %s"
- (buffer-substring bol eol)))
+ (buffer-substring (save-excursion
+ (beginning-of-line) (point))
+ eol)))
(skip-chars-forward " \t")))
@@ -319,51 +274,45 @@ With a negative prefix arg sorts in reverse order.
For example: to sort lines in the region by the first word on each line
starting with the letter \"f\",
- RECORD-REGEXP would be \"^.*$\" and KEY would be \"\\=\\<f\\w*\\>\""
- ;; using negative prefix arg to mean "reverse" is now inconsistent with
- ;; other sort-.*fields functions but then again this was before, since it
- ;; didn't use the magnitude of the arg to specify anything.
+ RECORD-REGEXP would be \"^.*$\" and KEY \"\\<f\\w*\\>\""
(interactive "P\nsRegexp specifying records to sort:
sRegexp specifying key within record: \nr")
(cond ((or (equal key-regexp "") (equal key-regexp "\\&"))
(setq key-regexp 0))
((string-match "\\`\\\\[1-9]\\'" key-regexp)
(setq key-regexp (- (aref key-regexp 1) ?0))))
- (save-excursion
- (save-restriction
- (narrow-to-region beg end)
- (goto-char (point-min))
- (let (sort-regexp-record-end) ;isn't dynamic scoping wonderful?
- (re-search-forward record-regexp)
- (setq sort-regexp-record-end (point))
- (goto-char (match-beginning 0))
- (sort-subr reverse
- (function (lambda ()
- (and (re-search-forward record-regexp nil 'move)
- (setq sort-regexp-record-end (match-end 0))
- (goto-char (match-beginning 0)))))
- (function (lambda ()
- (goto-char sort-regexp-record-end)))
- (function (lambda ()
- (let ((n 0))
- (cond ((numberp key-regexp)
- (setq n key-regexp))
- ((re-search-forward
- key-regexp sort-regexp-record-end t)
- (setq n 0))
- (t (throw 'key nil)))
- (condition-case ()
- (if (fboundp 'buffer-substring-lessp)
- (cons (match-beginning n)
- (match-end n))
- (buffer-substring (match-beginning n)
- (match-end n)))
- ;; if there was no such register
- (error (throw 'key nil)))))))))))
+ (save-restriction
+ (narrow-to-region beg end)
+ (goto-char (point-min))
+ (let (sort-regexp-record-end) ;isn't dynamic scoping wonderful?
+ (re-search-forward record-regexp)
+ (setq sort-regexp-record-end (point))
+ (goto-char (match-beginning 0))
+ (sort-subr reverse
+ (function (lambda ()
+ (and (re-search-forward record-regexp nil 'move)
+ (setq sort-regexp-record-end (match-end 0))
+ (goto-char (match-beginning 0)))))
+ (function (lambda ()
+ (goto-char sort-regexp-record-end)))
+ (function (lambda ()
+ (let ((n 0))
+ (cond ((numberp key-regexp)
+ (setq n key-regexp))
+ ((re-search-forward
+ key-regexp sort-regexp-record-end t)
+ (setq n 0))
+ (t (throw 'key nil)))
+ (condition-case ()
+ (if (fboundp 'buffer-substring-lessp)
+ (cons (match-beginning n)
+ (match-end n))
+ (buffer-substring (match-beginning n)
+ (match-end n)))
+ ;; if there was no such register
+ (error (throw 'key nil))))))))))
-(defvar sort-columns-subprocess t)
-
(defun sort-columns (reverse &optional beg end)
"Sort lines in region alphabetically by a certain range of columns.
For the purpose of this command, the region includes
@@ -371,11 +320,9 @@ the entire line that point is in and the entire line the mark is in.
The column positions of point and mark bound the range of columns to sort on.
A prefix argument means sort into reverse order.
-Note that `sort-columns' rejects text that contains tabs,
-because tabs could be split across the specified columns
-and it doesn't know how to handle that. Also, when possible,
-it uses the `sort' utility program, which doesn't understand tabs.
-Use \\[untabify] to convert tabs to spaces before sorting."
+Note that sort-columns uses the sort utility program and therefore
+cannot work on text containing TAB characters. Use M-x untabify
+to convert tabs to spaces before sorting."
(interactive "P\nr")
(save-excursion
(let (beg1 end1 col-beg1 col-end1 col-start col-end)
@@ -391,48 +338,7 @@ Use \\[untabify] to convert tabs to spaces before sorting."
(setq col-end (max col-beg1 col-end1))
(if (search-backward "\t" beg1 t)
(error "sort-columns does not work with tabs. Use M-x untabify."))
- (if (not (eq system-type 'vax-vms))
- ;; Use the sort utility if we can; it is 4 times as fast.
- (call-process-region beg1 end1 "sort" t t nil
- (if reverse "-rt\n" "-t\n")
- (concat "+0." col-start)
- (concat "-0." col-end))
- ;; On VMS, use Emacs's own facilities.
- (save-excursion
- (save-restriction
- (narrow-to-region beg1 end1)
- (goto-char beg1)
- (sort-subr reverse 'forward-line 'end-of-line
- (function (lambda () (move-to-column col-start) nil))
- (function (lambda () (move-to-column col-end) nil)))))))))
-
-(defun reverse-region (beg end)
- "Reverse the order of lines in a region.
-From a program takes two point or marker arguments, BEG and END."
- (interactive "r")
- (if (> beg end)
- (let (mid) (setq mid end end beg beg mid)))
- (save-excursion
- ;; put beg at the start of a line and end and the end of one --
- ;; the largest possible region which fits this criteria
- (goto-char beg)
- (or (bolp) (forward-line 1))
- (setq beg (point))
- (goto-char end)
- ;; the test for bolp is for those times when end is on an empty line;
- ;; it is probably not the case that the line should be included in the
- ;; reversal; it isn't difficult to add it afterward.
- (or (and (eolp) (not (bolp))) (progn (forward-line -1) (end-of-line)))
- (setq end (point-marker))
- ;; the real work. this thing cranks through memory on large regions.
- (let (ll (do t))
- (while do
- (goto-char beg)
- (setq ll (cons (buffer-substring (point) (progn (end-of-line) (point)))
- ll))
- (setq do (/= (point) end))
- (delete-region beg (if do (1+ (point)) (point))))
- (while (cdr ll)
- (insert (car ll) "\n")
- (setq ll (cdr ll)))
- (insert (car ll)))))
+ (call-process-region beg1 end1 "sort" t t nil
+ (if reverse "-rt\n" "-t\n")
+ (concat "+0." col-start)
+ (concat "-0." col-end)))))
diff --git a/lisp/sort.elc b/lisp/sort.elc
new file mode 100644
index 00000000000..3d6931a789d
--- /dev/null
+++ b/lisp/sort.elc
Binary files differ
diff --git a/lisp/textmodes/spell.el b/lisp/spell.el
index d7cd286141b..d7cd286141b 100644
--- a/lisp/textmodes/spell.el
+++ b/lisp/spell.el
diff --git a/lisp/spell.elc b/lisp/spell.elc
new file mode 100644
index 00000000000..62b08e9e2db
--- /dev/null
+++ b/lisp/spell.elc
Binary files differ
diff --git a/lisp/play/spook.el b/lisp/spook.el
index 84fffceeaa1..ed4e16a95ed 100644
--- a/lisp/play/spook.el
+++ b/lisp/spook.el
@@ -1,5 +1,5 @@
;; Spook phrase utility
-;; Copyright (C) 1988 Free Software Foundation, Inc.
+;; Copyright (C) 1988 Free Software Foundation
;; This file is part of GNU Emacs.
diff --git a/lisp/startup.el b/lisp/startup.el
new file mode 100644
index 00000000000..ae709d2f000
--- /dev/null
+++ b/lisp/startup.el
@@ -0,0 +1,238 @@
+;; Process Emacs shell arguments
+;; Copyright (C) 1985, 1986 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+; These are processed only at the beginning of the argument list.
+; -batch execute noninteractively (messages go to stdout,
+; variable noninteractive set to t)
+; This option must be the first in the arglist.
+; Processed by `main' in emacs.c -- never seen by lisp
+; -t file Specify to use file rather than stdin/stdout
+; as the terminal.
+; This option must be the first in the arglist.
+; Processed by `main' in emacs.c -- never seen by lisp
+; -nw Inhibit the use of any window-system-specific display
+; code; use the current virtual terminal.
+; This option must be the first in the arglist.
+; Processed by `main' in emacs.c -- never seen by lisp
+; -q load no init file
+; -no-init-file same
+; -u user load user's init file
+; -user user same
+
+; These are processed in the order encountered.
+; -f function execute function
+; -funcall function same
+; -l file load file
+; -load file same
+; -i file insert file into buffer
+; -insert file same
+; file visit file
+; -kill kill (exit) emacs
+
+(setq top-level '(normal-top-level))
+
+(defvar command-line-processed nil "t once command line has been processed")
+
+(defconst inhibit-startup-message nil
+ "*Non-nil inhibits the initial startup messages.
+This is for use in your personal init file, once you are familiar
+with the contents of the startup message.")
+
+(defconst inhibit-default-init nil
+ "*Non-nil inhibits loading the `default' library.")
+
+(defconst command-switch-alist nil
+ "Alist of command-line switches.
+Elements look like (SWITCH-STRING . HANDLER-FUNCTION).
+HANDLER-FUNCTION receives switch name as sole arg;
+remaining command-line args are in the variable `command-line-args-left'.")
+
+(defvar term-setup-hook nil
+ "Function to be called after loading terminal-specific lisp code.
+It is called with no arguments. You can use this to override the
+definitions made by the terminal-specific file.")
+
+(defvar window-setup-hook nil)
+
+(defconst initial-major-mode 'lisp-interaction-mode
+ "Major mode command symbol to use for the initial *scratch* buffer.")
+
+(defun normal-top-level ()
+ (if command-line-processed
+ (message "Back to top level.")
+ (setq command-line-processed t)
+ ;; In presence of symlinks, switch to cleaner form of default directory.
+ (if (and (not (eq system-type 'vax-vms))
+ (getenv "PWD")
+ (equal (nthcdr 10 (file-attributes default-directory))
+ (nthcdr 10 (file-attributes (getenv "PWD")))))
+ (setq default-directory (file-name-as-directory (getenv "PWD"))))
+ (unwind-protect
+ (command-line)
+ (and term-setup-hook
+ (funcall term-setup-hook))
+ (and window-setup-hook
+ (funcall window-setup-hook)))))
+
+(defun command-line ()
+ (let ((args (cdr command-line-args))
+ (init (if noninteractive nil (user-login-name)))
+ (done nil))
+ ;; If user has not done su, use current $HOME to find .emacs.
+ (and init (string= init (user-real-login-name))
+ (setq init ""))
+ (while (and (not done) args)
+ (let ((argi (car args)))
+ (if (or (string-equal argi "-q")
+ (string-equal argi "-no-init-file"))
+ (setq init nil
+ args (cdr args))
+ (if (or (string-equal argi "-u")
+ (string-equal argi "-user"))
+ (setq args (cdr args)
+ init (car args)
+ args (cdr args))
+ (setq done t)))))
+ ;; Load user's init file, or load default one.
+ (condition-case error
+ (if init
+ (progn (load (if (eq system-type 'vax-vms)
+ "sys$login:.emacs"
+ (concat "~" init "/.emacs"))
+ t t t)
+ (or inhibit-default-init
+ (let ((inhibit-startup-message nil))
+ ;; Users are supposed to be told their rights.
+ ;; (Plus how to get help and how to undo.)
+ ;; Don't you dare turn this off for anyone
+ ;; except yourself.
+ (load "default" t t)))))
+ (error (message "Error in init file")))
+ (if (get-buffer "*scratch*")
+ (save-excursion
+ (set-buffer "*scratch*")
+ (funcall initial-major-mode)))
+ ;; Load library for our terminal type.
+ ;; User init file can set term-file-prefix to nil to prevent this.
+ (and term-file-prefix (not noninteractive)
+ (if window-system
+ (load (concat term-file-prefix
+ (symbol-name window-system)
+ "-win")
+ t t)
+ (let ((term (getenv "TERM"))
+ hyphend)
+ (while (and term
+ (not (load (concat term-file-prefix 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))))))
+ (command-line-1 args)
+ (if noninteractive (kill-emacs t))))
+
+(defun command-line-1 (command-line-args-left)
+ (if (null command-line-args-left)
+ (cond ((and (not inhibit-startup-message) (not noninteractive)
+ ;; Don't clobber a non-scratch buffer if init file
+ ;; has selected it.
+ (string= (buffer-name) "*scratch*")
+ (not (input-pending-p)))
+ ;; If there are no switches to procss, we might as well
+ ;; run this hook now, and there may be some need to do it
+ ;; before doing any output.
+ (and term-setup-hook
+ (funcall term-setup-hook))
+ ;; Don't let the hook be run twice.
+ (setq term-setup-hook nil)
+ (and window-setup-hook
+ (funcall window-setup-hook))
+ (setq window-setup-hook nil)
+ (unwind-protect
+ (progn
+ (insert (emacs-version)
+ "
+Copyright (C) 1990 Free Software Foundation, Inc.\n")
+ ;; If keys have their default meanings,
+ ;; use precomputed string to save lots of time.
+ (if (and (eq (key-binding "\C-h") 'help-command)
+ (eq (key-binding "\C-xu") 'advertised-undo)
+ (eq (key-binding "\C-h\C-c") 'describe-copying)
+ (eq (key-binding "\C-h\C-d") 'describe-distribution)
+ (eq (key-binding "\C-h\C-w") 'describe-no-warranty)
+ (eq (key-binding "\C-ht") 'help-with-tutorial))
+ (insert
+ "Type C-h for help; C-x u to undo changes. (`C-' means use CTRL key.)
+
+GNU Emacs comes with ABSOLUTELY NO WARRANTY; type C-h C-w for full details.
+You may give out copies of Emacs; type C-h C-c to see the conditions.
+Type C-h C-d for information on getting the latest version.
+Type C-h t for a tutorial on using Emacs.")
+ (insert (substitute-command-keys
+ "Type \\[help-command] for help; \\[advertised-undo] to undo changes. (`C-' means use CTRL key.)
+
+GNU Emacs comes with ABSOLUTELY NO WARRANTY; type \\[describe-no-warranty] for full details.
+You may give out copies of Emacs; type \\[describe-copying] to see the conditions.
+Type \\[describe-distribution] for information on getting the latest version.
+Type \\[help-with-tutorial] for a tutorial on using Emacs.")))
+ (set-buffer-modified-p nil)
+ (sit-for 120))
+ (save-excursion
+ ;; In case the Emacs server has already selected
+ ;; another buffer, erase the one our message is in.
+ (set-buffer (get-buffer "*scratch*"))
+ (erase-buffer)
+ (set-buffer-modified-p nil)))))
+ (let ((dir default-directory)
+ (line 0))
+ (while command-line-args-left
+ (let ((argi (car command-line-args-left))
+ tem)
+ (setq command-line-args-left (cdr command-line-args-left))
+ (cond ((setq tem (assoc argi command-switch-alist))
+ (funcall (cdr tem) argi))
+ ((or (string-equal argi "-f") ;what the manual claims
+ (string-equal argi "-funcall")
+ (string-equal argi "-e")) ; what the source used to say
+ (setq tem (intern (car command-line-args-left)))
+ (setq command-line-args-left (cdr command-line-args-left))
+ (funcall tem))
+ ((or (string-equal argi "-l")
+ (string-equal argi "-load"))
+ (let ((file (car command-line-args-left)))
+ ;; Take file from default dir if it exists there;
+ ;; otherwise let `load' search for it.
+ (if (file-exists-p (expand-file-name file))
+ (setq file (expand-file-name file)))
+ (load file nil t))
+ (setq command-line-args-left (cdr command-line-args-left)))
+ ((or (string-equal argi "-i")
+ (string-equal argi "-insert"))
+ (insert-file-contents (car command-line-args-left))
+ (setq command-line-args-left (cdr command-line-args-left)))
+ ((string-equal argi "-kill")
+ (kill-emacs t))
+ ((string-match "^\\+[0-9]+\\'" argi)
+ (setq line (string-to-int argi)))
+ (t
+ (find-file (expand-file-name argi dir))
+ (or (zerop line)
+ (goto-line line))
+ (setq line 0))))))))
diff --git a/lisp/startup.elc b/lisp/startup.elc
new file mode 100644
index 00000000000..37f1871b2a9
--- /dev/null
+++ b/lisp/startup.elc
Binary files differ
diff --git a/lisp/play/studly.el b/lisp/studly.el
index 5661b04a3cb..5661b04a3cb 100644
--- a/lisp/play/studly.el
+++ b/lisp/studly.el
diff --git a/lisp/studly.elc b/lisp/studly.elc
new file mode 100644
index 00000000000..309b31a8253
--- /dev/null
+++ b/lisp/studly.elc
Binary files differ
diff --git a/lisp/subr.el b/lisp/subr.el
index ffb4cb58184..cd5dc88dd28 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -1,5 +1,5 @@
;; Basic lisp subroutines for Emacs
-;; Copyright (C) 1985, 1986 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1986, 1990 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
@@ -18,28 +18,15 @@
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-(defun one-window-p (&optional arg)
+(defun one-window-p (&optional nomini)
"Returns non-nil if there is only one window.
Optional arg NOMINI non-nil means don't count the minibuffer
even if it is active."
- (eq (selected-window)
- (next-window (selected-window) (if arg 'arg))))
-
-(defun walk-windows (proc &optional minibuf all-screens)
- "Cycle through all visible windows, calling PROC for each one.
-PROC is called with a window as argument.
-Optional second arg MINIBUF t means count the minibuffer window
-even if not active. If MINIBUF is neither t nor nil it means
-not to count the minibuffer even if it is active.
-Optional third arg ALL-SCREENS t means include all windows in all screens;
-otherwise cycle within the selected screen."
- (let* ((walk-windows-start (selected-window))
- (walk-windows-current walk-windows-start))
- (while (progn
- (setq walk-windows-current
- (next-window walk-windows-current minibuf all-screens))
- (funcall proc walk-windows-current)
- (not (eq walk-windows-current walk-windows-start))))))
+ (let ((base-window (selected-window)))
+ (if (and nomini (eq base-window (minibuffer-window)))
+ (setq base-window (next-window base-window)))
+ (eq base-window
+ (next-window base-window (if nomini 'arg)))))
(defun read-quoted-char (&optional prompt)
"Like `read-char', except that if the first character read is an octal
@@ -77,22 +64,22 @@ Optional argument PROMPT specifies a string to use to prompt the user."
;from mentioning keys that run this command.
(put 'undefined 'suppress-keymap t)
-(defun suppress-keymap (map &optional nodigits)
- "Make MAP override all normally self-inserting keys to be undefined.
-Normally, as an exception, digits and minus-sign are set to make prefix args,
-but optional second arg NODIGITS non-nil treats them like other chars."
- (let ((i 0))
- (while (<= i 127)
- (if (eql (lookup-key global-map (char-to-string i)) 'self-insert-command)
- (define-key map (char-to-string i) 'undefined))
+(defun suppress-keymap (map &optional arg)
+ "Make MAP override all buffer-modifying commands to be undefined.
+Works by knowing which commands are normally buffer-modifying.
+Normally also makes digits set numeric arg,
+but optional second arg NODIGITS non-nil prevents this."
+ (let ((i ? ))
+ (while (< i 127)
+ (aset map i 'undefined)
(setq i (1+ i))))
- (or nodigits
+ (or arg
(let (loop)
- (define-key map "-" 'negative-argument)
+ (aset map ?- 'negative-argument)
;; Make plain numbers do numeric args.
(setq loop ?0)
(while (<= loop ?9)
- (define-key map (char-to-string loop) 'digit-argument)
+ (aset map loop 'digit-argument)
(setq loop (1+ loop))))))
;; now in fns.c
@@ -126,9 +113,7 @@ but optional second arg NODIGITS non-nil treats them like other chars."
(defun substitute-key-definition (olddef newdef keymap)
"Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF.
-In other words, OLDDEF is replaced with NEWDEF where ever it appears.
-Prefix keymaps reached from KEYMAP are not checked recursively;
-perhaps they ought to be."
+In other words, OLDDEF is replaced with NEWDEF where ever it appears."
(if (arrayp keymap)
(let ((len (length keymap))
(i 0))
@@ -160,11 +145,11 @@ perhaps they ought to be."
(fset 'send-string 'process-send-string)
(fset 'send-region 'process-send-region)
(fset 'show-buffer 'set-window-buffer)
-(fset 'buffer-flush-undo 'buffer-disable-undo)
; alternate names
(fset 'string= 'string-equal)
(fset 'string< 'string-lessp)
+(fset 'mod '%)
(fset 'move-marker 'set-marker)
(fset 'eql 'eq)
(fset 'not 'null)
@@ -208,25 +193,6 @@ If it is a list, the elements are called, in order, with no arguments."
(mapcar 'funcall value)
(funcall value)))))
(setq hooklist (cdr hooklist))))
-
-;; Tell C code how to call this function.
-(defconst run-hooks 'run-hooks
- "Variable by which C primitives find the function `run-hooks'.
-Don't change it.")
-
-(defun add-hook (hook function)
- "Add to the value of HOOK the function FUNCTION unless already present.
-HOOK should be a symbol, and FUNCTION may be any valid function.
-HOOK's value should be a list of functions, not a single function.
-If HOOK is void, it is first set to nil."
- (or (boundp hook) (set hook nil))
- (or (if (consp function)
- ;; Clever way to tell whether a given lambda-expression
- ;; is equal to anything in the hook.
- (let ((tail (assoc (cdr function) (symbol-value hook))))
- (equal function tail))
- (memq function (symbol-value hook)))
- (set hook (cons function hook))))
(defun momentary-string-display (string pos &optional exit-char message)
"Momentarily display STRING in the buffer at POS.
@@ -258,70 +224,18 @@ If MESSAGE is nil, instructions to type EXIT-CHAR are displayed there."
(delete-region pos insert-end)))
(setq buffer-file-name name)
(set-buffer-modified-p modified))))
-
-(defun start-process-shell-command (name buffer &rest args)
- "Start a program in a subprocess. Return the process object for it.
-Args are NAME BUFFER COMMAND &rest COMMAND-ARGS.
-NAME is name for process. It is modified if necessary to make it unique.
-BUFFER is the buffer or (buffer-name) to associate with the process.
- Process output goes at end of that buffer, unless you specify
- an output stream or filter function to handle the output.
- BUFFER may be also nil, meaning that this process is not associated
- with any buffer
-Third arg is command name, the name of a shell command.
-Remaining arguments are the arguments for the command.
-Wildcards and redirection are handle as usual in the shell."
- (if (eq system-type 'vax-vms)
- (apply 'start-process name buffer args)
- (start-process name buffer shell-file-name "-c"
- (concat "exec " (mapconcat 'identity args " ")))))
-
-(defun eval-after-load (file form)
- "Arrange that, if FILE is ever loaded, FORM will be run at that time.
-This makes or adds to an entry on `after-load-alist'.
-FILE should be the name of a library, with no directory name."
- (or (assoc file after-load-alist)
- (setq after-load-alist (cons (list file) after-load-alist)))
- (nconc (assoc file after-load-alist) (list form))
- form)
-
-(defun eval-next-after-load (file)
- "Read the following input sexp, and run it whenever FILE is loaded.
-This makes or adds to an entry on `after-load-alist'.
-FILE should be the name of a library, with no directory name."
- (eval-after-load file (read)))
-
-(defmacro defun-inline (name args &rest body)
- "Create an \"inline defun\" (actually a macro).
-Use just like `defun'."
- (nconc (list 'defmacro name '(&rest args))
- (if (stringp (car body))
- (prog1 (list (car body))
- (setq body (or (cdr body) body))))
- (list (list 'cons (list 'quote
- (cons 'lambda (cons args body)))
- 'args))))
-
-(defun user-original-login-name ()
- "Return user's login name from original login.
-This tries to remain unaffected by `su', by looking in environment variables."
- (or (getenv "LOGNAME") (getenv "USER") (user-login-name)))
-(defun force-mode-line-update (&optional all)
- "Force the mode-line of the current buffer to be redisplayed.
-With optional non-nil ALL then force then force redisplay of all mode-lines."
- (if all (save-excursion (set-buffer (other-buffer))))
- (set-buffer-modified-p (buffer-modified-p)))
-
-(defun keyboard-translate (from to)
- "Translate character FROM to TO at a low level.
-This function creates a `keyboard-translate-table' if necessary
-and then modifies one entry in it."
- (or (boundp 'keyboard-translate-table)
- (let ((table (make-string 256))
- (i 0))
- (while (< i 256)
- (aset table i i)
- (setq i (1+ i)))
- (setq keyboard-translate-table table)))
- (aset keyboard-translate-table from to))
+(defun undo-start ()
+ "Move undo-pointer to front of undo records.
+The next call to undo-more will undo the most recently made change."
+ (if (eq buffer-undo-list t)
+ (error "No undo information in this buffer"))
+ (setq pending-undo-list buffer-undo-list))
+
+(defun undo-more (count)
+ "Undo back N undo-boundaries beyond what was already undone recently.
+Call undo-start to get ready to undo recent changes,
+then call undo-more one or more times to undo them."
+ (or pending-undo-list
+ (error "No further undo information"))
+ (setq pending-undo-list (primitive-undo count pending-undo-list)))
diff --git a/lisp/subr.elc b/lisp/subr.elc
new file mode 100644
index 00000000000..45c5fd62145
--- /dev/null
+++ b/lisp/subr.elc
Binary files differ
diff --git a/lisp/sun-curs.el b/lisp/sun-cursors.el
index f290e1b3a76..2a6ca08f2b3 100644
--- a/lisp/sun-curs.el
+++ b/lisp/sun-cursors.el
@@ -174,7 +174,7 @@ Otherwise, ICON should be a vector or the name of a vector of [x y 32-chars]"
(while (> bit 0)
(insert (sc::char-at-bit char bit))
(setq bit (lsh bit -1))))
- (if (eq 1 (% index 2)) (newline))
+ (if (eq 1 (mod index 2)) (newline))
(setq index (1+ index))))
(sc::goto-hotspot))
diff --git a/lisp/sun-fns.el b/lisp/sun-fns.el
index b2ca59203f6..2c12fbc12ba 100644
--- a/lisp/sun-fns.el
+++ b/lisp/sun-fns.el
@@ -1,5 +1,5 @@
;; Subroutines of Mouse handling for Sun windows
-;; Copyright (C) 1987 Free Software Foundation, Inc.
+;; Copyright (C) 1987, 1991, 1992 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
@@ -17,6 +17,15 @@
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;;; Upgrade Apr, 1992, Jeff Peck
+;;; modeline-menu
+;;; modeline resize
+;;; mouse-fill-paragraph(s)
+;;; mouse in Buffer-menu
+;;;
+;;; Fix Aug, 1989, Jeff Peck
+;;; minibuf-prompt-length
+;;;
;;; Submitted Mar. 1987, Jeff Peck
;;; Sun Microsystems Inc. <peck@sun.com>
;;; Conceived Nov. 1986, Stan Jefferson,
@@ -420,13 +429,88 @@ relative X divided by window width."
"Pop-up menu of commands."
(sun-menu-evaluate window x (1- y) 'minibuffer-menu))
+;;; Thanks to Joe Wells for this hack.
+;;; GNU Emacs should supply something better... Oh well.
+(defun minibuf-prompt-length ()
+ "Returns the length of the current minibuffer prompt."
+ (save-window-excursion
+ (select-window (minibuffer-window))
+ (save-excursion
+ (let ((screen-width (screen-width))
+ (point-min (point-min))
+ length)
+ (goto-char point-min)
+ (insert-char ?a screen-width)
+ (goto-char point-min)
+ (vertical-motion 1)
+ (setq length (- screen-width (point)))
+ (goto-char point-min)
+ (delete-char screen-width)
+ length))))
+
(defun mini-move-point (window x y)
- ;; -6 is good for most common cases
- (mouse-move-point window (- x 6) 0))
+ (mouse-move-point window (- x (minibuf-prompt-length)) 0))
(defun mini-set-mark-and-stuff (window x y)
- ;; -6 is good for most common cases
- (mouse-set-mark-and-stuff window (- x 6) 0))
+ (mouse-set-mark-and-stuff window (- x (minibuf-prompt-length)) 0))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; resize from modeline
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defvar *modeline-hit* nil "store original modline-hit data")
+
+(defun modeline-hit (w x y) (interactive)
+ (setq *modeline-hit* (cons w (caddr hit))))
+
+(defun mouse-drag-modeline (w x y) (interactive)
+ (if *modeline-hit*
+ (let ((delta (- (cdr *modeline-hit*) (caddr hit)))
+ (win (car *modeline-hit*)))
+ (setq *modeline-hit* nil)
+ (eval-in-window win (shrink-window delta)))))
+
+;; Modeline drag to resize:
+;; Watch out for interference if you use "up" for something else
+;; For example: '(text up left) is used...
+(global-set-mouse '(modeline middle) 'modeline-hit)
+(global-set-mouse '(modeline up middle) 'mouse-drag-modeline)
+(global-set-mouse '(text up middle) 'mouse-drag-modeline)
+(global-set-mouse '(scrollbar up middle) 'mouse-drag-modeline)
+(global-set-mouse '(minibuffer up middle) 'mouse-drag-modeline)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; modeline-menu functions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+;; parse thru a modeline-menu, finding item under nth character
+(defun nth-menu-elt (n menu)
+ (let ((n (- n (length (caar menu)))))
+ (if (< n 0)
+ (cdar menu)
+ (if (consp (cdr menu))
+ (nth-menu-elt n (cdr menu))
+ (cdar menu)))))
+
+(defun modeline-menu-command (x menu)
+ "*Evaluate the command associated with the character N of the MENU.
+Each element of MENU is of the form (STRING . ACTION). The STRING is
+displayed in the modeline and ACTION to invoked when that string is moused.
+If (commandp ACTION) is true,the ACTION is called interactively;
+otherwise, ACTION is evaled."
+ (let ((command (nth-menu-elt x menu)))
+ (if (commandp command)
+ (call-interactively command)
+ (eval command))))
+
+(defun modeline-menu-string (menu)
+ "*Extract the strings in (cdr MENU) and concatenate them into a string.
+The string in (car MENU) is not included in the returned string.
+ For best results, (length (caar menu)) should equal
+ the prefix in the actual modeline format string."
+ (apply 'concat (mapcar 'car (cdr menu))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -434,19 +518,18 @@ relative X divided by window width."
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun Buffer-at-mouse (w x y)
- "Calls Buffer-menu-buffer from mouse click."
(save-window-excursion
(mouse-move-point w x y)
- (beginning-of-line)
(Buffer-menu-buffer t)))
(defun mouse-buffer-bury (w x y)
"Bury the indicated buffer."
(bury-buffer (Buffer-at-mouse w x y))
+ (list-buffers)
)
(defun mouse-buffer-select (w x y)
- "Put the indicated buffer in selected window."
+ "Select the indicated buffer in other-window."
(switch-to-buffer (Buffer-at-mouse w x y))
(list-buffers)
)
@@ -458,6 +541,13 @@ relative X divided by window width."
(Buffer-menu-delete)
))
+(defun mouse-buffer-mark (w x y)
+ "mark indicated buffer for delete"
+ (save-window-excursion
+ (mouse-move-point w x y)
+ (Buffer-menu-mark)
+ ))
+
(defun mouse-buffer-execute (w x y)
"execute buffer-menu selections"
(save-window-excursion
@@ -465,6 +555,31 @@ relative X divided by window width."
(Buffer-menu-execute)
))
+(defun buffer-modeline-menu-cmd (w x y)
+ (select-window w)
+ ;; goto a line with a buffer, skip first two lines
+ (let ((line-no (count-lines 1 (point))))
+ (if (< line-no 2) (forward-line (- 2 line-no))))
+ (modeline-menu-command x buffer-modeline-menu))
+
+(defvar buffer-modeline-menu '(("--%%-" . (forward-line -1))
+ (" [ " . (forward-line -1))
+ ("Mark " . Buffer-menu-mark)
+ ("Del " . Buffer-menu-delete)
+ ("Save " . Buffer-menu-save)
+ ("Undo " . Buffer-menu-unmark)
+ ("Prev " . (forward-line -1))
+ ("Next " . (forward-line 1))
+ ("Edit " . Buffer-menu-select)
+ ("eXec " . Buffer-menu-execute)
+ ("] " . (forward-line 1))
+ )
+ "*Each element of this list is a character STRING
+\(that is displayed in the modeline\) consed to an ACTION to invoke
+when that string is moused. If (commandp ACTION) is true,
+the ACTION is called interactively; otherwise, ACTION is evaled."
+ )
+
(defun enable-mouse-in-buffer-list ()
"Call this to enable mouse selections in *Buffer List*
LEFT puts the indicated buffer in the selected window.
@@ -472,16 +587,71 @@ relative X divided by window width."
RIGHT marks the indicated buffer for deletion.
MIDDLE-RIGHT deletes the marked buffers.
To unmark a buffer marked for deletion, select it with LEFT."
- (save-window-excursion
- (list-buffers) ; Initialize *Buffer List*
- (set-buffer "*Buffer List*")
- (local-set-mouse '(text middle) 'mouse-buffer-bury)
- (local-set-mouse '(text left) 'mouse-buffer-select)
- (local-set-mouse '(text right) 'mouse-buffer-delete)
- (local-set-mouse '(text middle right) 'mouse-buffer-execute)
- )
+
+ (local-set-mouse '(text left) 'mouse-buffer-select)
+ (local-set-mouse '(text middle) 'mouse-buffer-bury)
+ (local-set-mouse '(text right) 'mouse-buffer-delete)
+ (local-set-mouse '(text middle left) 'mouse-buffer-mark)
+ (local-set-mouse '(text middle right) 'mouse-buffer-execute)
+ (setq mode-line-buffer-identification
+ (list (modeline-menu-string buffer-modeline-menu) "%b"))
+ (local-set-mouse '(modeline left) 'buffer-modeline-menu-cmd)
+ (local-set-mouse '(modeline left double) 'buffer-modeline-menu-cmd)
)
+(defvar buffer-menu-mode-hook nil "run-hooks when entering Buffer Menu mode.")
+
+(if (memq 'enable-mouse-in-buffer-list buffer-menu-mode-hook)
+ nil
+ (setq buffer-menu-mode-hook
+ (cons 'enable-mouse-in-buffer-list buffer-menu-mode-hook)))
+
+;; make sure a new buffer is created using buffer-menu-mode-hook
+(if (get-buffer "*Buffer List*") (kill-buffer "*Buffer List*"))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; mouse fill (useful to re-format mail messages with long lines
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun mouse-fill-paragraph (w x y)
+ "Utility function to fill paragraphs from mouse click,
+useful in Mail to read things that have long lines."
+ (eval-in-window w
+ (mouse-move-point w x y)
+ (let (fill-prefix)
+ (fill-paragraph nil))))
+
+
+(defun fill-some-paragraphs ()
+ "*Fill the succeeding paragraphs that have the same prefix."
+ (interactive)
+ (let (fill-prefix fpr eop beg end)
+ (set-fill-prefix)
+ ;; if no fill-prefix, then match lines beginning with an alpha char.
+ (setq fpr (or fill-prefix "[a-zA-Z]"))
+ (setq fpr (if (let ((sm (string-match "[ \t]*" fpr)))
+ (and sm (= (length fpr) (match-end 0))))
+ ;; if fill-prefix is just TAB-SPACE, then also accept
+ ;; empty lines in the region.
+ (concat "\\(" fpr "\\)\\|\\(^$\\)")
+ (regexp-quote fpr)
+ ))
+ ;; now that we have the prefix, find a region of lines that match:
+ (save-excursion
+ (beginning-of-line 1)
+ (setq beg (point))
+ ;; find lines with similar prefixes:
+ (while (progn (forward-line 1)
+ (setq end (point))
+ (and (not (eobp)) (looking-at fpr))))
+ (fill-region beg end nil))))
+
+;; fill all succeeding paragraphs with this fill prefix
+(defun mouse-fill-paragraphs (w x y)
+ "Utility function to fill paragraphs from mouse click,
+useful in Mail to read things that have long lines."
+ (eval-in-window w
+ (mouse-move-point w x y)
+ (fill-some-paragraphs)))
;;;*******************************************************************
;;;
@@ -586,18 +756,20 @@ To unmark a buffer marked for deletion, select it with LEFT."
;;;
;;; Note: meta of any single button selects window.
-(global-set-mouse '(modeline left) 'mouse-scroll-up)
-(global-set-mouse '(modeline meta left) 'mouse-select-window)
+(global-set-mouse '(modeline double left) 'mouse-scroll-up)
+(global-set-mouse '(modeline shift left) 'mouse-scroll-up)
+(global-set-mouse '(modeline double middle) 'mouse-scroll-proportional)
+(global-set-mouse '(modeline shift middle) 'mouse-scroll-proportional)
+(global-set-mouse '(modeline double right) 'mouse-scroll-down)
+(global-set-mouse '(modeline shift right) 'mouse-scroll-down)
-(global-set-mouse '(modeline middle) 'mouse-scroll-proportional)
+(global-set-mouse '(modeline meta left) 'mouse-select-window)
(global-set-mouse '(modeline meta middle) 'mouse-select-window)
-(global-set-mouse '(modeline control middle) 'mouse-split-horizontally)
-
-(global-set-mouse '(modeline right) 'mouse-scroll-down)
-(global-set-mouse '(modeline meta right) 'mouse-select-window)
+(global-set-mouse '(modeline meta right) 'mouse-select-window)
;;; control-left selects this window, control-right deletes it.
(global-set-mouse '(modeline control left) 'mouse-delete-other-windows)
+(global-set-mouse '(modeline control middle) 'mouse-split-horizontally)
(global-set-mouse '(modeline control right) 'mouse-delete-window)
;; in case of confusion, just select it:
@@ -610,6 +782,7 @@ To unmark a buffer marked for deletion, select it with LEFT."
(global-set-mouse '(modeline shift control meta right) 'mouse-help-region)
(global-set-mouse '(modeline double control meta right) 'mouse-help-region)
+
;;;
;;; Minibuffer Mousemap
;;; Demonstrating some variety:
@@ -618,8 +791,8 @@ To unmark a buffer marked for deletion, select it with LEFT."
(global-set-mouse '(minibuffer middle) 'mini-set-mark-and-stuff)
-(global-set-mouse '(minibuffer shift middle) '(select-previous-complex-command))
-(global-set-mouse '(minibuffer double middle) '(select-previous-complex-command))
+(global-set-mouse '(minibuffer shift middle) '(prev-complex-command))
+(global-set-mouse '(minibuffer double middle) '(prev-complex-command))
(global-set-mouse '(minibuffer control middle) '(next-complex-command 1))
(global-set-mouse '(minibuffer meta middle) '(previous-complex-command 1))
diff --git a/lisp/sun-fns.elc b/lisp/sun-fns.elc
new file mode 100644
index 00000000000..a3269916f07
--- /dev/null
+++ b/lisp/sun-fns.elc
Binary files differ
diff --git a/lisp/sun-keys.el b/lisp/sun-keys.el
index 59fba2a5791..87da264c1b7 100644
--- a/lisp/sun-keys.el
+++ b/lisp/sun-keys.el
@@ -8,7 +8,7 @@
;;;
;;; Copyright (C) 1986 Free Software Foundation, Inc.
;;;
-;;; This file is part of GNU Emacs.
+;; 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
@@ -23,6 +23,7 @@
;; 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
;;;
;;; Batten@uk.ac.bham.multics (Ian G. Batten)
;;;
diff --git a/lisp/term/sun-mouse.el b/lisp/sun-mouse.el
index bed2b416c1f..a2f4b938e28 100644
--- a/lisp/term/sun-mouse.el
+++ b/lisp/sun-mouse.el
@@ -1,5 +1,5 @@
;; Mouse handling for Sun windows
-;; Copyright (C) 1987 Free Software Foundation, Inc.
+;; Copyright (C) 1987, 1991 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
@@ -19,6 +19,9 @@
;;; Jeff Peck, Sun Microsystems, Jan 1987.
;;; Original idea by Stan Jefferson
+;;
+;; Mar 90 get/set selections
+;; Mar 91 add mouse-help, print bindings dynamically
(provide 'sun-mouse)
@@ -167,7 +170,7 @@ Just like the Common Lisp function of the same name."
(,@ forms))
(set-buffer StartBuffer)))))
-(put 'eval-in-buffer 'lisp-indent-function 1)
+(put 'eval-in-buffer 'lisp-indent-hook 1)
;;; this is used extensively by sun-fns.el
;;;
@@ -178,8 +181,11 @@ Just like the Common Lisp function of the same name."
(progn
(select-window (, window))
(,@ forms))
- (select-window OriginallySelectedWindow)))))
-(put 'eval-in-window 'lisp-indent-function 1)
+ ;; don't go back to window if it has been destroyed...
+ ;; window-point seems to work as an indication of existence
+ (if (window-point OriginallySelectedWindow)
+ (select-window OriginallySelectedWindow))))))
+(put 'eval-in-window 'lisp-indent-hook 1)
;;;
;;; handy utility, generalizes window_loop
@@ -198,7 +204,7 @@ This is a macro, and does not evaluate its arguments."
(select-window
(next-window nil (, yesmini)))))))
(select-window OriginallySelectedWindow)))))
-(put 'eval-in-window 'lisp-indent-function 0)
+(put 'eval-in-window 'lisp-indent-hook 0)
(defun move-to-loc (x y)
"Move cursor to window location X, Y.
@@ -224,6 +230,7 @@ Handles wrapped and horizontally scrolled lines correctly."
))
+(setq *mouse-help* nil) ; flag to display, rather than execute
(defun sun-mouse-handler (&optional hit)
"Evaluates the function or list associated with a mouse hit.
Expecting to read a hit, which is a list: (button x y delta).
@@ -249,10 +256,15 @@ Returns nil."
(mouse-code-to-mouse-list mouse-code)))))
((symbolp form)
(setq this-command form)
- (funcall form *mouse-window* *mouse-x* *mouse-y*))
+ (if *mouse-help*
+ (progn (prin1 (list form *mouse-window* *mouse-x* *mouse-y*))
+ (exit-recursive-edit))
+ (funcall form *mouse-window* *mouse-x* *mouse-y*)))
((listp form)
(setq this-command (car form))
- (eval form))
+ (if *mouse-help*
+ (progn (prin1 form) (exit-recursive-edit))
+ (eval form)))
(t
(error "Mouse action must be symbol or list, but was: %s"
form))))))
@@ -263,6 +275,11 @@ Returns nil."
;; (message (prin1-to-string this-command)) ; to see what your buttons did
nil)
+(defun mouse-help ()
+ (interactive)
+ (let ((*mouse-help* t))
+ (recursive-edit)))
+
(defun sm::combined-hits ()
"Read and return next mouse-hit, include possible double click"
(let ((hit1 (mouse-hit-read)))
@@ -634,20 +651,115 @@ CODE values: 13 = Tool-Position, 14 = Size-in-Pixels, 18 = Size-in-Chars."
;;; Function interface to selection/region
;;; primative functions are defined in sunfns.c
;;;
-(defun sun-yank-selection ()
- "Set mark and yank the contents of the current sunwindows selection
-into the current buffer at point."
+(defun sunview-yank-stuff ()
+ "Set mark and yank the contents of the current TTYSW `STUFF' selection
+into the current buffer at point. The STUFF selection contains the currently
+or previously highlighted text from a TTYSW."
(interactive "*")
(set-mark-command nil)
(insert-string (sun-get-selection)))
+;;;
+(defun display-host ()
+ "Extract <host> from DISPLAY environment variable, or return nil if not specified."
+ (let ((display (getenv "DISPLAY")))
+ (if display
+ (let ((colon_at (string-match ":" display)))
+ (if colon_at
+ (if (not (zerop colon_at))
+ (substring display 0 colon_at)
+ ))))))
+
+;;; get_selection has been extended to work in X
+;;; we extend to work on remote X display...
+(defun sunview-yank-clipboard ()
+ "Set mark and yank the contents of the SunView Clipboard into the
+current buffer at point."
+ (interactive "*")
+ (set-mark-command nil)
+ (let ((host (display-host)))
+ (if host
+ (call-process "rsh" nil t t (display-host) "get_selection" "3")
+ (call-process "get_selection" nil t t "3")))
+ )
+
+(defun sunview-yank-current-selection ()
+ "Set mark and yank the contents of the current SunView selection
+into current buffer at point. The current selection is the currently
+highlighted text in either a textsw or a ttysw."
+ (interactive "*")
+ (set-mark-command nil)
+ (let ((host (display-host)))
+ (if host
+ (call-process "rsh" nil t t (display-host) "get_selection")
+ (call-process "get_selection" nil t t))))
+
+(defun sunview-yank-any-selection (arg)
+ "Yank one of the sunview selections:
+with no arg, the current selection; with minus-only prefix, the clipboard;
+with any other arg, the ttysw STUFF."
+ (interactive "*P")
+ (cond ((null arg) (sunview-yank-current-selection))
+ ((eq arg '-) (sunview-yank-clipboard))
+ (t (sunview-yank-stuff))))
+
+;;; define the selection file used by this emacs
+;;; if not local machine, then automounter must find /net/<host>/tmp
+(defvar owselectionfilex nil "Cache path to ttysw selection file (a kludge!).")
+;;; determine value at runtime, not when this file loaded into temacs
+(defun owselectionfile ()
+ (or owselectionfilex
+ (let* ((host (display-host))
+ (filex
+ (if host
+ (concat "/net/" host "/tmp/ttyselection")
+ "/tmp/ttyselection")))
+ (if (file-exists-p filex)
+ (setq owselectionfilex filex)
+ (progn
+ (message "no TTYSW selection file")
+ nil)
+ ))))
+
+(defun xv-yank-selection ()
+ "Set mark and yank the contents of the current Xview selection
+into the current buffer at point. The STUFF selection contains the currently
+or previously highlighted text from a TTYSW."
+ (interactive "*")
+ (if (owselectionfile)
+ (progn
+ (insert-file (owselectionfile))
+ (exchange-point-and-mark)))
+ )
+
+(defun xv-select-region (beg end)
+ "Set the TTYSW selection to the region in the current buffer."
+ (interactive "r")
+ (if (owselectionfile)
+ (write-region beg end (owselectionfile) nil 'noprint))
+ )
+
+(defun sun-yank-selection ()
+ "Set mark and yank the contents of the current TTYSW `STUFF' or Xview selection
+into the current buffer at point."
+ (interactive "*")
+ (if (getenv "DISPLAY")
+ (xv-yank-selection)
+ (sunview-yank-stuff))
+ )
+
(defun sun-select-region (beg end)
- "Set the sunwindows selection to the region in the current buffer."
+ "Set the TTYSW 'STUFF' or Xview selection to the region in the current buffer."
(interactive "r")
- (sun-set-selection (buffer-substring beg end)))
+ (if (getenv "DISPLAY")
+ (xv-select-region beg end)
+ (sun-set-selection (buffer-substring beg end)))
+ )
+
+
;;;
-;;; Support for emacstool
+;;; support for emacstool
;;; This closes the window instead of stopping emacs.
;;;
(defun suspend-emacstool (&optional stuffstring)
@@ -655,10 +767,12 @@ into the current buffer at point."
you don't want to suspend (there is no way to resume),
just close the window, and wait for reopening."
(interactive)
- (run-hooks 'suspend-hook)
+ (if (and (boundp 'suspend-hook) suspend-hook)
+ (funcall suspend-hook))
(if stuffstring (send-string-to-terminal stuffstring))
(send-string-to-terminal "\033[2t") ; To close EmacsTool window.
- (run-hooks 'suspend-resume-hook))
+ (if (and (boundp 'suspend-resume-hook) suspend-resume-hook)
+ (funcall suspend-resume-hook)))
;;;
;;; initialize mouse maps
;;;
diff --git a/lisp/sun-mouse.elc b/lisp/sun-mouse.elc
new file mode 100644
index 00000000000..b0c4971ff8a
--- /dev/null
+++ b/lisp/sun-mouse.elc
Binary files differ
diff --git a/lisp/term/sup-mouse.el b/lisp/sup-mouse.el
index d03b009136d..d03b009136d 100644
--- a/lisp/term/sup-mouse.el
+++ b/lisp/sup-mouse.el
diff --git a/lisp/sup-mouse.elc b/lisp/sup-mouse.elc
new file mode 100644
index 00000000000..a53ab91c65c
--- /dev/null
+++ b/lisp/sup-mouse.elc
Binary files differ
diff --git a/lisp/superyank.el b/lisp/superyank.el
deleted file mode 100644
index 4d16e6b5e5b..00000000000
--- a/lisp/superyank.el
+++ /dev/null
@@ -1,1212 +0,0 @@
-;; superyank.el -- Version 1.1
-;;
-;; Inserts the message being replied to with various user controlled
-;; citation styles.
-;;
-
-;; This file 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
-;; this file, 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.
-
-;; NAME: Barry A. Warsaw USMAIL: National Institute of Standards
-;; TELE: (301) 975-3460 and Technology (formerly NBS)
-;; UUCP: {...}!uunet!cme-durer!warsaw Rm. B-124, Bldg. 220
-;; ARPA: warsaw@cme.nist.gov Gaithersburg, MD 20899
-
-;; Modification history:
-;;
-;; modified: 14-Jun-1989 baw (better keymap set procedure, rewrite-headers)
-;; modified: 12-Jun-1989 baw (added defvar for sy-use-only-preference-p)
-;; modified: 6-Jun-1989 baw (better sy-rewrite-headers, no kill/yank)
-;; modified: 5-Jun-1989 baw (requires rnewspost.el)
-;; modified: 1-Jun-1989 baw (persistent attribution, sy-open-line)
-;; modified: 31-May-1989 baw (fixed some gnus problems, id'd another)
-;; modified: 22-May-1989 baw (documentation)
-;; modified: 8-May-1989 baw (auto filling of regions)
-;; modified: 1-May-1989 baw (documentation)
-;; modified: 27-Apr-1989 baw (new preference scheme)
-;; modified: 24-Apr-1989 baw (remove gnus headers, attrib scheme, cite lines)
-;; modified: 19-Apr-1989 baw (cite key, fill p, yank region, naming scheme)
-;; modified: 12-Apr-1989 baw (incorp other mail yank features seen on net)
-;; created : 16-Feb-1989 baw (mod vanilla fn indent-rigidly mail-yank-original)
-
-;; Though I wrote this package basically from scratch, as an elisp
-;; learning exercise, it was inspired by postings of similar packages to
-;; the gnu.emacs newsgroup over the past month or so.
-;;
-;; Here's a brief history of how this package developed:
-;;
-;; I as well as others on the net were pretty unhappy about the way emacs
-;; cited replies with the tab or 4 spaces. It looked ugly and made it hard
-;; to distinguish between original and cited lines. I hacked on the function
-;; yank-original to at least give the user the ability to define the citation
-;; character. I posted this simple hack, and others did as well. The main
-;; difference between mine and others was that a space was put after the
-;; citation string on on new citations, but not after previously cited lines:
-;;
-;; >> John wrote this originally
-;; > Jane replied to that
-;;
-;; Then Martin Neitzel posted some code that he developed, derived in part
-;; from code that Ashwin Ram posted previous to that. In Martin's
-;; posting, he introduced a new, and (IMHO) superior, citation style,
-;; eliminating nested citations. Yes, I wanted to join the Small-But-
-;; Growing-Help-Stamp-Out-Nested-Citation-Movement! You should too.
-;;
-;; But Martin's code simply asks the user for the citation string (here
-;; after called the `attribution' string), and I got to thinking, it wouldn't
-;; be that difficult to automate that part. So I started hacking this out.
-;; It proved to be not as simple as I first thought. But anyway here it
-;; is. See the wish list below for future plans (if I have time).
-;;
-;; Type "C-h f mail-yank-original" after this package is loaded to get a
-;; description of what it does and the variables that control it.
-;;
-;; ======================================================================
-;;
-;; Changes wish list
-;;
-;; 1) C-x C-s yanks a region from the RMAIL buffer instead of the
-;; whole buffer
-;;
-;; 2) reparse nested citations to try to recast as non-nested citations
-;; perhaps by checking the References: line
-;;
-;; ======================================================================
-;;
-;; require and provide features
-;;
-(require 'sendmail)
-(provide 'superyank)
-
-;;
-;; ======================================================================
-;;
-;; don't need rnewspost.el to rewrite the header. This only works
-;; with diffs to rnewspost.el that I posted with the original
-;; superyank code.
-;;
-(setq news-reply-header-hook nil)
-
-;; **********************************************************************
-;; start of user defined variables
-;; **********************************************************************
-;;
-;; this section defines variables that control the operation of
-;; super-mail-yank. Most of these are described in the comment section
-;; as well as the DOCSTRING.
-;;
-
-;;
-;; ----------------------------------------------------------------------
-;;
-;; this variable holds the default author's name for citations
-;;
-(defvar sy-default-attribution "Anon"
- "String that describes attribution to unknown person. This string
-should not contain the citation string.")
-
-;;
-;; ----------------------------------------------------------------------
-;;
-;; string used as an end delimiter for both nested and non-nested citations
-;;
-(defvar sy-citation-string ">"
- "String to use as an end-delimiter for citations. This string is
-used in both nested and non-nested citations. For best results, use a
-single character with no trailing space. Most commonly used string
-is: \">\.")
-
-;;
-;; ----------------------------------------------------------------------
-;;
-;; variable controlling citation type, nested or non-nested
-;;
-(defvar sy-nested-citation-p nil
- "Non-nil uses nested citations, nil uses non-nested citations.
-Nested citations are of the style:
-
-I wrote this
-> He wrote this
->> She replied to something he wrote
-
-Non-nested citations are of the style:
-
-I wrote this
-John> He wrote this
-Jane> She originally wrote this")
-
-
-;;
-;; ----------------------------------------------------------------------
-;;
-;; regular expression that matches existing citations
-;;
-(defvar sy-cite-regexp "[a-zA-Z0-9]*>"
- "Regular expression that describes how an already cited line in an
-article begins. The regexp is only used at the beginning of a line,
-so it doesn't need to begin with a '^'.")
-
-;;
-;; ----------------------------------------------------------------------
-;;
-;; regular expression that delimits names from titles in the field that
-;; looks like: (John X. Doe -- Computer Hacker Extraordinaire)
-;;
-(defvar sy-titlecue-regexp "\\s +-+\\s +"
-
- "Regular expression that delineates names from titles in the name
-field. Often, people will set up their name field to look like this:
-
-(John Xavier Doe -- Computer Hacker Extraordinaire)
-
-Set to nil to treat entire field as a name.")
-
-;;
-;; ----------------------------------------------------------------------
-;;
-;;
-(defvar sy-preferred-attribution 2
-
- "This is an integer indicating what the user's preference is in
-attribution style, based on the following key:
-
-0: email address name is preferred
-1: initials are preferred
-2: first name is preferred
-3: last name is preferred
-
-The value of this variable may also be greater than 3, which would
-allow you to prefer the 2nd through nth - 1 name. If the preferred
-attribution is nil or the empty string, then the secondary preferrence
-will be the first name. After that, the entire name alist is search
-until a non-empty, non-nil name is found. If no such name is found,
-then the user is either queried or the default attribution string is
-used depending on the value of sy-confirm-always-p.
-
-Examples:
-
-assume the from: line looks like this:
-
-from: doe@computer.some.where.com (John Xavier Doe)
-
-The following preferences would return these strings:
-
-0: \"doe\"
-1: \"JXD\"
-2: \"John\"
-3: \"Doe\"
-4: \"Xavier\"
-
-anything else would return \"John\".")
-
-;;
-;; ----------------------------------------------------------------------
-;;
-(defvar sy-confirm-always-p t
- "If t, always confirm attribution string before inserting into
-buffer.")
-
-
-;;
-;; ----------------------------------------------------------------------
-;;
-;; informative header hook
-;;
-(defvar sy-rewrite-header-hook 'sy-header-on-said
- "Hook for inserting informative header at the top of the yanked
-message. Set to nil for no header. Here is a list of predefined
-header styles; you can use these as a model to write you own:
-
-sy-header-on-said [default]: On 14-Jun-1989 GMT,
- John Xavier Doe said:
-
-sy-header-inarticle-writes: In article <123456789> John Xavier Doe writes:
-
-sy-header-regarding-writes: Regarding RE: superyank; John Xavier Doe adds:
-
-sy-header-verbose: On 14-Jun-1989 GMT, John Xavier Doe
- from the organization Great Company
- has this to say about article <123456789>
- in newsgroups misc.misc
- concerning RE: superyank
- referring to previous articles <987654321>
-
-You can use the following variables as information strings in your header:
-
-sy-reply-yank-date: the date field [ex: 14-Jun-1989 GMT]
-sy-reply-yank-from: the from field [ex: John Xavier Doe]
-sy-reply-yank-message-id: the message id [ex: <123456789>]
-sy-reply-yank-subject: the subject line [ex: RE: superyank]
-sy-reply-yank-newsgroup: the newsgroup name for GNUS [ex: misc.misc]
-sy-reply-yank-references: the article references [ex: <987654321>]
-sy-reply-yank-organization: the author's organization [ex: Great Company]
-
-If a field can't be found, because it doesn't exist or is not being
-shown, perhaps because of toggle-headers, the corresponding field
-variable will contain the string \"mumble mumble\".")
-
-;;
-;; ----------------------------------------------------------------------
-;;
-;; non-nil means downcase the author's name string
-;;
-(defvar sy-downcase-p nil
- "Non-nil means downcase the author's name string.")
-
-;;
-;; ----------------------------------------------------------------------
-;;
-;; controls removal of leading white spaces
-;;
-(defvar sy-left-justify-p nil
- "If non-nil, delete all leading white space before citing.")
-
-;;
-;; ----------------------------------------------------------------------
-;;
-;; controls auto filling of region
-;;
-(defvar sy-auto-fill-region-p nil
- "If non-nil, automatically fill each paragraph that is cited. If
-nil, do not auto fill each paragraph.")
-
-
-;;
-;; ----------------------------------------------------------------------
-;;
-;; controls use of preferred attribution only, or use of attribution search
-;; scheme if the preferred attrib can't be found.
-;;
-(defvar sy-use-only-preference-p nil
-
- "If non-nil, then only the preferred attribution string will be
-used. If the preferred attribution string can not be found, then the
-sy-default-attribution will be used. If nil, and the preferred
-attribution string is not found, then some secondary scheme will be
-employed to find a suitable attribution string.")
-
-;; **********************************************************************
-;; end of user defined variables
-;; **********************************************************************
-
-;;
-;; ----------------------------------------------------------------------
-;;
-;; The new citation style means we can clean out other headers in addition
-;; to those previously cleaned out. Anyway, we create our own headers.
-;; Also, we want to clean out any headers that gnus puts in. Add to this
-;; for other mail or news readers you may be using.
-;;
-(setq mail-yank-ignored-headers "^via:\\|^origin:\\|^status:\\|^re\\(mail\\|ceiv\\)ed\\|^[a-z-]*message-id:\\|^\\(summary-\\)?line[s]?:\\|^cc:\\|^subject:\\|^\\(\\(in-\\)?reply-\\)?to:\\|^\\(\\(return\\|reply\\)-\\)?path:\\|^\\(posted-\\)?date:\\|^\\(mail-\\)?from:\\|^newsgroup[s]?:\\|^organization:\\|^keywords:\\|^distribution:\\|^references:")
-
-;;
-;; ----------------------------------------------------------------------
-;;
-;; global variables, not user accessable
-;;
-(setq sy-persist-attribution (concat sy-default-attribution "> "))
-(setq sy-reply-yank-date "")
-(setq sy-reply-yank-from "")
-(setq sy-reply-yank-message-id "")
-(setq sy-reply-yank-subject "")
-(setq sy-reply-yank-newsgroups "")
-(setq sy-reply-yank-references "")
-(setq sy-reply-yank-organization "")
-
-;;
-;; ======================================================================
-;;
-;; This section contains primitive functions used in the schemes. They
-;; extract name fields from various parts of the "from:" field based on
-;; the control variables described above.
-;;
-;; Some will use recursion to pick out the correct namefield in the namestring
-;; or the list of initials. These functions all scan a string that contains
-;; the name, ie: "John Xavier Doe". There is no limit on the number of names
-;; in the string. Also note that all white spaces are basically ignored and
-;; are stripped from the returned strings, and titles are ignored if
-;; sy-titlecue-regexp is set to non-nil.
-;;
-;; Others will use methods to try to extract the name from the email
-;; address of the originator. The types of addresses readable are
-;; described above.
-
-;;
-;; ----------------------------------------------------------------------
-;;
-;; try to extract the name from an email address of the form
-;; name%[stuff]
-;;
-;; Unlike the get-name functions above, these functions operate on the
-;; buffer instead of a supplied name-string.
-;;
-(defun sy-%-style-address ()
- (beginning-of-line)
- (buffer-substring
- (progn (re-search-forward "%" (point-max) t)
- (if (not (bolp)) (forward-char -1))
- (point))
- (progn (re-search-backward "^\\|[^a-zA-Z0-9]")
- (point))))
-
-;;
-;; ----------------------------------------------------------------------
-;;
-;; try to extract names from addresses with the form:
-;; [stuff]name@[stuff]
-;;
-(defun sy-@-style-address ()
- (beginning-of-line)
- (buffer-substring
- (progn (re-search-forward "@" (point-max) t)
- (if (not (bolp)) (forward-char -1))
- (point))
- (progn (re-search-backward "^\\|[^a-zA-Z0-0]")
- (if (not (bolp)) (forward-char 1))
- (point))))
-
-;;
-;; ----------------------------------------------------------------------
-;;
-;; try to extract the name from addresses with the form:
-;; [stuff]![stuff]...!name[stuff]
-;;
-(defun sy-!-style-address ()
- (beginning-of-line)
- (buffer-substring
- (progn (while (re-search-forward "!" (point-max) t))
- (point))
- (progn (re-search-forward "[^a-zA-Z0-9]\\|$")
- (if (not (eolp)) (forward-char -1))
- (point))))
-
-;;
-;; ----------------------------------------------------------------------
-;;
-;; using the different email name schemes, try each one until you get a
-;; non-nil entry
-;;
-(defun sy-get-emailname ()
- (let ((en1 (sy-%-style-address))
- (en2 (sy-@-style-address))
- (en3 (sy-!-style-address)))
- (cond
- ((not (string-equal en1 "")) en1)
- ((not (string-equal en2 "")) en2)
- ((not (string-equal en3 "")) en3)
- (t ""))))
-
-;;
-;; ----------------------------------------------------------------------
-;;
-;; returns the "car" of the namestring, really the first namefield
-;;
-;; (sy-string-car "John Xavier Doe")
-;; => "John"
-;;
-(defun sy-string-car (namestring)
- (substring namestring
- (progn (string-match "\\s *" namestring) (match-end 0))
- (progn (string-match "\\s *\\S +" namestring) (match-end 0))))
-
-;;
-;; ----------------------------------------------------------------------
-;;
-;; returns the "cdr" of the namestring, really the whole string from
-;; after the first name field to the end of the string.
-;;
-;; (sy-string-cdr "John Xavier Doe")
-;; => "Xavier Doe"
-;;
-(defun sy-string-cdr (namestring)
- (substring namestring
- (progn (string-match "\\s *\\S +\\s *" namestring)
- (match-end 0))))
-
-;;
-;; ----------------------------------------------------------------------
-;;
-;; convert a namestring to a list of namefields
-;;
-;; (sy-namestring-to-list "John Xavier Doe")
-;; => ("John" "Xavier" "Doe")
-;;
-(defun sy-namestring-to-list (namestring)
- (if (not (string-match namestring ""))
- (append (list (sy-string-car namestring))
- (sy-namestring-to-list (sy-string-cdr namestring)))))
-
-;;
-;; ----------------------------------------------------------------------
-;;
-;; strip the initials from each item in the list and return a string
-;; that is the concatenation of the initials
-;;
-(defun sy-strip-initials (raw-nlist)
- (if (not raw-nlist)
- nil
- (concat (substring (car raw-nlist) 0 1)
- (sy-strip-initials (cdr raw-nlist)))))
-
-
-;;
-;; ----------------------------------------------------------------------
-;;
-;; using the namestring, build a list which is in the following order
-;;
-;; (email, initials, firstname, lastname, name1, name2, name3 ... nameN-1)
-;;
-(defun sy-build-ordered-namelist (namestring)
- (let* ((raw-nlist (sy-namestring-to-list namestring))
- (initials (sy-strip-initials raw-nlist))
- (firstname (car raw-nlist))
- (revnames (reverse (cdr raw-nlist)))
- (lastname (car revnames))
- (midnames (reverse (cdr revnames)))
- (emailnames (sy-get-emailname)))
- (append (list emailnames)
- (list initials)
- (list firstname)
- (list lastname)
- midnames)))
-
-;;
-;; ----------------------------------------------------------------------
-;;
-;; Query the user for the attribution string. Supply sy-default-attribution
-;; as the default choice.
-;;
-(defun sy-query-for-attribution ()
- (concat
- (let* ((prompt (concat "Enter attribution string: (default "
- sy-default-attribution
- ") "))
- (query (read-input prompt))
- (attribution (if (string-equal query "")
- sy-default-attribution
- query)))
- (if sy-downcase-p
- (downcase attribution)
- attribution))
- sy-citation-string))
-
-
-;;
-;; ----------------------------------------------------------------------
-;;
-;; parse the current line for the namestring
-;;
-(defun sy-get-namestring ()
- (save-restriction
- (beginning-of-line)
- (if (re-search-forward "(.*)" (point-max) t)
- (let ((start (progn
- (beginning-of-line)
- (re-search-forward "\\((\\s *\\)\\|$" (point-max) t)
- (point)))
- (end (progn
- (re-search-forward
- (concat "\\(\\s *\\()\\|" sy-titlecue-regexp "\\)\\)\\|$")
- (point-max) t)
- (point))))
- (narrow-to-region start end)
- (let ((start (progn
- (beginning-of-line)
- (point)))
- (end (progn
- (end-of-line)
- (re-search-backward
- (concat "\\s *\\()\\|" sy-titlecue-regexp "\\)$")
- (point-min) t)
- (point))))
- (buffer-substring start end)))
- (let ((start (progn
- (beginning-of-line)
- (re-search-forward "^\"*")
- (point)))
- (end (progn
- (re-search-forward "\\(\\s *[a-zA-Z0-9\\.]+\\)*"
- (point-max) t)
- (point))))
- (buffer-substring start end)))))
-
-
-;;
-;; ----------------------------------------------------------------------
-;;
-;; scan the nlist and return the integer pointing to the first legal
-;; non-empty namestring. Returns the integer pointing to the index
-;; in the nlist of the preferred namestring, or nil if no legal
-;; non-empty namestring could be found.
-;;
-(defun sy-return-preference-n (nlist)
- (let ((p sy-preferred-attribution)
- (exception nil))
- ;;
- ;; check to be sure the index is not out-of-bounds
- ;;
- (cond
- ((< p 0) (setq p 2) (setq exception t))
- ((not (nth p nlist)) (setq p 2) (setq exception t)))
- ;;
- ;; check to be sure that the explicit preference is not empty
- ;;
- (if (string-equal (nth p nlist) "")
- (progn (setq p 0)
- (setq exception t)))
- ;;
- ;; find the first non-empty namestring
- ;;
- (while (and (nth p nlist)
- (string-equal (nth p nlist) ""))
- (setq exception t)
- (setq p (+ p 1)))
- ;;
- ;; return the preference index if non-nil, otherwise nil
- ;;
- (if (or (and exception sy-use-only-preference-p)
- (not (nth p nlist)))
- nil
- p)))
-
-;;
-;;
-;; ----------------------------------------------------------------------
-;;
-;; rebuild the nlist into an alist for completing-read. Use as a guide
-;; the index of the preferred name field. Get the actual preferred
-;; name field base on other factors (see above). If no actual preferred
-;; name field is found, then query the user for the attribution string.
-;;
-;; also note that the nlist is guaranteed to be non-empty. At the very
-;; least it will consist of 4 empty strings ("" "" "" "")
-;;
-(defun sy-nlist-to-alist (nlist)
- (let ((preference (sy-return-preference-n nlist))
- alist
- (n 0))
- ;;
- ;; check to be sure preference is not nil
- ;;
- (if (not preference)
- (setq alist (list (cons (sy-query-for-attribution) nil)))
- ;;
- ;; preference is non-nil
- ;;
- (setq alist (list (cons (nth preference nlist) nil)))
- (while (nth n nlist)
- (if (= n preference) nil
- (setq alist (append alist (list (cons (nth n nlist) nil)))))
- (setq n (+ n 1))))
- alist))
-
-
-
-;;
-;; ----------------------------------------------------------------------
-;;
-;; confirm if desired after the alist has been built
-;;
-(defun sy-get-attribution (alist)
- (concat
- ;;
- ;; check to see if nested citations are to be used
- ;;
- (if sy-nested-citation-p
- ""
- ;;
- ;; check to see if confirmation is needed
- ;; if not, just return the preference (first element in alist)
- ;;
- (if (not sy-confirm-always-p)
- (car (car alist))
- ;;
- ;; confirmation is requested so build the prompt, confirm
- ;; and return the chosen string
- ;;
- (let* (ignore
- (prompt (concat "Complete attribution string: (default "
- (car (car alist))
- ") "))
- ;;
- ;; set up the local completion keymap
- ;;
- (minibuffer-local-must-match-map
- (let ((map (make-sparse-keymap)))
- (define-key map "?" 'minibuffer-completion-help)
- (define-key map " " 'minibuffer-complete-word)
- (define-key map "\t" 'minibuffer-complete)
- (define-key map "\00A" 'exit-minibuffer)
- (define-key map "\00D" 'exit-minibuffer)
- (define-key map "\007"
- '(lambda ()
- (interactive)
- (beep)
- (exit-minibuffer)))
- map))
- ;;
- ;; read the completion
- ;;
- (attribution (completing-read prompt alist))
- ;;
- ;; check attribution string for emptyness
- ;;
- (choice (if (or (not attribution)
- (string-equal attribution ""))
- (car (car alist))
- attribution)))
-
- (if sy-downcase-p
- (downcase choice)
- choice))))
- sy-citation-string))
-
-
-;;
-;; ----------------------------------------------------------------------
-;;
-;; this function will scan the current rmail buffer, narrowing it to the
-;; from: line, then using this, it will try to decipher some names from
-;; that line. It will then build the name alist and try to confirm
-;; its choice of attribution strings. It returns the chosen attribution
-;; string.
-;;
-(defun sy-scan-rmail-for-names (rmailbuffer)
- (save-excursion
- (let ((case-fold-search t)
- alist
- attribution)
- (switch-to-buffer rmailbuffer)
- (goto-char (point-min))
- ;;
- ;; be sure there is a from: line
- ;;
- (if (not (re-search-forward "^from:\\s *" (point-max) t))
- (setq attribution (sy-query-for-attribution))
- ;;
- ;; if there is a from: line, then scan the narrow the buffer,
- ;; grab the namestring, and build the alist, then using this
- ;; get the attribution string.
- ;;
- (save-restriction
- (narrow-to-region (point)
- (progn (end-of-line) (point)))
- (let* ((namestring (sy-get-namestring))
- (nlist (sy-build-ordered-namelist namestring)))
- (setq alist (sy-nlist-to-alist nlist))))
- ;;
- ;; we've built the alist, now confirm the attribution choice
- ;; if appropriate
- ;;
- (setq attribution (sy-get-attribution alist)))
- attribution)))
-
-
-;;
-;; ======================================================================
-;;
-;; the following function insert of citations, writing of headers, filling
-;; paragraphs and general higher level operations
-;;
-
-;;
-;; ----------------------------------------------------------------------
-;;
-;; insert a nested citation
-;;
-(defun sy-insert-citation (start end cite-string)
- (save-excursion
- (goto-char end)
- (setq end (point-marker))
- (goto-char start)
- (or (bolp)
- (forward-line 1))
-
- (let ((fill-prefix (concat cite-string " "))
- (fstart (point))
- (fend (point)))
-
- (while (< (point) end)
- ;;
- ;; remove leading tabs if desired
- ;;
- (if sy-left-justify-p
- (delete-region (point)
- (progn (skip-chars-forward " \t") (point))))
- ;;
- ;; check to see if the current line should be cited
- ;;
- (if (or (eolp)
- (looking-at sy-cite-regexp))
- ;;
- ;; do not cite this line unless nested-citations are to be
- ;; used
- ;;
- (progn
- (or (eolp)
- (if sy-nested-citation-p
- (insert cite-string)))
-
- ;; set fill start and end points
- ;;
- (or (= fstart fend)
- (not sy-auto-fill-region-p)
- (progn (goto-char fend)
- (or (not (eolp))
- (setq fend (+ fend 1)))
- (fill-region-as-paragraph fstart fend)))
- (setq fstart (point))
- (setq fend (point)))
-
- ;; else
- ;;
- (insert fill-prefix)
- (end-of-line)
- (setq fend (point)))
-
- (forward-line 1)))
- (move-marker end nil)))
-
-;;
-;; ----------------------------------------------------------------------
-;;
-;; yank a particular field into a holding variable
-;;
-(defun sy-yank-fields (start)
- (save-excursion
- (goto-char start)
- (setq sy-reply-yank-date (mail-fetch-field "date")
- sy-reply-yank-from (mail-fetch-field "from")
- sy-reply-yank-subject (mail-fetch-field "subject")
- sy-reply-yank-newsgroups (mail-fetch-field "newsgroups")
- sy-reply-yank-references (mail-fetch-field "references")
- sy-reply-yank-message-id (mail-fetch-field "message-id")
- sy-reply-yank-organization (mail-fetch-field "organization"))
- (or sy-reply-yank-date
- (setq sy-reply-yank-date "mumble mumble"))
- (or sy-reply-yank-from
- (setq sy-reply-yank-from "mumble mumble"))
- (or sy-reply-yank-subject
- (setq sy-reply-yank-subject "mumble mumble"))
- (or sy-reply-yank-newsgroups
- (setq sy-reply-yank-newsgroups "mumble mumble"))
- (or sy-reply-yank-references
- (setq sy-reply-yank-references "mumble mumble"))
- (or sy-reply-yank-message-id
- (setq sy-reply-yank-message-id "mumble mumble"))
- (or sy-reply-yank-organization
- (setq sy-reply-yank-organization "mumble mumble"))))
-
-;;
-;; ----------------------------------------------------------------------
-;;
-;; rewrite the header to be more conversational
-;;
-(defun sy-rewrite-headers (start)
- (goto-char start)
- (run-hooks 'sy-rewrite-header-hook))
-
-;;
-;; ----------------------------------------------------------------------
-;;
-;; some different styles of headers
-;;
-(defun sy-header-on-said ()
- (insert-string "\nOn " sy-reply-yank-date ",\n"
- sy-reply-yank-from " said:\n"))
-
-(defun sy-header-inarticle-writes ()
- (insert-string "\nIn article " sy-reply-yank-message-id
- " " sy-reply-yank-from " writes:\n"))
-
-(defun sy-header-regarding-writes ()
- (insert-string "\nRegarding " sy-reply-yank-subject
- "; " sy-reply-yank-from " adds:\n"))
-
-(defun sy-header-verbose ()
- (insert-string "\nOn " sy-reply-yank-date ",\n"
- sy-reply-yank-from "\nfrom the organization "
- sy-reply-yank-organization "\nhad this to say about article "
- sy-reply-yank-message-id "\nin newsgroups "
- sy-reply-yank-newsgroups "\nconcerning "
- sy-reply-yank-subject "\nreferring to previous articles "
- sy-reply-yank-references "\n"))
-
-;;
-;; ----------------------------------------------------------------------
-;;
-;; yank the original article in and attribute
-;;
-(defun sy-yank-original (arg)
-
- "Insert the message being replied to, if any (in rmail/gnus). Puts
-point before the text and mark after. Calls generalized citation
-function sy-insert-citation to cite all allowable lines."
-
- (interactive "P")
- (if mail-reply-buffer
- (let* ((sy-confirm-always-p (if (consp arg)
- t
- sy-confirm-always-p))
- (attribution (sy-scan-rmail-for-names mail-reply-buffer))
- (top (point))
- (start (point))
- (end (progn (delete-windows-on mail-reply-buffer)
- (insert-buffer mail-reply-buffer)
- (mark))))
-
- (sy-yank-fields start)
- (sy-rewrite-headers start)
- (setq start (point))
- (mail-yank-clear-headers top (mark))
- (setq sy-persist-attribution (concat attribution " "))
- (sy-insert-citation start end attribution))
-
- (goto-char top)
- (exchange-point-and-mark)))
-
-
-;;
-;; ----------------------------------------------------------------------
-;;
-;; this is here for compatibility with existing mail/news yankers
-;; overloads the default mail-yank-original
-;;
-(defun mail-yank-original (arg)
-
- "Yank original message buffer into the reply buffer, citing as per
-user preferences. Numeric Argument forces confirmation.
-
-Here is a description of the superyank.el package, what it does and
-what variables control its operation. This was written by Barry
-Warsaw (warsaw@cme.nist.gov, {...}!uunet!cme-durer!warsaw).
-
-A 'Citation' is the acknowledgement of the original author of a mail
-message. There are two general forms of citation. In 'nested
-citations', indication is made that the cited line was written by
-someone *other* that the current message author (or by that author at
-an earlier time). No indication is made as to the identity of the
-original author. Thus, a nested citation after multiple replies would
-look like this (this is after my reply to a previous message):
-
->>John originally wrote this
->>and this as well
-> Jane said that John didn't know
-> what he was talking about
-And that's what I think as well.
-
-In non-nested citations, you won't see multiple \">\" characters at
-the beginning of the line. Non-nested citations will insert an
-informative string at the beginning of a cited line, attributing that
-line to an author. The same message described above might look like
-this if non-nested citations were used:
-
-John> John originally wrote this
-John> and this as well
-Jane> Jane said that John didn't know
-Jane> what he was talking about
-And that's what I think as well.
-
-Notice that my inclusion of Jane's inclusion of John's original
-message did not result in a cited line of the form: Jane>John>. Thus
-no nested citations. The style of citation is controlled by the
-variable `sy-nested-citation-p'. Nil uses non-nested citations and
-non-nil uses old style, nested citations.
-
-The variable `sy-citation-string' is the string to use as a marker for
-a citation, either nested or non-nested. For best results, this
-string should be a single character with no trailing space and is
-typically the character \">\". In non-nested citations this string is
-appended to the attribution string (author's name), along with a
-trailing space. In nested citations, a trailing space is only added
-to a first level citation.
-
-Another important variable is `sy-cite-regexp' which describes strings
-that indicate a previously cited line. This regular expression is
-always used at the beginning of a line so it doesn't need to begin
-with a \"^\" character. Change this variable if you change
-`sy-citation-string'.
-
-The following section only applies to non-nested citations.
-
-This package has a fair amount of intellegence related to deciphering
-the author's name based on information provided by the original
-message buffer. In normal operation, the program will pick out the
-author's first and last names, initials, terminal email address and
-any other names it can find. It will then pick an attribution string
-from this list based on a user defined preference and it will ask for
-confirmation if the user specifies. This package gathers its
-information from the `From:' line of the original message buffer. It
-recognizes From: lines with the following forms:
-
-From: John Xavier Doe <doe@speedy.computer.com>
-From: \"John Xavier Doe\" <doe@speedy.computer.com>
-From: doe@speedy.computer.com (John Xavier Doe)
-From: computer!speedy!doe (John Xavier Doe)
-From: computer!speedy!doe (John Xavier Doe)
-From: doe%speedy@computer.com (John Xavier Doe)
-
-In this case, if confirmation is requested, the following strings will
-be made available for completion and confirmation:
-
-\"John\"
-\"Xavier\"
-\"Doe\"
-\"JXD\"
-\"doe\"
-
-Note that completion is case sensitive. If there was a problem
-picking out a From: line, or any other problem getting even a single
-name, then the user will be queried for an attribution string. The
-default attribution string is set in the variable
-`sy-default-attribution'.
-
-Sometimes people set their name fields so that it also includes a
-title of the form:
-
-From: doe@speedy.computer.com (John Doe -- Hacker Extraordinaire)
-
-To avoid the inclusion of the string \"-- Hacker Extraordinaire\" in
-the name list, the variable `sy-titlecue-regexp' is provided. Its
-default setting will still properly recognize names of the form:
-
-From: xdoe@speedy.computer.com (John Xavier-Doe -- Crazed Hacker)
-
-The variable `sy-preferred-attribution' contains an integer that
-indicates which name field the user prefers to use as the attribution
-string, based on the following key:
-
-0: email address name is preferred
-1: initials are preferred
-2: first name is preferred
-3: last name is preferred
-
-The value can be greater than 3, in which case, you would be
-preferring the 2nd throught nth -1 name. In any case, if the
-preferred name can't be found, then one of two actions will be taken
-depending on the value of the variable `sy-use-only-preference-p'. If
-this is non-nil, then the `sy-default-attribution will be used. If it
-is nil, then a secondary scheme will be employed to find a suitable
-attribution scheme. First, the author's first name will be used. If
-that can't be found than the name list is searched for the first
-non-nil, non-empty name string. If still no name can be found, then
-the user is either queried, or the `sy-default-attribution' is used,
-depending on the value of `sy-confirm-always-p'.
-
-If the variable `sy-confirm-always-p' is non-nil, superyank will always
-confirm the attribution string with the user before inserting it into
-the reply buffer. Confirmation is with completion, but the completion
-list is merely a suggestion; the user can override the list by typing
-in a string of their choice.
-
-The variable `sy-rewrite-header-hook' is a hook that contains a lambda
-expression which rewrites the informative header at the top of the
-yanked message. Set to nil to avoid writing any header.
-
-You can make superyank autofill each paragraph it cites by setting the
-variable `sy-auto-fill-region-p' to non-nil. Or set the variable to nil
-and fill the paragraphs manually with sy-fill-paragraph-manually (see
-below).
-
-Finally, `sy-downcase-p' if non-nil, indicates that you always want to
-downcase the attribution string before insertion, and
-`sy-left-justify-p', if non-nil, indicates that you want to delete all
-leading white space before citing.
-
-Since the almost all yanking in other modes (RMAIL, GNUS) is done
-through the function `mail-yank-original', and since superyank
-overloads this function, cited yanking is automatically bound to the
-C-c C-y key. There are three other smaller functions that are
-provided with superyank and they are bound as below. Try C-h f on
-each function to get more information on these functions.
-
-Key Bindings:
-
-C-c C-y mail-yank-original (superyank's version)
-C-c q sy-fill-paragraph-manually
-C-c C-q sy-fill-paragraph-manually
-C-c i sy-insert-persist-attribution
-C-c C-i sy-insert-persist-attribution
-C-c C-o sy-open-line
-
-
-Summary of variables, with their default values:
-
-sy-default-attribution (default: \"Anon\")
- Attribution to use if no attribution string can be deciphered
- from the original message buffer.
-
-sy-citation-string (default: \">\")
- String to append to the attribution string for citation, for
- best results, it should be one character with no trailing space.
-
-sy-nested-citation-p (default: nil)
- Nil means use non-nested citations, non-nil means use old style
- nested citations.
-
-sy-cite-regexp (default: \"[a-zA-Z0-9]*>\")
- Regular expression that matches the beginning of a previously
- cited line. Always used at the beginning of a line so it does
- not need to start with a \"^\" character.
-
-sy-titlecue-regexp (default: \"\\s +-+\\s +\")
- Regular expression that matches a title delimiter in the name
- field.
-
-sy-preferred-attribution (default: 2)
- Integer indicating user's preferred attribution field.
-
-sy-confirm-always-p (default: t)
- Non-nil says always confirm with completion before inserting
- attribution.
-
-sy-rewrite-header-hook (default: 'sy-header-on-said)
- Hook for inserting informative header at the top of the yanked
- message.
-
-sy-downcase-p (default: nil)
- Non-nil says downcase the attribution string before insertion.
-
-sy-left-justify-p (default: nil)
- Non-nil says delete leading white space before citing.
-
-sy-auto-fill-region-p (default: nil)
- Non-nil says don't auto fill the region. T says auto fill the
- paragraph.
-
-sy-use-only-preference-p (default: nil)
- If nil, use backup scheme when preferred attribution string
- can't be found. If non-nil and preferred attribution string
- can't be found, then use sy-default-attribution."
-
- (interactive "P")
-
- (local-set-key "\C-cq" 'sy-fill-paragraph-manually)
- (local-set-key "\C-c\C-q" 'sy-fill-paragraph-manually)
- (local-set-key "\C-c\i" 'sy-insert-persist-attribution)
- (local-set-key "\C-c\C-i" 'sy-insert-persist-attribution)
- (local-set-key "\C-c\C-o" 'sy-open-line)
-
- (sy-yank-original arg))
-
-
-;;
-;; ----------------------------------------------------------------------
-;;
-;; based on Bruce Israel's "fill-paragraph-properly", and modified from
-;; code posted by David C. Lawrence. Modified to use the persistant
-;; attribution if none could be found from the paragraph.
-;;
-(defun sy-fill-paragraph-manually (arg)
- "Fill paragraph containing or following point, automatically finding
-the sy-cite-regexp and using it as the prefix. If the sy-cite-regexp
-is not in the first line of the paragraph, it makes a guess at what
-the fill-prefix for the paragraph should be by looking at the first
-line and taking anything up to the first alphanumeric character.
-
-Prefix arg means justify both sides of paragraph as well.
-
-This function just does fill-paragraph if the fill-prefix is set. If
-what it deduces to be the paragraph prefix (based on the first line)
-does not precede each line in the region, then the persistant
-attribution is used. The persistant attribution is just the last
-attribution string used to cite lines."
-
- (interactive "P")
- (save-excursion
- (forward-paragraph)
- (or (bolp)
- (newline 1))
-
- (let ((end (point))
- st
- (fill-prefix fill-prefix))
- (backward-paragraph)
- (if (looking-at "\n")
- (forward-char 1))
- (setq st (point))
- (if fill-prefix
- nil
- (untabify st end) ;; die, scurvy tabs!
- ;;
- ;; untabify might have made the paragraph longer character-wise,
- ;; make sure end reflects the correct location of eop.
- ;;
- (forward-paragraph)
- (setq end (point))
- (goto-char st)
- (if (looking-at sy-cite-regexp)
- (setq fill-prefix (concat
- (buffer-substring
- st (progn (re-search-forward sy-cite-regexp)
- (point)))
- " "))
- ;;
- ;; this regexp is is convenient because paragraphs quoted by simple
- ;; indentation must still yield to us <evil laugh>
- ;;
- (while (looking-at "[^a-zA-Z0-9]")
- (forward-char 1))
- (setq fill-prefix (buffer-substring st (point))))
- (next-line 1) (beginning-of-line)
- (while (and (< (point) end)
- (not (string-equal fill-prefix "")))
- ;;
- ;; if what we decided was the fill-prefix does not precede all
- ;; of the lines in the paragraph, we probably goofed. In this
- ;; case set it to the persistant attribution.
- ;;
- (if (looking-at (regexp-quote fill-prefix))
- ()
- (setq fill-prefix sy-persist-attribution))
- (next-line 1)
- (beginning-of-line)))
- (fill-region-as-paragraph st end arg))))
-
-;;
-;; ----------------------------------------------------------------------
-;;
-;; insert the persistant attribution at point
-;;
-(defun sy-insert-persist-attribution ()
- "Insert the persistant attribution at the beginning of the line that
-point is on. This string is the last attribution confirmed and used
-in the yanked reply buffer."
- (interactive)
- (save-excursion
- (beginning-of-line)
- (insert-string sy-persist-attribution)))
-
-
-;;
-;; ----------------------------------------------------------------------
-;;
-;; open a line putting the attribution at the beginning
-
-(defun sy-open-line (arg)
- "Insert a newline and leave point before it. Also inserts the
-persistant attribution at the beginning of the line. With arg,
-inserts that many newlines."
- (interactive "p")
- (save-excursion
- (let ((start (point)))
- (open-line arg)
- (goto-char start)
- (forward-line)
- (while (< 0 arg)
- (sy-insert-persist-attribution)
- (forward-line 1)
- (setq arg (- arg 1))))))
-
diff --git a/lisp/tabify.elc b/lisp/tabify.elc
new file mode 100644
index 00000000000..068065efb54
--- /dev/null
+++ b/lisp/tabify.elc
Binary files differ
diff --git a/lisp/tags.el b/lisp/tags.el
new file mode 100644
index 00000000000..2cef30ae2da
--- /dev/null
+++ b/lisp/tags.el
@@ -0,0 +1,304 @@
+;; Tags facility for Emacs.
+;; Copyright (C) 1985, 1986, 1988 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+(provide 'tags)
+
+(defvar tag-table-files nil
+ "List of file names covered by current tag table.
+nil means it has not been computed yet; do (tag-table-files) to compute it.")
+
+(defvar last-tag nil
+ "Tag found by the last find-tag.")
+
+(defun visit-tags-table (file)
+ "Tell tags commands to use tag table file FILE.
+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
+ (concat default-directory "TAGS")
+ t)))
+ (setq file (expand-file-name file))
+ (if (file-directory-p file)
+ (setq file (concat file "TAGS")))
+ (setq tag-table-files nil
+ tags-file-name file))
+
+(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))))
+ (setq tags-file-name buffer-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)))
+
+(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))
+ (setq size (read (current-buffer)))
+ (goto-char prev)
+ (forward-line 1)
+ (forward-char size))
+ (goto-char (1- prev))
+ (buffer-substring (point)
+ (progn (beginning-of-line) (point))))))
+
+(defun tag-table-files ()
+ "Return a list of files in the current tag table.
+File names returned are absolute."
+ (save-excursion
+ (visit-tags-table-buffer)
+ (or tag-table-files
+ (let (files)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (forward-line 1)
+ (end-of-line)
+ (skip-chars-backward "^,\n")
+ (setq prev (point))
+ (setq size (read (current-buffer)))
+ (goto-char prev)
+ (setq files (cons (expand-file-name
+ (buffer-substring (1- (point))
+ (save-excursion
+ (beginning-of-line)
+ (point)))
+ (file-name-directory tags-file-name))
+ files))
+ (forward-line 1)
+ (forward-char size))
+ (setq tag-table-files (nreverse files))))))
+
+;; Return a default tag to search for, based on the text at point.
+(defun find-tag-default ()
+ (save-excursion
+ (while (looking-at "\\sw\\|\\s_")
+ (forward-char 1))
+ (if (re-search-backward "\\sw\\|\\s_" nil t)
+ (progn (forward-char 1)
+ (buffer-substring (point)
+ (progn (forward-sexp -1)
+ (while (looking-at "\\s'")
+ (forward-char 1))
+ (point))))
+ nil)))
+
+(defun find-tag-tag (string)
+ (let* ((default (find-tag-default))
+ (spec (read-string
+ (if default
+ (format "%s(default %s) " string default)
+ string))))
+ (list (if (equal spec "")
+ default
+ spec))))
+
+(defun find-tag (tagname &optional next other-window)
+ "Find tag (in current tag table) 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 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.
+
+See documentation of variable tags-file-name."
+ (interactive (if current-prefix-arg
+ '(nil t)
+ (find-tag-tag "Find tag: ")))
+ (let (buffer file linebeg startpos)
+ (save-excursion
+ (visit-tags-table-buffer)
+ (if (not next)
+ (goto-char (point-min))
+ (setq tagname last-tag))
+ (setq last-tag tagname)
+ (while (progn
+ (if (not (search-forward tagname nil t))
+ (error "No %sentries containing %s"
+ (if next "more " "") tagname))
+ (not (looking-at "[^\n\177]*\177"))))
+ (search-forward "\177")
+ (setq file (expand-file-name (file-of-tag)
+ (file-name-directory tags-file-name)))
+ (setq linebeg
+ (buffer-substring (1- (point))
+ (save-excursion (beginning-of-line) (point))))
+ (search-forward ",")
+ (setq startpos (read (current-buffer))))
+ (if other-window
+ (find-file-other-window file)
+ (find-file file))
+ (widen)
+ (push-mark)
+ (let ((offset 1000)
+ found
+ (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 tags-loop-form '(find-tag nil t))
+ ;; Return t in case used as the tags-loop-form.
+ t)
+
+(defun find-tag-other-window (tagname &optional next)
+ "Find tag (in current tag table) 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.
+
+See documentation of variable tags-file-name."
+ (interactive (if current-prefix-arg
+ '(nil t)
+ (find-tag-tag "Find tag other window: ")))
+ (find-tag tagname next t))
+
+(defvar next-file-list nil
+ "List of files for next-file to process.")
+
+(defun next-file (&optional initialize)
+ "Select next file among files in current tag table.
+Non-nil argument (prefix arg, if interactive)
+initializes to the beginning of the list of files in the tag table."
+ (interactive "P")
+ (if initialize
+ (setq next-file-list (tag-table-files)))
+ (or next-file-list
+ (error "All files processed."))
+ (find-file (car next-file-list))
+ (setq next-file-list (cdr next-file-list)))
+
+(defvar tags-loop-form nil
+ "Form for tags-loop-continue to eval to process one file.
+If it returns nil, it is through with one file; move on to next.")
+
+(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. See variable tags-loop-form."
+ (interactive)
+ (if first-time
+ (progn (next-file t)
+ (goto-char (point-min))))
+ (while (not (eval tags-loop-form))
+ (next-file)
+ (message "Scanning file %s..." buffer-file-name)
+ (goto-char (point-min))))
+
+(defun tags-search (regexp)
+ "Search through all files listed in tag 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 tags-file-name."
+ (interactive "sTags search (regexp): ")
+ (if (and (equal regexp "")
+ (eq (car tags-loop-form) 're-search-forward))
+ (tags-loop-continue nil)
+ (setq tags-loop-form
+ (list 're-search-forward regexp nil t))
+ (tags-loop-continue t)))
+
+(defun tags-query-replace (from to &optional delimited)
+ "Query-replace-regexp FROM with TO through all files listed in tag table.
+Third arg DELIMITED (prefix arg) means replace only word-delimited matches.
+If you exit (C-G or ESC), you can resume the query-replace
+with the command \\[tags-loop-continue].
+
+See documentation of variable tags-file-name."
+ (interactive "sTags query replace (regexp): \nsTags query replace %s by: \nP")
+ (setq tags-loop-form
+ (list 'and (list 'save-excursion
+ (list 're-search-forward from nil t))
+ (list 'not (list 'perform-replace from to t t
+ (not (null delimited))))))
+ (tags-loop-continue t))
+
+(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 "sList tags (in file): ")
+ (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 "^\177")
+ (point))))
+ (terpri)
+ (forward-line 1)))))
+
+(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 "^\177")
+ (point))))
+ (terpri)
+ (forward-line 1)))))
diff --git a/lisp/tags.elc b/lisp/tags.elc
new file mode 100644
index 00000000000..fcef3bd5e3d
--- /dev/null
+++ b/lisp/tags.elc
Binary files differ
diff --git a/lisp/tar-mode.el b/lisp/tar-mode.el
deleted file mode 100644
index c690385064a..00000000000
--- a/lisp/tar-mode.el
+++ /dev/null
@@ -1,1117 +0,0 @@
-;;; -*- Mode: Emacs-Lisp -*-
-
-;;; File: tar-mode.el
-;;; Description: simple editing of tar files from GNU emacs
-;;; Author: Jamie Zawinski <jwz@lucid.com>
-;;; Created: 4 Apr 1990
-;;; Version: 1.21, 10 Mar 91
-
-;;; Copyright (C) 1990, 1991 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;;; This package attempts to make dealing with Unix 'tar' archives easier.
-;;; When this code is loaded, visiting a file whose name ends in '.tar' will
-;;; cause the contents of that archive file to be displayed in a Dired-like
-;;; listing. It is then possible to use the customary Dired keybindings to
-;;; extract sub-files from that archive, either by reading them into their own
-;;; editor buffers, or by copying them directly to arbitrary files on disk.
-;;; It is also possible to delete sub-files from within the tar file and write
-;;; the modified archive back to disk, or to edit sub-files within the archive
-;;; and re-insert the modified files into the archive. See the documentation
-;;; string of tar-mode for more info.
-
-;;; To autoload, add this to your .emacs file:
-;;;
-;;; (setq auto-mode-alist (cons '("\\.tar$" . tar-mode) auto-mode-alist))
-;;; (autoload 'tar-mode "tar-mode")
-;;;
-;;; But beware: for certain tar files - those whose very first file has
-;;; a -*- property line - autoloading won't work. See the function
-;;; "tar-normal-mode" to understand why.
-
-;;; This code now understands the extra fields that GNU tar adds to tar files.
-
-;;; This interacts correctly with "uncompress.el" in the Emacs library,
-;;; which you get with
-;;;
-;;; (autoload 'uncompress-while-visiting "uncompress")
-;;; (setq auto-mode-alist (cons '("\\.Z$" . uncompress-while-visiting)
-;;; auto-mode-alist))
-;;;
-;;; Do not attempt to use tar-mode.el with crypt.el, you will lose.
-
-;;; *************** TO DO ***************
-;;;
-;;; o chmod should understand "a+x,og-w".
-;;;
-;;; o It's not possible to add a NEW file to a tar archive; not that
-;;; important, but still...
-;;;
-;;; o In the directory listing, we don't show creation times because I don't
-;;; know how to print an arbitrary date, and I don't really want to have to
-;;; implement decode-universal-time.
-;;;
-;;; o There's code to update the datestamp of edited subfiles, but we set it
-;;; to zero because I don't know how to get the current time as an integer.
-;;;
-;;; o The code is less efficient that it could be - in a lot of places, I
-;;; pull a 512-character string out of the buffer and parse it, when I could
-;;; be parsing it in place, not garbaging a string. Should redo that.
-;;;
-;;; o I'd like a command that searches for a string/regexp in every subfile
-;;; of an archive, where <esc> would leave you in a subfile-edit buffer.
-;;; (Like the Meta-R command of the Zmacs mail reader.)
-;;;
-;;; o Sometimes (but not always) reverting the tar-file buffer does not
-;;; re-grind the listing, and you are staring at the binary tar data.
-;;; Typing 'g' again immediately after that will always revert and re-grind
-;;; it, though. I have no idea why this happens.
-;;;
-;;; o Tar-mode interacts poorly with crypt.el and zcat.el because the tar
-;;; write-file-hook actually writes the file. Instead it should remove the
-;;; header (and conspire to put it back afterwards) so that other write-file
-;;; hooks which frob the buffer have a chance to do their dirty work. There
-;;; might be a problem if the tar write-file-hook does not come *first* on
-;;; the list.
-;;;
-;;; o Block files, sparse files, continuation files, and the various header
-;;; types aren't editable. Actually I don't know that they work at all.
-
-(defvar tar-anal-blocksize 20
- "*The blocksize of tar files written by Emacs, or nil, meaning don't care.
-The blocksize of a tar file is not really the size of the blocks; rather, it is
-the number of blocks written with one system call. When tarring to a tape,
-this is the size of the *tape* blocks, but when writing to a file, it doesn't
-matter much. The only noticeable difference is that if a tar file does not
-have a blocksize of 20, tar will tell you that; all this really controls is
-how many null padding bytes go on the end of the tar file.")
-
-(defvar tar-update-datestamp nil
- "*Whether tar-mode should play fast and loose with sub-file datestamps;
-if this is true, then editing and saving a tar file entry back into its
-tar file will update its datestamp. If false, the datestamp is unchanged.
-You may or may not want this - it is good in that you can tell when a file
-in a tar archive has been changed, but it is bad for the same reason that
-editing a file in the tar archive at all is bad - the changed version of
-the file never exists on disk.
-
-## This doesn't work yet because there's no way to get the current time as
-## an integer - if this var is true, then editing a file sets its date to
-## December 31, 1969 (which happens to be what 0 encodes).")
-
-
-
-;;; First, duplicate some Common Lisp functions; I used to just (require 'cl)
-;;; but "cl.el" was messing some people up (also it's really big).
-
-(defmacro tar-setf (form val)
- "A mind-numbingly simple implementation of setf."
- (let ((mform (macroexpand form (and (boundp 'byte-compile-macro-environment)
- byte-compile-macro-environment))))
- (cond ((symbolp mform) (list 'setq mform val))
- ((not (consp mform)) (error "can't setf %s" form))
- ((eq (car mform) 'aref)
- (list 'aset (nth 1 mform) (nth 2 mform) val))
- ((eq (car mform) 'car)
- (list 'setcar (nth 1 mform) val))
- ((eq (car mform) 'cdr)
- (list 'setcdr (nth 1 mform) val))
- (t (error "don't know how to setf %s" form)))))
-
-(defmacro tar-dolist (control &rest body)
- "syntax: (dolist (var-name list-expr &optional return-value) &body body)"
- (let ((var (car control))
- (init (car (cdr control)))
- (val (car (cdr (cdr control)))))
- (list 'let (list (list '_dolist_iterator_ init))
- (list 'while '_dolist_iterator_
- (cons 'let
- (cons (list (list var '(car _dolist_iterator_)))
- (append body
- (list (list 'setq '_dolist_iterator_
- (list 'cdr '_dolist_iterator_)))))))
- val)))
-
-(defmacro tar-dotimes (control &rest body)
- "syntax: (dolist (var-name count-expr &optional return-value) &body body)"
- (let ((var (car control))
- (n (car (cdr control)))
- (val (car (cdr (cdr control)))))
- (list 'let (list (list '_dotimes_end_ n)
- (list var 0))
- (cons 'while
- (cons (list '< var '_dotimes_end_)
- (append body
- (list (list 'setq var (list '1+ var))))))
- val)))
-
-
-;;; down to business.
-
-(defmacro make-tar-header (name mode uid git size date ck lt ln
- magic uname gname devmaj devmin)
- (list 'vector name mode uid git size date ck lt ln
- magic uname gname devmaj devmin))
-
-(defmacro tar-header-name (x) (list 'aref x 0))
-(defmacro tar-header-mode (x) (list 'aref x 1))
-(defmacro tar-header-uid (x) (list 'aref x 2))
-(defmacro tar-header-gid (x) (list 'aref x 3))
-(defmacro tar-header-size (x) (list 'aref x 4))
-(defmacro tar-header-date (x) (list 'aref x 5))
-(defmacro tar-header-checksum (x) (list 'aref x 6))
-(defmacro tar-header-link-type (x) (list 'aref x 7))
-(defmacro tar-header-link-name (x) (list 'aref x 8))
-(defmacro tar-header-magic (x) (list 'aref x 9))
-(defmacro tar-header-uname (x) (list 'aref x 10))
-(defmacro tar-header-gname (x) (list 'aref x 11))
-(defmacro tar-header-dmaj (x) (list 'aref x 12))
-(defmacro tar-header-dmin (x) (list 'aref x 13))
-
-(defmacro make-tar-desc (data-start tokens)
- (list 'cons data-start tokens))
-
-(defmacro tar-desc-data-start (x) (list 'car x))
-(defmacro tar-desc-tokens (x) (list 'cdr x))
-
-(defconst tar-name-offset 0)
-(defconst tar-mode-offset (+ tar-name-offset 100))
-(defconst tar-uid-offset (+ tar-mode-offset 8))
-(defconst tar-gid-offset (+ tar-uid-offset 8))
-(defconst tar-size-offset (+ tar-gid-offset 8))
-(defconst tar-time-offset (+ tar-size-offset 12))
-(defconst tar-chk-offset (+ tar-time-offset 12))
-(defconst tar-linkp-offset (+ tar-chk-offset 8))
-(defconst tar-link-offset (+ tar-linkp-offset 1))
-;;; GNU-tar specific slots.
-(defconst tar-magic-offset (+ tar-link-offset 100))
-(defconst tar-uname-offset (+ tar-magic-offset 8))
-(defconst tar-gname-offset (+ tar-uname-offset 32))
-(defconst tar-dmaj-offset (+ tar-gname-offset 32))
-(defconst tar-dmin-offset (+ tar-dmaj-offset 8))
-(defconst tar-end-offset (+ tar-dmin-offset 8))
-
-(defun tokenize-tar-header-block (string)
- "Returns a 'tar-header' structure (a list of name, mode, uid, gid, size,
-write-date, checksum, link-type, and link-name)."
- (cond ((< (length string) 512) nil)
- (;(some 'plusp string) ; <-- oops, massive cycle hog!
- (or (not (= 0 (aref string 0))) ; This will do.
- (not (= 0 (aref string 101))))
- (let* ((name-end (1- tar-mode-offset))
- (link-end (1- tar-magic-offset))
- (uname-end (1- tar-gname-offset))
- (gname-end (1- tar-dmaj-offset))
- (link-p (aref string tar-linkp-offset))
- (magic-str (substring string tar-magic-offset (1- tar-uname-offset)))
- (uname-valid-p (or (string= "ustar " magic-str) (string= "GNUtar " magic-str)))
- name
- (nulsexp "[^\000]*\000"))
- (and (string-match nulsexp string tar-name-offset) (setq name-end (min name-end (1- (match-end 0)))))
- (and (string-match nulsexp string tar-link-offset) (setq link-end (min link-end (1- (match-end 0)))))
- (and (string-match nulsexp string tar-uname-offset) (setq uname-end (min uname-end (1- (match-end 0)))))
- (and (string-match nulsexp string tar-gname-offset) (setq gname-end (min gname-end (1- (match-end 0)))))
- (setq name (substring string tar-name-offset name-end)
- link-p (if (or (= link-p 0) (= link-p ?0))
- nil
- (- link-p ?0)))
- (if (and (null link-p) (string-match "/$" name)) (setq link-p 5)) ; directory
- (make-tar-header
- name
- (tar-parse-octal-integer string tar-mode-offset (1- tar-uid-offset))
- (tar-parse-octal-integer string tar-uid-offset (1- tar-gid-offset))
- (tar-parse-octal-integer string tar-gid-offset (1- tar-size-offset))
- (tar-parse-octal-integer string tar-size-offset (1- tar-time-offset))
- (tar-parse-octal-integer string tar-time-offset (1- tar-chk-offset))
- (tar-parse-octal-integer string tar-chk-offset (1- tar-linkp-offset))
- link-p
- (substring string tar-link-offset link-end)
- uname-valid-p
- (and uname-valid-p (substring string tar-uname-offset uname-end))
- (and uname-valid-p (substring string tar-gname-offset gname-end))
- (tar-parse-octal-integer string tar-dmaj-offset (1- tar-dmin-offset))
- (tar-parse-octal-integer string tar-dmin-offset (1- tar-end-offset))
- )))
- (t 'empty-tar-block)))
-
-
-(defun tar-parse-octal-integer (string &optional start end)
- "deletes all your files, and then reboots."
- (if (null start) (setq start 0))
- (if (null end) (setq end (length string)))
- (if (= (aref string start) 0)
- 0
- (let ((n 0))
- (while (< start end)
- (setq n (if (< (aref string start) ?0) n
- (+ (* n 8) (- (aref string start) 48)))
- start (1+ start)))
- n)))
-
-(defun tar-parse-octal-integer-safe (string)
- (let ((L (length string)))
- (if (= L 0) (error "empty string"))
- (tar-dotimes (i L)
- (if (or (< (aref string i) ?0)
- (> (aref string i) ?7))
- (error "'%c' is not an octal digit."))))
- (tar-parse-octal-integer string))
-
-
-(defun checksum-tar-header-block (string)
- "Computes and returns a tar-acceptable checksum for this block."
- (let* ((chk-field-start tar-chk-offset)
- (chk-field-end (+ chk-field-start 8))
- (sum 0)
- (i 0))
- ;; Add up all of the characters except the ones in the checksum field.
- ;; Add that field as if it were filled with spaces.
- (while (< i chk-field-start)
- (setq sum (+ sum (aref string i))
- i (1+ i)))
- (setq i chk-field-end)
- (while (< i 512)
- (setq sum (+ sum (aref string i))
- i (1+ i)))
- (+ sum (* 32 8))))
-
-(defun check-tar-header-block-checksum (hblock desired-checksum file-name)
- "Beep and print a warning if the checksum doesn't match."
- (if (not (= desired-checksum (checksum-tar-header-block hblock)))
- (progn (beep) (message "Invalid checksum for file %s!" file-name))))
-
-(defun recompute-tar-header-block-checksum (hblock)
- "Modifies the given string to have a valid checksum field."
- (let* ((chk (checksum-tar-header-block hblock))
- (chk-string (format "%6o" chk))
- (l (length chk-string)))
- (aset hblock 154 0)
- (aset hblock 155 32)
- (tar-dotimes (i l) (aset hblock (- 153 i) (aref chk-string (- l i 1)))))
- hblock)
-
-
-(defun tar-grind-file-mode (mode string start)
- "Write a \"-rw--r--r-\" representing MODE into STRING beginning at START."
- (aset string start (if (zerop (logand 256 mode)) ?- ?r))
- (aset string (+ start 1) (if (zerop (logand 128 mode)) ?- ?w))
- (aset string (+ start 2) (if (zerop (logand 64 mode)) ?- ?x))
- (aset string (+ start 3) (if (zerop (logand 32 mode)) ?- ?r))
- (aset string (+ start 4) (if (zerop (logand 16 mode)) ?- ?w))
- (aset string (+ start 5) (if (zerop (logand 8 mode)) ?- ?x))
- (aset string (+ start 6) (if (zerop (logand 4 mode)) ?- ?r))
- (aset string (+ start 7) (if (zerop (logand 2 mode)) ?- ?w))
- (aset string (+ start 8) (if (zerop (logand 1 mode)) ?- ?x))
- (if (zerop (logand 1024 mode)) nil (aset string (+ start 2) ?s))
- (if (zerop (logand 2048 mode)) nil (aset string (+ start 5) ?s))
- string)
-
-(defun summarize-tar-header-block (tar-hblock &optional mod-p)
- "Returns a line similar to the output of 'tar -vtf'."
- (let ((name (tar-header-name tar-hblock))
- (mode (tar-header-mode tar-hblock))
- (uid (tar-header-uid tar-hblock))
- (gid (tar-header-gid tar-hblock))
- (uname (tar-header-uname tar-hblock))
- (gname (tar-header-gname tar-hblock))
- (size (tar-header-size tar-hblock))
- (time (tar-header-date tar-hblock))
- (ck (tar-header-checksum tar-hblock))
- (link-p (tar-header-link-type tar-hblock))
- (link-name (tar-header-link-name tar-hblock))
- )
- (let* ((left 11)
- (namew 8)
- (groupw 8)
- (sizew 8)
- (datew 2)
- (slash (1- (+ left namew)))
- (lastdigit (+ slash groupw sizew))
- (namestart (+ lastdigit datew))
- (string (make-string (+ namestart (length name) (if link-p (+ 5 (length link-name)) 0)) 32))
- (type (tar-header-link-type tar-hblock)))
- (aset string 0 (if mod-p ?* ? ))
- (aset string 1
- (cond ((or (eq type nil) (eq type 0)) ?-)
- ((eq type 1) ?l) ; link
- ((eq type 2) ?s) ; symlink
- ((eq type 3) ?c) ; char special
- ((eq type 4) ?b) ; block special
- ((eq type 5) ?d) ; directory
- ((eq type 6) ?p) ; FIFO/pipe
- ((eq type 20) ?*) ; directory listing
- ((eq type 29) ?M) ; multivolume continuation
- ((eq type 35) ?S) ; sparse
- ((eq type 38) ?V) ; volume header
- ))
- (tar-grind-file-mode mode string 2)
- (setq uid (if (= 0 (length uname)) (int-to-string uid) uname))
- (setq gid (if (= 0 (length gname)) (int-to-string gid) gname))
- (setq size (int-to-string size))
- (tar-dotimes (i (min (1- namew) (length uid))) (aset string (- slash i) (aref uid (- (length uid) i 1))))
- (aset string (1+ slash) ?/)
- (tar-dotimes (i (min (1- groupw) (length gid))) (aset string (+ (+ slash 2) i) (aref gid i)))
- (tar-dotimes (i (min sizew (length size))) (aset string (- lastdigit i) (aref size (- (length size) i 1))))
- ;; ## bloody hell, how do I print an arbitrary date??
- (tar-dotimes (i (length name)) (aset string (+ namestart i) (aref name i)))
- (if (or (eq link-p 1) (eq link-p 2))
- (progn
- (tar-dotimes (i 3) (aset string (+ namestart 1 (length name) i) (aref (if (= link-p 1) "==>" "-->") i)))
- (tar-dotimes (i (length link-name)) (aset string (+ namestart 5 (length name) i) (aref link-name i)))))
- string)))
-
-
-(defun tar-summarize-buffer ()
- "Parse the contents of the tar file in the current buffer, and place a
-dired-like listing on the front; then narrow to it, so that only that listing
-is visible (and the real data of the buffer is hidden)."
- (message "parsing tar file...")
- (let* ((result '())
- (pos 1)
- (bs (max 1 (- (buffer-size) 1024))) ; always 2+ empty blocks at end.
- (bs100 (max 1 (/ bs 100)))
- (tokens nil))
- (while (not (eq tokens 'empty-tar-block))
- (let* ((hblock (buffer-substring pos (+ pos 512))))
- (setq tokens (tokenize-tar-header-block hblock))
- (setq pos (+ pos 512))
- (message "parsing tar file...%s%%"
- ;(/ (* pos 100) bs) ; this gets round-off lossage
- (/ pos bs100) ; this doesn't
- )
- (if (eq tokens 'empty-tar-block)
- nil
- (if (null tokens) (error "premature EOF parsing tar file."))
- (if (eq (tar-header-link-type tokens) 20)
- ;; Foo. There's an extra empty block after these.
- (setq pos (+ pos 512)))
- (let ((size (tar-header-size tokens)))
- (if (< size 0)
- (error "%s has size %s - corrupted."
- (tar-header-name tokens) size))
- ;
- ; This is just too slow. Don't really need it anyway....
- ;(check-tar-header-block-checksum
- ; hblock (checksum-tar-header-block hblock)
- ; (tar-header-name tokens))
-
- (setq result (cons (make-tar-desc pos tokens) result))
-
- (if (and (null (tar-header-link-type tokens))
- (> size 0))
- (setq pos
- (+ pos 512 (ash (ash (1- size) -9) 9)) ; this works
- ;(+ pos (+ size (- 512 (rem (1- size) 512)))) ; this doesn't
- ))
- ))))
- (make-local-variable 'tar-parse-info)
- (setq tar-parse-info (nreverse result)))
- (save-excursion
- (goto-char (point-min))
- (let ((buffer-read-only nil))
- (tar-dolist (tar-desc tar-parse-info)
- (insert-string
- (summarize-tar-header-block (tar-desc-tokens tar-desc)))
- (insert-string "\n"))
- (make-local-variable 'tar-header-offset)
- (setq tar-header-offset (point))
- (narrow-to-region 1 tar-header-offset)
- (set-buffer-modified-p nil)))
- (message "parsing tar file...done."))
-
-
-(defvar tar-mode-map nil "*Local keymap for tar-mode listings.")
-
-(if tar-mode-map
- nil
- (setq tar-mode-map (make-keymap))
- (suppress-keymap tar-mode-map)
- (define-key tar-mode-map " " 'tar-next-line)
- (define-key tar-mode-map "c" 'tar-copy)
- (define-key tar-mode-map "d" 'tar-flag-deleted)
- (define-key tar-mode-map "\^D" 'tar-flag-deleted)
- (define-key tar-mode-map "e" 'tar-extract)
- (define-key tar-mode-map "f" 'tar-extract)
- (define-key tar-mode-map "g" 'revert-buffer)
- (define-key tar-mode-map "h" 'describe-mode)
- (define-key tar-mode-map "n" 'tar-next-line)
- (define-key tar-mode-map "\^N" 'tar-next-line)
- (define-key tar-mode-map "o" 'tar-extract-other-window)
- (define-key tar-mode-map "\^C" 'tar-copy)
- (define-key tar-mode-map "p" 'tar-previous-line)
- (define-key tar-mode-map "\^P" 'tar-previous-line)
- (define-key tar-mode-map "r" 'tar-rename-entry)
- (define-key tar-mode-map "u" 'tar-unflag)
- (define-key tar-mode-map "v" 'tar-view)
- (define-key tar-mode-map "x" 'tar-expunge)
- (define-key tar-mode-map "\177" 'tar-unflag-backwards)
- (define-key tar-mode-map "E" 'tar-extract-other-window)
- (define-key tar-mode-map "M" 'tar-chmod-entry)
- (define-key tar-mode-map "G" 'tar-chgrp-entry)
- (define-key tar-mode-map "O" 'tar-chown-entry)
- )
-
-;; tar mode is suitable only for specially formatted data.
-(put 'tar-mode 'mode-class 'special)
-(put 'tar-subfile-mode 'mode-class 'special)
-
-(defun tar-mode ()
- "Major mode for viewing a tar file as a dired-like listing of its contents.
-You can move around using the usual cursor motion commands.
-Letters no longer insert themselves.
-Type 'e' to pull a file out of the tar file and into its own buffer.
-Type 'c' to copy an entry from the tar file into another file on disk.
-
-If you edit a sub-file of this archive (as with the 'e' command) and
-save it with Control-X Control-S, the contents of that buffer will be
-saved back into the tar-file buffer; in this way you can edit a file
-inside of a tar archive without extracting it and re-archiving it.
-
-See also: variables tar-update-datestamp and tar-anal-blocksize.
-\\{tar-mode-map}"
- ;; this is not interactive because you shouldn't be turning this
- ;; mode on and off. You can corrupt things that way.
- (make-local-variable 'tar-header-offset)
- (make-local-variable 'tar-parse-info)
- (make-local-variable 'require-final-newline)
- (setq require-final-newline nil) ; binary data, dude...
- (make-local-variable 'revert-buffer-function)
- (setq revert-buffer-function 'tar-mode-revert)
- (setq major-mode 'tar-mode)
- (setq mode-name "Tar")
- (use-local-map tar-mode-map)
- (auto-save-mode 0)
- (widen)
- (if (and (boundp 'tar-header-offset) tar-header-offset)
- (narrow-to-region 1 tar-header-offset)
- (tar-summarize-buffer))
- (run-hooks 'tar-mode-hook)
- )
-
-
-(defun tar-subfile-mode (p)
- "Minor mode for editing an element of a tar-file.
-This mode redefines ^X^S to save the current buffer back into its
-associated tar-file buffer. You must save that buffer to actually
-save your changes to disk."
- (interactive "P")
- (or (and (boundp 'superior-tar-buffer) superior-tar-buffer)
- (error "This buffer is not an element of a tar file."))
- (or (assq 'tar-subfile-mode minor-mode-alist)
- (setq minor-mode-alist (append minor-mode-alist
- (list '(tar-subfile-mode
- " TarFile")))))
- (make-local-variable 'tar-subfile-mode)
- (setq tar-subfile-mode
- (if (null p)
- (not tar-subfile-mode)
- (> (prefix-numeric-value p) 0)))
- (cond (tar-subfile-mode
- ;; copy the local keymap so that we don't accidentally
- ;; alter a keymap like 'lisp-mode-map' which is shared
- ;; by all buffers in that mode.
- (let ((m (current-local-map)))
- (if m (use-local-map (copy-keymap m))))
- (local-set-key "\^X\^S" 'tar-subfile-save-buffer)
- ;; turn off auto-save.
- (auto-save-mode nil)
- (setq buffer-auto-save-file-name nil)
- (run-hooks 'tar-subfile-mode-hook))
- (t (local-set-key "\^X\^S" 'save-buffer)))
- )
-
-
-(defun tar-mode-revert (&optional no-autosave no-confirm)
- "Revert this buffer and turn on tar mode again, to re-compute the
-directory listing."
- (setq tar-header-offset nil)
- (let ((revert-buffer-function nil))
- (revert-buffer t no-confirm)
- (widen))
- (tar-mode))
-
-
-(defun tar-next-line (p)
- (interactive "p")
- (forward-line p)
- (if (eobp) nil (forward-char 36)))
-
-(defun tar-previous-line (p)
- (interactive "p")
- (tar-next-line (- p)))
-
-(defun tar-current-descriptor (&optional noerror)
- "Returns the tar-descriptor of the current line, or signals an error."
- ;; I wish lines had plists, like in ZMACS...
- (or (nth (count-lines (point-min)
- (save-excursion (beginning-of-line) (point)))
- tar-parse-info)
- (if noerror
- nil
- (error "This line does not describe a tar-file entry."))))
-
-
-(defun tar-extract (&optional other-window-p)
- "*In tar-mode, extract this entry of the tar file into its own buffer."
- (interactive)
- (let* ((view-p (eq other-window-p 'view))
- (descriptor (tar-current-descriptor))
- (tokens (tar-desc-tokens descriptor))
- (name (tar-header-name tokens))
- (size (tar-header-size tokens))
- (link-p (tar-header-link-type tokens))
- (start (+ (tar-desc-data-start descriptor) tar-header-offset -1))
- (end (+ start size)))
- (if link-p
- (error "This is a %s, not a real file."
- (cond ((eq link-p 5) "directory")
- ((eq link-p 20) "tar directory header")
- ((eq link-p 29) "multivolume-continuation")
- ((eq link-p 35) "sparse entry")
- ((eq link-p 38) "volume header")
- (t "link"))))
- (if (zerop size) (error "This is a zero-length file."))
- (let* ((tar-buffer (current-buffer))
- (bufname (concat (file-name-nondirectory name)
- " (" name " in "
- (file-name-nondirectory (buffer-file-name))
- ")"))
- (read-only-p (or buffer-read-only view-p))
- (buffer (get-buffer bufname))
- (just-created nil))
- (if buffer
- nil
- (setq buffer (get-buffer-create bufname))
- (setq just-created t)
- (unwind-protect
- (progn
- (widen)
- (save-excursion
- (set-buffer buffer)
- (insert-buffer-substring tar-buffer start end)
- (goto-char 0)
- (set-visited-file-name name) ; give it a name to decide mode.
- (normal-mode) ; pick a mode.
- (set-visited-file-name nil) ; nuke the name - not meaningful.
- (rename-buffer bufname)
-
- (make-local-variable 'superior-tar-buffer)
- (make-local-variable 'superior-tar-descriptor)
- (setq superior-tar-buffer tar-buffer)
- (setq superior-tar-descriptor descriptor)
- (tar-subfile-mode 1)
-
- (setq buffer-read-only read-only-p)
- (set-buffer-modified-p nil))
- (set-buffer tar-buffer))
- (narrow-to-region 1 tar-header-offset)))
- (if view-p
- (progn
- (view-buffer buffer)
- (and just-created (kill-buffer buffer)))
- (if other-window-p
- (switch-to-buffer-other-window buffer)
- (switch-to-buffer buffer))))))
-
-
-(defun tar-extract-other-window ()
- "*In tar-mode, extract this entry of the tar file into its own buffer."
- (interactive)
- (tar-extract t))
-
-(defun tar-view ()
- "*In tar-mode, view the tar file entry on this line."
- (interactive)
- (tar-extract 'view))
-
-
-(defun tar-read-file-name (&optional prompt)
- "Calls read-file-name, with the default being the file of the current
-tar-file descriptor."
- (or prompt (setq prompt "Copy to: "))
- (let* ((default-file (expand-file-name
- (tar-header-name (tar-desc-tokens
- (tar-current-descriptor)))))
- (target (expand-file-name
- (read-file-name prompt
- (file-name-directory default-file)
- default-file nil))))
- (if (or (string= "" (file-name-nondirectory target))
- (file-directory-p target))
- (setq target (concat (if (string-match "/$" target)
- (substring target 0 (1- (match-end 0)))
- target)
- "/"
- (file-name-nondirectory default-file))))
- target))
-
-
-(defun tar-copy (&optional to-file)
- "*In tar-mode, extract this entry of the tar file into a file on disk.
-If TO-FILE is not supplied, it is prompted for, defaulting to the name of
-the current tar-entry."
- (interactive (list (tar-read-file-name)))
- (let* ((descriptor (tar-current-descriptor))
- (tokens (tar-desc-tokens descriptor))
- (name (tar-header-name tokens))
- (size (tar-header-size tokens))
- (link-p (tar-header-link-type tokens))
- (start (+ (tar-desc-data-start descriptor) tar-header-offset -1))
- (end (+ start size)))
- (if link-p (error "This is a link, not a real file."))
- (if (zerop size) (error "This is a zero-length file."))
- (let* ((tar-buffer (current-buffer))
- buffer)
- (unwind-protect
- (progn
- (setq buffer (generate-new-buffer "*tar-copy-tmp*"))
- (widen)
- (save-excursion
- (set-buffer buffer)
- (insert-buffer-substring tar-buffer start end)
- (set-buffer-modified-p nil) ; in case we abort
- (write-file to-file)
- (message "Copied tar entry %s to %s" name to-file)
- (set-buffer tar-buffer)))
- (narrow-to-region 1 tar-header-offset)
- (if buffer (kill-buffer buffer)))
- )))
-
-
-(defun tar-flag-deleted (p &optional unflag)
- "*In tar mode, mark this sub-file to be deleted from the tar file.
-With a prefix argument, mark that many files."
- (interactive "p")
- (beginning-of-line)
- (tar-dotimes (i (if (< p 0) (- p) p))
- (if (tar-current-descriptor unflag) ; barf if we're not on an entry-line.
- (progn
- (delete-char 1)
- (insert (if unflag " " "D"))))
- (forward-line (if (< p 0) -1 1)))
- (if (eobp) nil (forward-char 36)))
-
-(defun tar-unflag (p)
- "*In tar mode, un-mark this sub-file if it is marked to be deleted.
-With a prefix argument, un-mark that many files forward."
- (interactive "p")
- (tar-flag-deleted p t))
-
-(defun tar-unflag-backwards (p)
- "*In tar mode, un-mark this sub-file if it is marked to be deleted.
-With a prefix argument, un-mark that many files backward."
- (interactive "p")
- (tar-flag-deleted (- p) t))
-
-
-(defun tar-expunge-internal ()
- "Expunge the tar-entry specified by the current line."
- (let* ((descriptor (tar-current-descriptor))
- (tokens (tar-desc-tokens descriptor))
- (line (tar-desc-data-start descriptor))
- (name (tar-header-name tokens))
- (size (tar-header-size tokens))
- (link-p (tar-header-link-type tokens))
- (start (tar-desc-data-start descriptor))
- (following-descs (cdr (memq descriptor tar-parse-info))))
- (if link-p (setq size 0)) ; size lies for hard-links.
- ;;
- ;; delete the current line...
- (beginning-of-line)
- (let ((line-start (point)))
- (end-of-line) (forward-char)
- (let ((line-len (- (point) line-start)))
- (delete-region line-start (point))
- ;;
- ;; decrement the header-pointer to be in synch...
- (setq tar-header-offset (- tar-header-offset line-len))))
- ;;
- ;; delete the data pointer...
- (setq tar-parse-info (delq descriptor tar-parse-info))
- ;;
- ;; delete the data from inside the file...
- (widen)
- (let* ((data-start (+ start tar-header-offset -513))
- (data-end (+ data-start 512 (ash (ash (+ size 511) -9) 9))))
- (delete-region data-start data-end)
- ;;
- ;; and finally, decrement the start-pointers of all following
- ;; entries in the archive. This is a pig when deleting a bunch
- ;; of files at once - we could optimize this to only do the
- ;; iteration over the files that remain, or only iterate up to
- ;; the next file to be deleted.
- (let ((data-length (- data-end data-start)))
- (tar-dolist (desc following-descs)
- (tar-setf (tar-desc-data-start desc)
- (- (tar-desc-data-start desc) data-length))))
- ))
- (narrow-to-region 1 tar-header-offset))
-
-
-(defun tar-expunge (&optional noconfirm)
- "*In tar-mode, delete all the archived files flagged for deletion.
-This does not modify the disk image; you must save the tar file itself
-for this to be permanent."
- (interactive)
- (if (or noconfirm
- (y-or-n-p "expunge files marked for deletion? "))
- (let ((n 0))
- (save-excursion
- (goto-char 0)
- (while (not (eobp))
- (if (looking-at "D")
- (progn (tar-expunge-internal)
- (setq n (1+ n)))
- (forward-line 1)))
- ;; after doing the deletions, add any padding that may be necessary.
- (tar-pad-to-blocksize)
- (narrow-to-region 1 tar-header-offset)
- )
- (if (zerop n)
- (message "nothing to expunge.")
- (message "%s expunged. Be sure to save this buffer." n)))))
-
-
-(defun tar-clear-modification-flags ()
- "remove the stars at the beginning of each line."
- (save-excursion
- (goto-char 0)
- (while (< (point) tar-header-offset)
- (if (looking-at "*")
- (progn (delete-char 1) (insert " ")))
- (forward-line 1))))
-
-
-(defun tar-chown-entry (new-uid)
- "*Change the user-id associated with this entry in the tar file.
-If this tar file was written by GNU tar, then you will be able to edit
-the user id as a string; otherwise, you must edit it as a number.
-You can force editing as a number by calling this with a prefix arg.
-This does not modify the disk image; you must save the tar file itself
-for this to be permanent."
- (interactive (list
- (let ((tokens (tar-desc-tokens (tar-current-descriptor))))
- (if (or current-prefix-arg
- (not (tar-header-magic tokens)))
- (let (n)
- (while (not (numberp (setq n (read-minibuffer
- "New UID number: "
- (format "%s" (tar-header-uid tokens)))))))
- n)
- (read-string "New UID string: " (tar-header-uname tokens))))))
- (cond ((stringp new-uid)
- (tar-setf (tar-header-uname (tar-desc-tokens (tar-current-descriptor)))
- new-uid)
- (tar-alter-one-field tar-uname-offset (concat new-uid "\000")))
- (t
- (tar-setf (tar-header-uid (tar-desc-tokens (tar-current-descriptor)))
- new-uid)
- (tar-alter-one-field tar-uid-offset
- (concat (substring (format "%6o" new-uid) 0 6) "\000 ")))))
-
-
-(defun tar-chgrp-entry (new-gid)
- "*Change the group-id associated with this entry in the tar file.
-If this tar file was written by GNU tar, then you will be able to edit
-the group id as a string; otherwise, you must edit it as a number.
-You can force editing as a number by calling this with a prefix arg.
-This does not modify the disk image; you must save the tar file itself
-for this to be permanent."
- (interactive (list
- (let ((tokens (tar-desc-tokens (tar-current-descriptor))))
- (if (or current-prefix-arg
- (not (tar-header-magic tokens)))
- (let (n)
- (while (not (numberp (setq n (read-minibuffer
- "New GID number: "
- (format "%s" (tar-header-gid tokens)))))))
- n)
- (read-string "New GID string: " (tar-header-gname tokens))))))
- (cond ((stringp new-gid)
- (tar-setf (tar-header-gname (tar-desc-tokens (tar-current-descriptor)))
- new-gid)
- (tar-alter-one-field tar-gname-offset
- (concat new-gid "\000")))
- (t
- (tar-setf (tar-header-gid (tar-desc-tokens (tar-current-descriptor)))
- new-gid)
- (tar-alter-one-field tar-gid-offset
- (concat (substring (format "%6o" new-gid) 0 6) "\000 ")))))
-
-(defun tar-rename-entry (new-name)
- "*Change the name associated with this entry in the tar file.
-This does not modify the disk image; you must save the tar file itself
-for this to be permanent."
- (interactive
- (list (read-string "New name: "
- (tar-header-name (tar-desc-tokens (tar-current-descriptor))))))
- (if (string= "" new-name) (error "zero length name."))
- (if (> (length new-name) 98) (error "name too long."))
- (tar-setf (tar-header-name (tar-desc-tokens (tar-current-descriptor)))
- new-name)
- (tar-alter-one-field 0
- (substring (concat new-name (make-string 99 0)) 0 99)))
-
-
-(defun tar-chmod-entry (new-mode)
- "*Change the protection bits associated with this entry in the tar file.
-This does not modify the disk image; you must save the tar file itself
-for this to be permanent."
- (interactive (list (tar-parse-octal-integer-safe
- (read-string "New protection (octal): "))))
- (tar-setf (tar-header-mode (tar-desc-tokens (tar-current-descriptor)))
- new-mode)
- (tar-alter-one-field tar-mode-offset
- (concat (substring (format "%6o" new-mode) 0 6) "\000 ")))
-
-
-(defun tar-alter-one-field (data-position new-data-string)
- (let* ((descriptor (tar-current-descriptor))
- (tokens (tar-desc-tokens descriptor)))
- (unwind-protect
- (save-excursion
- ;;
- ;; update the header-line.
- (beginning-of-line)
- (let ((p (point)))
- (forward-line 1)
- (delete-region p (point))
- (insert (summarize-tar-header-block tokens) "\n")
- (setq tar-header-offset (point-max)))
-
- (widen)
- (let* ((start (+ (tar-desc-data-start descriptor) tar-header-offset -513)))
- ;;
- ;; delete the old field and insert a new one.
- (goto-char (+ start data-position))
- (delete-region (point) (+ (point) (length new-data-string))) ; <--
- (insert new-data-string) ; <--
- ;;
- ;; compute a new checksum and insert it.
- (let ((chk (checksum-tar-header-block
- (buffer-substring start (+ start 512)))))
- (goto-char (+ start tar-chk-offset))
- (delete-region (point) (+ (point) 8))
- (insert (format "%6o" chk))
- (insert 0)
- (insert ? )
- (tar-setf (tar-header-checksum tokens) chk)
- ;;
- ;; ok, make sure we didn't botch it.
- (check-tar-header-block-checksum
- (buffer-substring start (+ start 512))
- chk (tar-header-name tokens))
- )))
- (narrow-to-region 1 tar-header-offset))))
-
-
-(defun tar-subfile-save-buffer ()
- "In tar subfile mode, write this buffer back into its parent tar-file buffer.
-This doesn't write anything to disk - you must save the parent tar-file buffer
-to make your changes permanent."
- (interactive)
- (if (not (and (boundp 'superior-tar-buffer) superior-tar-buffer))
- (error "this buffer has no superior tar file buffer."))
- (if (not (and (boundp 'superior-tar-descriptor) superior-tar-descriptor))
- (error "this buffer doesn't have an index into its superior tar file!"))
- (save-excursion
- (let ((subfile (current-buffer))
- (subfile-size (buffer-size))
- (descriptor superior-tar-descriptor))
- (set-buffer superior-tar-buffer)
- (let* ((tokens (tar-desc-tokens descriptor))
- (start (tar-desc-data-start descriptor))
- (name (tar-header-name tokens))
- (size (tar-header-size tokens))
- (size-pad (ash (ash (+ size 511) -9) 9))
- (head (memq descriptor tar-parse-info))
- (following-descs (cdr head)))
- (if (not head)
- (error "Can't find this tar file entry in its parent tar file!"))
- (unwind-protect
- (save-excursion
- (widen)
- ;; delete the old data...
- (let* ((data-start (+ start tar-header-offset -1))
- (data-end (+ data-start (ash (ash (+ size 511) -9) 9))))
- (delete-region data-start data-end)
- ;; insert the new data...
- (goto-char data-start)
- (insert-buffer subfile)
- ;;
- ;; pad the new data out to a multiple of 512...
- (let ((subfile-size-pad (ash (ash (+ subfile-size 511) -9) 9)))
- (goto-char (+ data-start subfile-size))
- (insert (make-string (- subfile-size-pad subfile-size) 0))
- ;;
- ;; update the data pointer of this and all following files...
- (tar-setf (tar-header-size tokens) subfile-size)
- (let ((difference (- subfile-size-pad size-pad)))
- (tar-dolist (desc following-descs)
- (tar-setf (tar-desc-data-start desc)
- (+ (tar-desc-data-start desc) difference))))
- ;;
- ;; Update the size field in the header block.
- (let ((header-start (- data-start 512)))
- (goto-char (+ header-start tar-size-offset))
- (delete-region (point) (+ (point) 12))
- (insert (format "%11o" subfile-size))
- (insert ? )
- ;;
- ;; Maybe update the datestamp.
- (if (not tar-update-datestamp)
- nil
- (goto-char (+ header-start tar-time-offset))
- (delete-region (point) (+ (point) 12))
- (insert (format "%11o" 0)) ; ## oops - how to get it??
- (insert ? ))
- ;;
- ;; compute a new checksum and insert it.
- (let ((chk (checksum-tar-header-block
- (buffer-substring header-start data-start))))
- (goto-char (+ header-start tar-chk-offset))
- (delete-region (point) (+ (point) 8))
- (insert (format "%6o" chk))
- (insert 0)
- (insert ? )
- (tar-setf (tar-header-checksum tokens) chk)))
- ;;
- ;; alter the descriptor-line...
- ;;
- (let ((position (- (length tar-parse-info) (length head))))
- (goto-char 1)
- (next-line position)
- (beginning-of-line)
- (let ((p (point))
- (m (set-marker (make-marker) tar-header-offset)))
- (forward-line 1)
- (delete-region p (point))
- (insert-before-markers (summarize-tar-header-block tokens t) "\n")
- (setq tar-header-offset (marker-position m)))
- )))
- ;; after doing the insertion, add any final padding that may be necessary.
- (tar-pad-to-blocksize))
- (narrow-to-region 1 tar-header-offset)))
- (set-buffer-modified-p t) ; mark the tar file as modified
- (set-buffer subfile)
- (set-buffer-modified-p nil) ; mark the tar subfile as unmodified
- (message "saved into tar-buffer \"%s\" - remember to save that buffer!"
- (buffer-name superior-tar-buffer))
- )))
-
-
-(defun tar-pad-to-blocksize ()
- "If we are being anal about tar file blocksizes, fix up the current buffer.
-Leaves the region wide."
- (if (null tar-anal-blocksize)
- nil
- (widen)
- (let* ((last-desc (nth (1- (length tar-parse-info)) tar-parse-info))
- (start (tar-desc-data-start last-desc))
- (tokens (tar-desc-tokens last-desc))
- (link-p (tar-header-link-type tokens))
- (size (if link-p 0 (tar-header-size tokens)))
- (data-end (+ start size))
- (bbytes (ash tar-anal-blocksize 9))
- (pad-to (+ bbytes (* bbytes (/ (1- data-end) bbytes))))
- (buffer-read-only nil) ; ##
- )
- ;; If the padding after the last data is too long, delete some;
- ;; else insert some until we are padded out to the right number of blocks.
- ;;
- (goto-char (+ (or tar-header-offset 0) data-end))
- (if (> (1+ (buffer-size)) (+ (or tar-header-offset 0) pad-to))
- (delete-region (+ (or tar-header-offset 0) pad-to) (1+ (buffer-size)))
- (insert (make-string (- (+ (or tar-header-offset 0) pad-to)
- (1+ (buffer-size)))
- 0)))
- )))
-
-
-(defun maybe-write-tar-file ()
- "Used as a write-file-hook to write tar-files out correctly."
- ;;
- ;; If the current buffer is in tar-mode and has its header-offset set,
- ;; only write out the part of the file after the header-offset.
- ;;
- (if (and (eq major-mode 'tar-mode)
- (and (boundp 'tar-header-offset) tar-header-offset))
- (unwind-protect
- (save-excursion
- (tar-clear-modification-flags)
- (widen)
- ;; Doing this here confuses things - the region gets left too wide!
- ;; I suppose this is run in a context where changing the buffer is bad.
- ;; (tar-pad-to-blocksize)
- (write-region tar-header-offset (1+ (buffer-size)) buffer-file-name nil t)
- ;; return T because we've written the file.
- t)
- (narrow-to-region 1 tar-header-offset)
- t)
- ;; return NIL because we haven't.
- nil))
-
-
-;;; Patch it in.
-
-(defvar tar-regexp "\\.tar$"
- "The regular expression used to identify tar file names.")
-
-(setq auto-mode-alist
- (cons (cons tar-regexp 'tar-mode) auto-mode-alist))
-
-(or (boundp 'write-file-hooks) (setq write-file-hooks nil))
-(or (listp write-file-hooks)
- (setq write-file-hooks (list write-file-hooks)))
-(or (memq 'maybe-write-tar-file write-file-hooks)
- (setq write-file-hooks
- (cons 'maybe-write-tar-file write-file-hooks)))
-
-
-;;; This is a hack. For files ending in .tar, we want -*- lines to be
-;;; completely ignored - if there is one, it applies to the first file
-;;; in the archive, and not the archive itself!
-
-(defun tar-normal-mode (&optional find-file)
- "Choose the major mode for this buffer automatically.
-Also sets up any specified local variables of the file.
-Uses the visited file name, the -*- line, and the local variables spec.
-
-This function is called automatically from `find-file'. In that case,
-if `inhibit-local-variables' is non-`nil' we require confirmation before
-processing a local variables spec. If you run `normal-mode' explicitly,
-confirmation is never required.
-
-Note that this version of this function has been hacked to interact
-correctly with tar files - when visiting a file which matches
-'tar-regexp', the -*- line and local-variables are not examined,
-as they would apply to a file within the archive rather than the archive
-itself."
- (interactive)
- (if (and buffer-file-name
- (string-match tar-regexp buffer-file-name))
- (tar-mode)
- (tar-real-normal-mode find-file)))
-
-
-(if (not (fboundp 'tar-real-normal-mode))
- (fset 'tar-real-normal-mode (symbol-function 'normal-mode)))
-(fset 'normal-mode 'tar-normal-mode)
-
-(provide 'tar-mode)
-
diff --git a/lisp/telnet.el b/lisp/telnet.el
index 77939cf0dd1..2b55679e8e4 100644
--- a/lisp/telnet.el
+++ b/lisp/telnet.el
@@ -1,4 +1,4 @@
-;; Copyright (C) 1985, 1988 Free Software Foundation, Inc.
+;; Copyright (C) 1985 Free Software Foundation
;; This file is part of GNU Emacs.
@@ -16,42 +16,20 @@
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
;; Author William F. Schelter
;;to do fix software types for lispm:
;;to eval current expression. Also to try to send escape keys correctly.
;;essentially we'll want the rubout-handler off.
-;; filter is simplistic but should be okay for typical shell usage.
-;; needs hacking if it is going to deal with asynchronous output in a sane
-;; manner
-
-(require 'comint)
-(provide 'telnet)
-
(defvar telnet-new-line "\r")
(defvar telnet-mode-map nil)
(defvar telnet-prompt-pattern "^[^#$%>]*[#$%>] *")
+(defvar telnet-interrupt-string "\^c" "String sent by C-c.")
+(defvar telnet-count 0)
(defvar telnet-replace-c-g nil)
-(make-variable-buffer-local
- (defvar telnet-remote-echoes t
- "True if the telnet process will echo input."))
-(make-variable-buffer-local
- (defvar telnet-interrupt-string "\C-c" "String sent by C-c."))
-
-(defvar telnet-count 0
- "Number of output strings read from the telnet process
-while looking for the initial password.")
-
-(defvar telnet-initial-count -50
- "Initial value of telnet-count. Should be set to the negative of the
-number of terminal writes telnet will make setting up the host connection.")
-
-(defvar telnet-maximum-count 4
- "Maximum value telnet-count can have.
-After this many passes, we stop looking for initial setup data.
-Should be set to the number of terminal writes telnet will make
-rejecting one login and prompting for the again for a username and password.")
+(defvar telnet-remote-echoes nil)
(defun telnet-interrupt-subjob ()
(interactive)
@@ -60,7 +38,7 @@ rejecting one login and prompting for the again for a username and password.")
(defun telnet-c-z ()
(interactive)
- (send-string nil "\C-z"))
+ (send-string nil ""))
(defun send-process-next-char ()
(interactive)
@@ -70,30 +48,33 @@ rejecting one login and prompting for the again for a username and password.")
(prog1 (read-char)
(setq quit-flag nil))))))
-; initialization on first load.
-(if telnet-mode-map
- nil
- (setq telnet-mode-map (copy-keymap comint-mode-map))
+(setq telnet-mode-map (make-sparse-keymap))
+
+(progn
(define-key telnet-mode-map "\C-m" 'telnet-send-input)
-; (define-key telnet-mode-map "\C-j" 'telnet-send-input)
+ (define-key telnet-mode-map "\C-j" 'telnet-send-input)
+ (define-key telnet-mode-map "\C-c\C-d" 'shell-send-eof)
(define-key telnet-mode-map "\C-c\C-q" 'send-process-next-char)
(define-key telnet-mode-map "\C-c\C-c" 'telnet-interrupt-subjob)
- (define-key telnet-mode-map "\C-c\C-z" 'telnet-c-z))
+ (define-key telnet-mode-map "\C-c\C-z" 'telnet-c-z)
+ (define-key telnet-mode-map "\C-c\C-u" 'kill-shell-input)
+ (define-key telnet-mode-map "\C-c\C-w" 'backward-kill-word)
+ (define-key telnet-mode-map "\C-c\C-o" 'kill-output-from-shell)
+ (define-key telnet-mode-map "\C-c\C-r" 'show-output-from-shell))
;;maybe should have a flag for when have found type
(defun telnet-check-software-type-initialize (string)
"Tries to put correct initializations in. Needs work."
- (let ((case-fold-search t))
- (cond ((string-match "unix" string)
- (setq telnet-prompt-pattern comint-prompt-regexp)
+ (cond ((string-match "unix" string)
+ (setq telnet-prompt-pattern shell-prompt-pattern)
(setq telnet-new-line "\n"))
((string-match "tops-20" string) ;;maybe add telnet-replace-c-g
(setq telnet-prompt-pattern "[@>]*"))
((string-match "its" string)
(setq telnet-prompt-pattern "^[^*>]*[*>] *"))
((string-match "explorer" string) ;;explorer telnet needs work
- (setq telnet-replace-c-g ?\n))))
- (setq comint-prompt-regexp telnet-prompt-pattern))
+ (setq telnet-replace-c-g ?\n))
+ ))
(defun telnet-initial-filter (proc string)
;For reading up to and including password; also will get machine type.
@@ -105,76 +86,133 @@ rejecting one login and prompting for the again for a username and password.")
(let* ((echo-keystrokes 0)
(password (read-password)))
(setq telnet-count 0)
- (send-string proc (concat password telnet-new-line))))
+ (send-string proc (concat password telnet-new-line))))
(t (telnet-check-software-type-initialize string)
(telnet-filter proc string)
- (cond ((> telnet-count telnet-maximum-count)
+ (cond ((> telnet-count 4)
(set-process-filter proc 'telnet-filter))
(t (setq telnet-count (1+ telnet-count)))))))
(defun telnet-filter (proc string)
- (let ((at-end
- (and (eq (process-buffer proc) (current-buffer))
- (= (point) (point-max)))))
- (save-excursion
- (set-buffer (process-buffer proc))
- (goto-char (process-mark proc))
- (let ((now (point)))
- (let ((index 0) c-m)
- (while (setq c-m (string-match "\C-m" string index))
- (insert-before-markers (substring string index c-m))
- (setq index (1+ c-m)))
- (insert-before-markers (substring string index)))
- (and telnet-replace-c-g
- (subst-char-in-region now (point) ?\C-g telnet-replace-c-g)))
-; (if (and (integer-or-marker-p last-input-start)
-; (marker-position last-input-start)
-; telnet-remote-echoes)
-; (delete-region last-input-start last-input-end))
- )
- (if at-end
- (goto-char (point-max)))))
+ (save-excursion
+ (set-buffer (process-buffer proc))
+ (goto-char (point-max))
+ (let ((now (point)))
+ (insert string)
+ (subst-char-in-region now (point) ?\^m ?\ )
+ (and telnet-replace-c-g
+ (subst-char-in-region now (point) ?\^g telnet-replace-c-g)))
+ (if (process-mark proc)
+ (set-marker (process-mark proc) (point)))
+ (if (and (integer-or-marker-p last-input-start)
+ (marker-position last-input-start)
+ telnet-remote-echoes)
+ (delete-region last-input-start last-input-end)))
+ (if (eq (process-buffer proc)
+ (current-buffer))
+ (goto-char (point-max))))
+
+(defun delete-char-or-send-eof (arg killp)
+ "At end of buffer, send eof to subshell. Otherwise delete character."
+ (interactive "p\nP")
+ (if (and (eobp) (not killp))
+ (process-send-eof)
+ (delete-char arg killp)))
(defun telnet-send-input ()
- (interactive)
- (comint-send-input telnet-new-line telnet-remote-echoes))
+ "Send input to remote host
+At end of buffer, sends all text after last output
+as input to the telnet, including a telnet-new-line inserted at the end.
+Not at end, copies current line to the end of the buffer and sends it,
+after first attempting to discard any prompt at the beginning of the line
+by matching the regexp that is the value of telnet-prompt-pattern if possible."
+ (interactive)
+ (let (copied)
+ (end-of-line)
+ (if (eobp)
+ (progn
+ (move-marker last-input-start
+ (process-mark (get-buffer-process (current-buffer))))
+ (move-marker last-input-end (point)))
+ (beginning-of-line)
+ (re-search-forward telnet-prompt-pattern nil t)
+ (let ((copy (buffer-substring (point)
+ (progn (forward-line 1) (point)))))
+ (goto-char (point-max))
+ (move-marker last-input-start (point))
+ (insert copy) (setq copied t)
+ (move-marker last-input-end (point))))
+ (save-excursion
+ (goto-char last-input-start)
+ (let ((process (get-buffer-process (current-buffer))))
+ (send-region process last-input-start last-input-end)
+ (if (not copied) (send-string process telnet-new-line))
+ (set-marker (process-mark process) (point))))))
(defun telnet (arg)
"Open a network login connection to host named HOST (a string).
Communication with HOST is recorded in a buffer *HOST-telnet*.
Normally input is edited in Emacs and sent a line at a time."
(interactive "sOpen telnet connection to host: ")
+ (require 'shell)
(let ((name (concat arg "-telnet" )))
- (switch-to-buffer (make-comint name "telnet"))
+ (switch-to-buffer (make-shell name "telnet"))
(set-process-filter (get-process name) 'telnet-initial-filter)
+ (accept-process-output (get-process name))
(erase-buffer)
(send-string name (concat "open " arg "\n"))
(telnet-mode)
- (setq telnet-count telnet-initial-count)))
+ (setq telnet-count -16)))
+
+(defun read-password ()
+ (let ((answ "") tem)
+ (while (prog1 (not (memq (setq tem (read-char))
+ '(?\C-m ?\n ?\C-g)))
+ (setq quit-flag nil))
+ (setq answ (concat answ (char-to-string tem))))
+ answ))
(defun telnet-mode ()
"This mode is for use during telnet from a buffer to another
-host. It has most of the same commands as comint-mode.
-There is a variable ``telnet-interrupt-string'' which is the character
+host. It has most of the same commands as shell mode.
+There is a variable `telnet-interrupt-string' which is the character
sent to try to stop execution of a job on the remote host.
-Data is sent to the remote host when RET is typed.
-
+Data is sent to the remote host when `return' is typed.
+Thus if you may need to edit the data before sending you
+should use c-n to move down a line. Then you can return
+to alter a previous line. Of course you should not use this
+mode of telnet if you want to run emacs like programs on the
+remote host (at least not yet!).
+
+The following commands imitate the usual Unix interrupt and
+editing control characters:
\\{telnet-mode-map}
Bugs:
---Replaces by a space, really should remove."
+--Replace by a space, really should remove.
+--For Unix interacts poorly with tcsh although csh,sh,ksh are ok."
(interactive)
- (comint-mode)
- (setq major-mode 'telnet-mode
- mode-name "Telnet"
- comint-prompt-regexp telnet-prompt-pattern)
+ (kill-all-local-variables)
+ (setq major-mode 'telnet-mode)
+ (setq mode-name "Telnet")
+ (setq mode-line-process '(": %s"))
+ (make-local-variable 'last-input-start)
(use-local-map telnet-mode-map)
- (run-hooks 'telnet-mode-hook))
+ (let ((tem telnet-prompt-pattern))
+ (make-local-variable 'telnet-prompt-pattern)
+ (setq telnet-prompt-pattern tem))
+ (make-local-variable 'telnet-interrupt-string)
+ (setq telnet-interrupt-string "")
+ (make-local-variable 'telnet-new-line)
+ (setq telnet-new-line "\r")
+ (make-local-variable 'last-input-start)
+ (setq last-input-start (make-marker))
+ (make-local-variable 'last-input-end)
+ (setq last-input-end (make-marker))
+ (make-local-variable 'telnet-remote-echoes)
+ (setq telnet-remote-echoes t)
+ (make-local-variable 'telnet-replace-c-g)
+ (setq telnet-replace-c-g nil))
+
+
-(defun read-password ()
- (let ((answ "") tem)
- (message "Reading password...")
- (while (not (or (= (setq tem (read-char)) ?\^m)
- (= tem ?\n)))
- (setq answ (concat answ (char-to-string tem))))
- answ))
diff --git a/lisp/telnet.elc b/lisp/telnet.elc
new file mode 100644
index 00000000000..7daf74d9db9
--- /dev/null
+++ b/lisp/telnet.elc
Binary files differ
diff --git a/lisp/term-nasty.el b/lisp/term-nasty.el
deleted file mode 100644
index 86a4a1ec30e..00000000000
--- a/lisp/term-nasty.el
+++ /dev/null
@@ -1,21 +0,0 @@
-Some people used to be bothered by the following comments that were
-found in terminal.el. We decided they were distracting, and that it
-was better not to have them there. On the other hand, we didn't want
-to appear to be giving in to the pressure to censor obscenity that
-currently threatens freedom of speech and of the press in the US.
-So we decided to put the comments here.
-
-
-These comments were removed from te-losing-unix.
- ;(what lossage)
- ;(message "fucking-unix: %d" char)
-
-This was before te-process-output.
-;; fucking unix has -such- braindamaged lack of tty control...
-
-And about the need to handle output characters such as C-m, C-g, C-h
-and C-i even though the termcap doesn't say they may be used:
-;fuck me harder
-;again and again!
-;wa12id!!
-;(spiked) \ No newline at end of file
diff --git a/lisp/term/COPYING b/lisp/term/COPYING
new file mode 100644
index 00000000000..9a170375811
--- /dev/null
+++ b/lisp/term/COPYING
@@ -0,0 +1,249 @@
+
+ GNU GENERAL PUBLIC LICENSE
+ Version 1, February 1989
+
+ Copyright (C) 1989 Free Software Foundation, Inc.
+ 675 Mass Ave, Cambridge, MA 02139, USA
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+ Preamble
+
+ The license agreements of most software companies try to keep users
+at the mercy of those companies. By contrast, our General Public
+License is intended to guarantee your freedom to share and change free
+software--to make sure the software is free for all its users. The
+General Public License applies to the Free Software Foundation's
+software and to any other program whose authors commit to using it.
+You can use it for your programs, too.
+
+ When we speak of free software, we are referring to freedom, not
+price. Specifically, the General Public License is designed to make
+sure that you have the freedom to give away or sell copies of free
+software, that you receive source code or can get it if you want it,
+that you can change the software or use pieces of it in new free
+programs; and that you know you can do these things.
+
+ To protect your rights, we need to make restrictions that forbid
+anyone to deny you these rights or to ask you to surrender the rights.
+These restrictions translate to certain responsibilities for you if you
+distribute copies of the software, or if you modify it.
+
+ For example, if you distribute copies of a such a program, whether
+gratis or for a fee, you must give the recipients all the rights that
+you have. You must make sure that they, too, receive or can get the
+source code. And you must tell them their rights.
+
+ We protect your rights with two steps: (1) copyright the software, and
+(2) offer you this license which gives you legal permission to copy,
+distribute and/or modify the software.
+
+ Also, for each author's protection and ours, we want to make certain
+that everyone understands that there is no warranty for this free
+software. If the software is modified by someone else and passed on, we
+want its recipients to know that what they have is not the original, so
+that any problems introduced by others will not reflect on the original
+authors' reputations.
+
+ The precise terms and conditions for copying, distribution and
+modification follow.
+
+ GNU GENERAL PUBLIC LICENSE
+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+ 0. This License Agreement applies to any program or other work which
+contains a notice placed by the copyright holder saying it may be
+distributed under the terms of this General Public License. The
+"Program", below, refers to any such program or work, and a "work based
+on the Program" means either the Program or any work containing the
+Program or a portion of it, either verbatim or with modifications. Each
+licensee is addressed as "you".
+
+ 1. You may copy and distribute verbatim copies of the Program's source
+code as you receive it, in any medium, provided that you conspicuously and
+appropriately publish on each copy an appropriate copyright notice and
+disclaimer of warranty; keep intact all the notices that refer to this
+General Public License and to the absence of any warranty; and give any
+other recipients of the Program a copy of this General Public License
+along with the Program. You may charge a fee for the physical act of
+transferring a copy.
+
+ 2. You may modify your copy or copies of the Program or any portion of
+it, and copy and distribute such modifications under the terms of Paragraph
+1 above, provided that you also do the following:
+
+ a) cause the modified files to carry prominent notices stating that
+ you changed the files and the date of any change; and
+
+ b) cause the whole of any work that you distribute or publish, that
+ in whole or in part contains the Program or any part thereof, either
+ with or without modifications, to be licensed at no charge to all
+ third parties under the terms of this General Public License (except
+ that you may choose to grant warranty protection to some or all
+ third parties, at your option).
+
+ c) If the modified program normally reads commands interactively when
+ run, you must cause it, when started running for such interactive use
+ in the simplest and most usual way, to print or display an
+ announcement including an appropriate copyright notice and a notice
+ that there is no warranty (or else, saying that you provide a
+ warranty) and that users may redistribute the program under these
+ conditions, and telling the user how to view a copy of this General
+ Public License.
+
+ d) You may charge a fee for the physical act of transferring a
+ copy, and you may at your option offer warranty protection in
+ exchange for a fee.
+
+Mere aggregation of another independent work with the Program (or its
+derivative) on a volume of a storage or distribution medium does not bring
+the other work under the scope of these terms.
+
+ 3. You may copy and distribute the Program (or a portion or derivative of
+it, under Paragraph 2) in object code or executable form under the terms of
+Paragraphs 1 and 2 above provided that you also do one of the following:
+
+ a) accompany it with the complete corresponding machine-readable
+ source code, which must be distributed under the terms of
+ Paragraphs 1 and 2 above; or,
+
+ b) accompany it with a written offer, valid for at least three
+ years, to give any third party free (except for a nominal charge
+ for the cost of distribution) a complete machine-readable copy of the
+ corresponding source code, to be distributed under the terms of
+ Paragraphs 1 and 2 above; or,
+
+ c) accompany it with the information you received as to where the
+ corresponding source code may be obtained. (This alternative is
+ allowed only for noncommercial distribution and only if you
+ received the program in object code or executable form alone.)
+
+Source code for a work means the preferred form of the work for making
+modifications to it. For an executable file, complete source code means
+all the source code for all modules it contains; but, as a special
+exception, it need not include source code for modules which are standard
+libraries that accompany the operating system on which the executable
+file runs, or for standard header files or definitions files that
+accompany that operating system.
+
+ 4. You may not copy, modify, sublicense, distribute or transfer the
+Program except as expressly provided under this General Public License.
+Any attempt otherwise to copy, modify, sublicense, distribute or transfer
+the Program is void, and will automatically terminate your rights to use
+the Program under this License. However, parties who have received
+copies, or rights to use copies, from you under this General Public
+License will not have their licenses terminated so long as such parties
+remain in full compliance.
+
+ 5. By copying, distributing or modifying the Program (or any work based
+on the Program) you indicate your acceptance of this license to do so,
+and all its terms and conditions.
+
+ 6. Each time you redistribute the Program (or any work based on the
+Program), the recipient automatically receives a license from the original
+licensor to copy, distribute or modify the Program subject to these
+terms and conditions. You may not impose any further restrictions on the
+recipients' exercise of the rights granted herein.
+
+ 7. The Free Software Foundation may publish revised and/or new versions
+of the General Public License from time to time. Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+Each version is given a distinguishing version number. If the Program
+specifies a version number of the license which applies to it and "any
+later version", you have the option of following the terms and conditions
+either of that version or of any later version published by the Free
+Software Foundation. If the Program does not specify a version number of
+the license, you may choose any version ever published by the Free Software
+Foundation.
+
+ 8. If you wish to incorporate parts of the Program into other free
+programs whose distribution conditions are different, write to the author
+to ask for permission. For software which is copyrighted by the Free
+Software Foundation, write to the Free Software Foundation; we sometimes
+make exceptions for this. Our decision will be guided by the two goals
+of preserving the free status of all derivatives of our free software and
+of promoting the sharing and reuse of software generally.
+
+ NO WARRANTY
+
+ 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
+REPAIR OR CORRECTION.
+
+ 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGES.
+
+ END OF TERMS AND CONDITIONS
+
+ Appendix: How to Apply These Terms to Your New Programs
+
+ If you develop a new program, and you want it to be of the greatest
+possible use to humanity, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these
+terms.
+
+ To do so, attach the following notices to the program. It is safest to
+attach them to the start of each source file to most effectively convey
+the exclusion of warranty; and each file should have at least the
+"copyright" line and a pointer to where the full notice is found.
+
+ <one line to give the program's name and a brief idea of what it does.>
+ Copyright (C) 19yy <name of author>
+
+ This program 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 1, or (at your option)
+ any later version.
+
+ This program 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 this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+Also add information on how to contact you by electronic and paper mail.
+
+If the program is interactive, make it output a short notice like this
+when it starts in an interactive mode:
+
+ Gnomovision version 69, Copyright (C) 19xx name of author
+ Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+ This is free software, and you are welcome to redistribute it
+ under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the
+appropriate parts of the General Public License. Of course, the
+commands you use may be called something other than `show w' and `show
+c'; they could even be mouse-clicks or menu items--whatever suits your
+program.
+
+You should also get your employer (if you work as a programmer) or your
+school, if any, to sign a "copyright disclaimer" for the program, if
+necessary. Here a sample; alter the names:
+
+ Yoyodyne, Inc., hereby disclaims all copyright interest in the
+ program `Gnomovision' (a program to direct compilers to make passes
+ at assemblers) written by James Hacker.
+
+ <signature of Ty Coon>, 1 April 1989
+ Ty Coon, President of Vice
+
+That's all there is to it!
diff --git a/lisp/term/apollo.el b/lisp/term/apollo.el
new file mode 100644
index 00000000000..3b75d654c50
--- /dev/null
+++ b/lisp/term/apollo.el
@@ -0,0 +1 @@
+(load "term/vt100")
diff --git a/lisp/term/at386.el b/lisp/term/at386.el
new file mode 100644
index 00000000000..65848affb74
--- /dev/null
+++ b/lisp/term/at386.el
@@ -0,0 +1,101 @@
+;;; Dell 325D (UNIX SVR4) as AT386 UNIX PC keyboard definitions
+;;; Based on Brant Cheikes (brant@linc.cis.upenn.edu, manta!brant)
+;;; unixpc.el.
+;;;
+;;; Mark J. Hewitt (mjh@uk.co.kernel)
+;;; 8-apr-91
+;;;
+;;; The AT386 keyboard mapping has three types of prefix keys:
+;;;
+;;; <esc> [ for cursor positioning and keypad
+;;; <esc> O for function keys
+;;; <esc> N for ALT keys
+;;;
+;;; *NOTE* Care is required when using ALT bound as a simple META key.
+;;; It works for most normal key sequences, but some ALT-CTRL
+;;; (aka M-C-x) are intercepted locally. F'rinstance M-C-d would
+;;; break to the kernel debugger, kdb (!).
+;;;
+
+(require 'keypad) ; for keypad-defaults
+
+(defvar Dell-map-1 nil
+ "The <esc>O keys (Function) on the Dell Unix PC.")
+(defvar Dell-map-3 nil
+ "The <esc>[ keys (Right-hand keypads) on the Dell Unix PC.")
+
+(defun enable-function-keys ()
+ "Enable the use of the keypad and function keys.
+Because of the nature of the PC keyboard under Unix,
+this unavoidably breaks a standard Emacs command (M-[);
+therefore, it is not done by default, but only if you give this command."
+ (interactive)
+ (global-set-key "\eO" Dell-map-1)
+ (global-set-key "\eN" 'ESC-prefix)
+ (global-set-key "\e[" Dell-map-3)
+)
+
+;;; Create a few new keypad defaults.
+
+(keypad-default "5" 'set-mark-command)
+(keypad-default "I" 'yank)
+(keypad-default "x" 'call-last-kbd-macro)
+(keypad-default "\C-f" 'info)
+(keypad-default "\C-g" 'overwrite-mode)
+(keypad-default "\C-h" 'auto-fill-mode)
+(keypad-default "\C-i" 'abbrev-mode)
+(keypad-default "\C-j" 'browse-yank)
+; There are no definitions for these functions.
+;(keypad-default "\C-l" 'Dell-132)
+;(keypad-default "\C-m" 'Dell-80)
+(keypad-default "\C-n" 'scroll-other-window)
+(keypad-default "\C-o" 'other-window)
+(keypad-default "\C-p" 'repeat-complex-command)
+
+;; Now populate the maps, if they are enabled.
+
+(if Dell-map-1
+ nil
+ (setq Dell-map-1 (make-keymap)) ; <ESC>O (function key) commands
+ (setup-terminal-keymap Dell-map-1
+ '(("P" . ??) ; F1 (help)
+ ("p" . ?\^f) ; Shift F1 (info)
+ ("Q" . ?\^g) ; F2 (overwrite-mode)
+ ("q" . ?\^g) ; Shift F2 (overwrite-mode)
+ ("R" . ?\^h) ; F3 (auto-fill-mode)
+ ("r" . ?\^h) ; Shift F3 (auto-fill-mode)
+ ("S" . ?\^i) ; F4 (abbrev-mode)
+ ("s" . ?\^i) ; Shift F4 (abbrev-mode)
+ ("T" . ?\^j) ; F5 (browse-yank)
+ ("t" . ?\^j) ; Shift F5 (browse-yank)
+ ("U" . ?\^l) ; F6 (Dell-132)
+ ("u" . ?\^m) ; Shift F6 (Dell-80)
+ ("V" . nil) ; F7
+ ("v" . nil) ; Shift F7
+ ("W" . ?\^n) ; F8 (scroll-other-window)
+ ("w" . ?\^o) ; Shift F8 (other-window)
+ ("X" . nil) ; F9
+ ("x" . nil) ; Shift F9
+ ("Y" . nil) ; F10
+ ("y" . nil) ; Shift F10
+ ("Z" . ?\^p) ; F11 (repeat-complex-command)
+ ("z" . ?\^p) ; Shift F11 (repeat-complex-command)
+ ("A" . ?x) ; F12 (call-last-kbd-macro)
+ ("a" . ?x) ; Shift F12 (call-last-kbd-macro)
+ )))
+
+(if Dell-map-3
+ nil
+ (setq Dell-map-3 (make-sparse-keymap)) ; <ESC>[ commands
+ (setup-terminal-keymap Dell-map-3
+ '(("A" . ?u) ; Up Arrow (previous-line)
+ ("B" . ?d) ; Down Arrow (next-line)
+ ("C" . ?r) ; Right Arrow (forward-char)
+ ("D" . ?l) ; Left Arrow (backward-char)
+ ("H" . ?\^a) ; Home (beginning-of-line)
+ ("Y" . ?\^b) ; End (end-of-line)
+ ("@" . ?I) ; Insert (yank)
+ ("U" . ?N) ; Page Up (scroll-up)
+ ("V" . ?P) ; Shift-Page (scroll-down)
+ ("G" . ?5) ; pad 5 (set-mark-command)
+ )))
diff --git a/lisp/term/bbn.el b/lisp/term/bbn.el
new file mode 100644
index 00000000000..9affcc21281
--- /dev/null
+++ b/lisp/term/bbn.el
@@ -0,0 +1 @@
+(load (concat term-file-prefix "bg") nil t)
diff --git a/lisp/term/bg.el b/lisp/term/bg.el
new file mode 100644
index 00000000000..c1b98910861
--- /dev/null
+++ b/lisp/term/bg.el
@@ -0,0 +1,6 @@
+;; BBN bitgraph terminal.
+
+(load (concat term-file-prefix "vt100") nil t) ;BG keyboard is VT100 clone
+(autoload 'bg-mouse-report "bg-mouse")
+(global-set-key "\e:" 'bg-mouse-report)
+(send-string-to-terminal "\e:0;7;;;360;512;9;16;9;16c")
diff --git a/lisp/term/bgnv.el b/lisp/term/bgnv.el
new file mode 100644
index 00000000000..9affcc21281
--- /dev/null
+++ b/lisp/term/bgnv.el
@@ -0,0 +1 @@
+(load (concat term-file-prefix "bg") nil t)
diff --git a/lisp/term/bgrv.el b/lisp/term/bgrv.el
new file mode 100644
index 00000000000..9affcc21281
--- /dev/null
+++ b/lisp/term/bgrv.el
@@ -0,0 +1 @@
+(load (concat term-file-prefix "bg") nil t)
diff --git a/lisp/term/bobcat.el b/lisp/term/bobcat.el
new file mode 100644
index 00000000000..7abe538ef77
--- /dev/null
+++ b/lisp/term/bobcat.el
@@ -0,0 +1,11 @@
+;;; HP terminals usually encourage using ^H as the rubout character
+
+(let ((the-table (make-string 128 0)))
+ (let ((i 0))
+ (while (< i 128)
+ (aset the-table i i)
+ (setq i (1+ i))))
+ ;; Swap ^H and DEL
+ (aset the-table ?\177 ?\^h)
+ (aset the-table ?\^h ?\177)
+ (setq keyboard-translate-table the-table))
diff --git a/lisp/term/news.el b/lisp/term/news.el
deleted file mode 100644
index 16b79e291c9..00000000000
--- a/lisp/term/news.el
+++ /dev/null
@@ -1,85 +0,0 @@
-;; keypad and function key bindings for the Sony NEWS keyboard.
-;; Copyright (C) 1989 Free Software Foundation, Inc.
-
-;; This file is part of GNU Emacs.
-
-;; 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.
-
-;; This file effects a mapping from the raw escape sequences of various
-;; keypad and function keys to the symbols used by emacs to represent
-;; those keys. The mapping from key symbol to the function performed
-;; when that key is pressed is handled keyboard-independently by the file
-;; ../keypad.el.
-
-;; Note that his file is also used under X11. For this to work, the variable
-;; names must not change from keyboard file to keyboard file, nor can the
-;; structure of keypad-maps change.
-
-(require 'keypad)
-
-(defvar keypads nil
- "Keypad and function keys keymap for Sony News machine.")
-
-(defvar keypad-maps nil
- "A list of strings sent by the keypad and function keys on the Sony News.
-There is an element for each unique prefix. Each element is of the form
-(PREFIX map map ...), each map being (string . symbol).")
-
-(setq keypad-maps '(("\eO"
- ("P" . function-1)
- ("Q" . function-2)
- ("R" . function-3)
- ("S" . function-4)
- ("T" . function-5)
- ("U" . function-6)
- ("V" . function-7)
- ("W" . function-8)
- ("X" . function-9)
- ("Y" . function-10)
-
- ("m" . keypad-subtract)
- ("k" . keypad-add)
- ("l" . keypad-comma)
- ("n" . keypad-period)
- ("M" . keypad-enter)
-
- ("p" . keypad-0)
- ("q" . keypad-1)
- ("r" . keypad-2)
- ("s" . keypad-3)
- ("t" . keypad-4)
- ("u" . keypad-5)
- ("v" . keypad-6)
- ("w" . keypad-7)
- ("x" . keypad-8)
- ("y" . keypad-9)
-
- ; These three strings are just made up.
- ("a" . execute) ; enter
- ("b" . select) ; nfer
- ("c" . cancel)))) ; xfer
-
-(let ((pads keypad-maps))
- (while pads
- (unwind-protect
- (let* ((prefix (car (car pads)))
- (stringmap (cdr (car pads)))
- (padmap (if (lookup-key global-map prefix)
- (error "Keymap entry for keypad prefix already exisists")
- (make-sparse-keymap))))
- (define-key global-map prefix padmap)
- (setup-terminal-keymap padmap stringmap))
- (setq pads (cdr pads)))))
diff --git a/lisp/term/s4.el b/lisp/term/s4.el
new file mode 100644
index 00000000000..ab81a3bd7c9
--- /dev/null
+++ b/lisp/term/s4.el
@@ -0,0 +1,142 @@
+;; Map s4 function key escape sequences
+;; into the standard slots in function-keymap where we can;
+;; set up terminal-specific bindings where we must
+;;
+;; by: Eric S. Raymond, eric@snark.thyrsus.com
+
+(require 'keypad)
+
+;; First, map as many keys as possible to terminal-independent keycaps
+
+(defvar META-RB-map nil
+ "The META-RB-map maps the ESC-[ function keys on the s4 keyboard.")
+
+(if (not META-RB-map)
+ (progn
+ (setq META-RB-map (lookup-key global-map "\e["))
+ (if (not (keymapp META-RB-map))
+ (setq META-RB-map (make-sparse-keymap))) ;; <ESC>[ commands
+
+ (setup-terminal-keymap META-RB-map
+ '(("A" . ?u) ; up arrow
+ ("B" . ?d) ; down-arrow
+ ("C" . ?r) ; right-arrow
+ ("D" . ?l) ; left-arrow
+ ("U" . ?N) ; 'Page' -> next page
+ ("V" . ?P) ; 'Shift-Page' -> prev page
+ ("H" . ?h) ; 'Home' -> home-key
+ ;; ("J" . ??) ; 'Clear' -> unmapped
+ ))))
+
+(defun enable-arrow-keys ()
+ "Enable the use of the s4 arrow keys for cursor motion.
+Because of the nature of the s4, this unavoidably breaks
+the standard Emacs command ESC [; therefore, it is not done by default,
+but only if you give this command in your .emacs."
+ (global-set-key "\e[" META-RB-map))
+
+(defvar META-N-map nil
+ "META-N-map maps the ESC-N function keys on the s4 keyboard.")
+
+(if (not META-N-map)
+ (progn
+
+ (setq META-N-map (lookup-key global-map "\eN"))
+ (if (not (keymapp META-N-map))
+ (setq META-N-map (make-sparse-keymap))) ;; <ESC>N commands
+ (setup-terminal-keymap META-N-map '(
+ ("a" . ?C) ; 'Rfrsh' -> redraw screen
+ ;; ("A" . ??) ; 'Clear' -> unmapped
+ ;; ("c" . ??) ; 'Move' -> unmapped
+ ;; ("d" . ??) ; 'Copy' -> unmapped
+ ;; ("B" . ??) ; 'Shift-Beg' -> unmapped
+ ;; ("M" . ??) ; 'Shift-Home' -> unmapped
+ ;; ("N" . ??) ; 'Shift-End' -> unmapped
+ ("e" . ?k) ; 'Dlete' -> generic delete (kill-region)
+ ("f" . ?.) ; 'Dlete Char' -> keypad .
+ ("g" . ?1) ; 'Prev' -> keypad 1 (backward-word)
+ ("h" . ?3) ; 'Next' -> keypad 3 (forward-word)
+ ("i" . ?s) ; 'Mark' -> select
+ ;; ("I" . ??) ; 'Select' -> MAPPED BELOW
+ ;; ("j" . ??) ; 'Input Mode' -> unmapped
+ ))
+
+ (define-key global-map "\eN" META-N-map)))
+
+(defvar META-O-map nil
+ "META-O-map maps the META-O function keys on the s4 keyboard.")
+
+(if (not META-O-map)
+ (progn
+
+ (setq META-O-map (lookup-key global-map "\eO"))
+ (if (not (keymapp META-O-map))
+ (setq META-O-map (make-sparse-keymap))) ;; <ESC>O commands
+ (setup-terminal-keymap META-O-map '(
+ ("a" . ?E) ; 'Clear-Line' -> Clear to EOL
+ ("A" . ?S) ; 'Shift-Clear-Line' -> Clear to EOS
+ ("b" . ?\C-@) ; 'Ref' -> function key 0
+ ("c" . ?\C-a) ; 'F1' -> function key 1
+ ("d" . ?\C-b) ; 'F2' -> function key 2
+ ("e" . ?\C-c) ; 'F3' -> function key 3
+ ("f" . ?\C-d) ; 'F4' -> function key 4
+ ("g" . ?\C-e) ; 'F5' -> function key 5
+ ("h" . ?\C-f) ; 'F6' -> function key 6
+ ("i" . ?\C-g) ; 'F7' -> function key 7
+ ("j" . ?\C-h) ; 'F8' -> function key 8
+ ;; ("k" . ??) ; 'Exit' -> MAPPED BELOW
+ ("m" . ??) ; 'Help' -> help-command
+ ;; ("n" . ??) ; 'Creat' -> unmapped
+ ;; ("o" . ??) ; 'Save' -> MAPPED BELOW
+ ;; ("r" . ??) ; 'Opts' -> unmapped
+ ;; ("s" . ??) ; 'Undo' -> MAPPED BELOW
+ ("t" . ?x) ; 'Redo' -> 'do' key
+ ;; ("u" . ??) ; 'Cmd' -> MAPPED BELOW
+ ;; ("v" . ??) ; 'Open' -> MAPPED BELOW
+ ;; ("V" . ??) ; 'Close' -> unmapped
+ ;; ("w" . ??) ; 'Cancel' -> MAPPED BELOW
+ ("x" . ?f) ; 'Find' -> find/replace
+ ;; ("y" . ??) ; 'Rplac' -> MAPPED BELOW
+ ;; ("z" . ??) ; 'Print' -> MAPPED BELOW
+ ))
+
+ (define-key global-map "\eO" META-O-map)))
+
+(defvar META-P-map nil
+ "META-P-map maps the META-P function keys on the s4 keyboard.")
+
+(if (not META-P-map)
+ (progn
+
+ (setq META-P-map (lookup-key global-map "\eP"))
+ (if (not (keymapp META-P-map))
+ (setq META-P-map (make-sparse-keymap))) ;; <ESC>P commands
+ (setup-terminal-keymap META-P-map '(
+ ("a" . ?1) ; Ctrl-1 -> keypad 1
+ ("b" . ?2) ; Ctrl-2 -> keypad 2
+ ("c" . ?3) ; Ctrl-3 -> keypad 3
+ ("d" . ?4) ; Ctrl-4 -> keypad 4
+ ("e" . ?5) ; Ctrl-5 -> keypad 5
+ ("f" . ?6) ; Ctrl-6 -> keypad 6
+ ("g" . ?7) ; Ctrl-7 -> keypad 7
+ ("h" . ?8) ; Ctrl-8 -> keypad 8
+ ("i" . ?9) ; Ctrl-9 -> keypad 9
+ ("j" . ?0) ; Ctrl-0 -> keypad 0
+ ("k" . ?-) ; Ctrl-- -> keypad -
+ ))
+
+ (define-key global-map "\eP" META-P-map)))
+
+;; Now do terminal-specific mappings of keys with no standard-keycap equivalent
+
+;;;(define-key esc-map "9" 'beginning-of-buffer) ;'Begin'
+;;;(define-key esc-map "0" 'end-of-buffer) ;'End'
+(define-key META-N-map "I" 'narrow-to-region) ;'Select'
+(define-key META-O-map "k" 'save-buffers-kill-emacs) ;'Exit'
+(define-key META-O-map "o" 'save-buffer) ;'Save'
+(define-key META-O-map "s" 'undo) ;'Undo'
+(define-key META-O-map "u" 'execute-extended-command) ;'Cmd'
+(define-key META-O-map "v" 'find-file) ;'Open'
+(define-key META-O-map "w" 'keyboard-quit) ;'Cancl'
+(define-key META-O-map "y" 'replace-regexp) ;'Rplac'
+(define-key META-O-map "z" 'lpr-buffer) ;'Print'
diff --git a/lisp/term/sun.el b/lisp/term/sun.el
new file mode 100644
index 00000000000..171bc1c4488
--- /dev/null
+++ b/lisp/term/sun.el
@@ -0,0 +1,333 @@
+;; keybinding for standard default sunterm keys
+;; Copyright (C) 1987 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;; Jeff Peck, Sun Microsystems Inc <peck@sun.com>
+;; Mar, 91 better integration with X windows
+
+(defun ignore-key ()
+ "interactive version of ignore"
+ (interactive)
+ (ignore))
+
+(defun unbound-key ()
+ "filler for compound keymaps"
+ (interactive)
+ (error "unbound-key"))
+
+(defun on-window-line-p (n)
+ (save-excursion
+ (beginning-of-line 1)
+ (let ((p (point)))
+ (move-to-window-line n)
+ (equal (point) p))))
+
+(defun scroll-down-in-place (n)
+ (interactive "p")
+ (if (on-window-line-p 0)
+ (progn (scroll-down n) (previous-line n))
+ (previous-line n) (scroll-down n)))
+
+(defun scroll-up-in-place (n)
+ (interactive "p")
+ (if (on-window-line-p -1)
+ (progn (scroll-up n) (next-line n))
+ (next-line n) (scroll-up n)))
+
+(defun kill-region-and-unmark (beg end)
+ "Like kill-region, but pops the mark [which equals point, anyway.]"
+ (interactive "r")
+ (kill-region beg end)
+ (setq this-command 'kill-region-and-unmark)
+ (set-mark-command t))
+
+(defun rerun-prev-command ()
+ "Repeat Previous-complex-command."
+ (interactive)
+ (eval (nth 0 command-history)))
+
+(defvar grep-arg nil "Default arg for RE-search")
+
+;; not sure this all works... or works at all...
+(defun search-command-arg ()
+ ;; if previous minibuf command specified a search string, return it.
+ ;; this way, a call to M-x re-search-forward can pass its arg.
+ (let* ((command (car command-history))
+ (command-name (symbol-name (car command)))
+ (search-arg (car (cdr command)))
+ (search-command
+ (and command-name (string-match "search" command-name))))
+ (and search-command (stringp search-arg) search-arg)))
+
+(defun grep-arg (&optional prompt)
+ "helper function used by research-{backward,forward}"
+ (if (memq last-command '(research-forward research-backward)) grep-arg
+ (let ((this-command this-command) ; save this binding from read-string
+ (default (or (search-command-arg)
+ search-last-regexp
+ grep-arg)))
+ (read-string (or prompt "Regexp arg: ") default))))
+
+(defun research-forward ()
+ "Repeat regexp search forward, using previous search arg if available."
+ (interactive) ;
+ (if (re-search-forward (grep-arg "Regexp search: "))
+ (setq search-last-regexp grep-arg)))
+
+(defun research-backward ()
+ "Repeat regexp search backward, using previous search arg if available."
+ (interactive) ;
+ (if (re-search-backward (grep-arg "Regexp search backward: "))
+ (setq search-last-regexp grep-arg)))
+
+(defun help-for-dummies ()
+ (interactive)
+ (let ((char ?\C-h))
+ (if (or (= char ?\C-h) (= char ??))
+ (save-window-excursion
+ (switch-to-buffer "*Help*")
+ (erase-buffer)
+ (insert (documentation 'help-for-help))
+ (goto-char (point-min))
+ (while (memq char '(?\C-h ?? ?\C-v ?\ ?\177 ?\M-v))
+ (if (memq char '(?\C-v ?\ ))
+ (scroll-up))
+ (if (memq char '(?\177 ?\M-v))
+ (scroll-down))
+ (message "A B C F I K L M N S T V W C-c C-d C-n C-w%s: "
+ (if (pos-visible-in-window-p (point-max))
+ "" " or Space to scroll"))
+ (let ((cursor-in-echo-area t))
+ (setq char (read-char))))))
+ (let ((defn (cdr (assq (downcase char) (cdr help-map)))))
+ (if defn (call-interactively defn) (ding)))))
+
+;;;
+;;; handle sun's extra function keys
+;;; this version for those who run with standard .ttyswrc and no emacstool
+;;;
+;;; sunview picks up expose and open on the way UP,
+;;; so we ignore them on the way down
+;;;
+
+;;; Since .emacs gets loaded before this file, a hook is supplied
+;;; for you to put your own bindings in. Example:
+;(setq sun-esc-bracket t)
+;(setq sun-raw-map-hooks '( ; not your usual hook list
+; (define-key sun-raw-map "211z" 'goto-line) ; R4
+; (define-key sun-raw-map "212z" 'other-window) ; R5
+; (define-key sun-raw-map "213z" 'scroll-other-window) ; R6
+; ))
+
+(defvar sun-esc-bracket nil
+ "*If non-nil, rebind ESC [ as prefix for Sun function keys.")
+
+(defvar sun-raw-map (make-sparse-keymap) "*Keymap for ESC-[ encoded keyboard")
+
+(define-key sun-raw-map "208z" 'unbound-key) ; R1
+(define-key sun-raw-map "209z" 'unbound-key) ; R2
+(define-key sun-raw-map "210z" 'backward-page) ; R3
+(define-key sun-raw-map "213z" 'forward-page) ; R6
+(define-key sun-raw-map "214z" 'beginning-of-buffer) ; R7
+(define-key sun-raw-map "216z" 'scroll-down) ; R9
+(define-key sun-raw-map "215z" 'previous-line) ; R8 (up-arrow)
+(define-key sun-raw-map "217z" 'backward-char) ; R10 (rt-arrow)
+(define-key sun-raw-map "219z" 'forward-char) ; R12 (dn-arrow)
+(define-key sun-raw-map "221z" 'next-line) ; R14 (lf-arrow)
+(define-key sun-raw-map "218z" 'recenter) ; R11
+(define-key sun-raw-map "220z" 'end-of-buffer) ; R13
+(define-key sun-raw-map "222z" 'scroll-up) ; R15
+(define-key sun-raw-map "193z" 'redraw-display) ; Again L1
+(define-key sun-raw-map "194z" 'list-buffers) ; Props L2
+(define-key sun-raw-map "195z" 'undo) ; Undo L3
+(define-key sun-raw-map "196z" 'ignore-key) ; Expose-down L4
+(define-key sun-raw-map "197z" 'sun-select-region) ; Put L5
+(define-key sun-raw-map "198z" 'ignore-key) ; Open-down L6
+(define-key sun-raw-map "199z" 'sun-yank-selection) ; Get L7
+(define-key sun-raw-map "200z" 'exchange-point-and-mark); Find L8
+(define-key sun-raw-map "201z" 'kill-region-and-unmark) ; Delete L9
+(define-key sun-raw-map "207z" 'help-for-help) ; Help Key on Type-4 KBD
+(define-key sun-raw-map "225z" 'toggle-selective-display); T2
+(define-key sun-raw-map "226z" 'scroll-down-in-place) ; T3
+(define-key sun-raw-map "227z" 'scroll-up-in-place) ; T4
+(define-key sun-raw-map "228z" 'shell) ; T5
+(define-key sun-raw-map "229z" 'shrink-window) ; T6
+(define-key sun-raw-map "230z" 'enlarge-window) ; T7
+
+(if sun-esc-bracket
+ (progn
+ (define-key esc-map "[" sun-raw-map) ; Install sun-raw-map
+ (define-key esc-map "[A" 'previous-line ) ; R8
+ (define-key esc-map "[B" 'next-line) ; R14
+ (define-key esc-map "[C" 'forward-char) ; R12
+ (define-key esc-map "[D" 'backward-char) ; R10
+ (define-key esc-map "[[" 'backward-paragraph) ; the original esc-[
+ ))
+
+;;; Since .emacs gets loaded before this file, a hook is supplied
+;;; for you to put your own bindings in.
+
+(defvar sun-raw-map-hooks nil
+ "List of forms to evaluate after setting sun-raw-map.
+This list is processed by: (mapcar 'eval sun-raw-map-hooks)")
+
+(mapcar 'eval sun-raw-map-hooks)
+
+;;; This section adds defintions for the emacstool users
+;;; emacstool event filter converts function keys to C-x*{c}{lrt}
+;;;
+;;; for example the Open key (L7) would be encoded as "\C-x*gl"
+;;; the control, meta, and shift keys modify the character {lrt}
+;;; note that (unshifted) C-l is ",", C-r is "2", and C-t is "4"
+;;;
+;;; {c} is [a-j] for LEFT, [a-i] for TOP, [a-o] for RIGHT.
+;;; A higher level insists on encoding {h,j,l,n}{r} (the arrow keys)
+;;; as ANSI escape sequences. Use the shell command
+;;; % setkeys noarrows
+;;; if you want these to come through for emacstool.
+;;;
+;;; If you are not using EmacsTool,
+;;; you can also use this by creating a .ttyswrc file to do the conversion.
+;;; but it won't include the CONTROL, META, or SHIFT keys!
+;;;
+
+;;; Note: al (STOP), el (EXPOSE) and gl (OPEN) are trapped by EmacsTool,
+;;; so they never make it here.
+
+(defvar meta-flag t)
+
+(defvar suntool-map (make-sparse-keymap)
+ "*Keymap for Emacstool bindings.")
+
+(define-key suntool-map "ar" 'unbound-key) ; R1
+(define-key suntool-map "br" 'unbound-key) ; R2
+(define-key suntool-map "hr" 'previous-line) ; R8 (up-arrow)
+(define-key suntool-map "jr" 'backward-char) ; R10 (rt-arrow)
+(define-key suntool-map "lr" 'forward-char) ; R12 (dn-arrow)
+(define-key suntool-map "nr" 'next-line) ; R14 (lf-arrow)
+(define-key suntool-map "gr" 'beginning-of-buffer) ; r7
+(define-key suntool-map "iR" 'backward-page) ; R9
+(define-key suntool-map "ir" 'scroll-down) ; r9
+(define-key suntool-map "kr" 'recenter) ; r11
+(define-key suntool-map "mr" 'end-of-buffer) ; r13
+(define-key suntool-map "oR" 'forward-page) ; R15
+(define-key suntool-map "or" 'scroll-up) ; r15
+(define-key suntool-map "b\M-L" 'rerun-prev-command) ; M-AGAIN
+(define-key suntool-map "b\M-l" 'repeat-complex-command); M-Again
+(define-key repeat-complex-command-map "\C-x*b\M-l" 'previous-complex-command)
+(define-key suntool-map "bl" 'redraw-display) ; Again L1
+(define-key suntool-map "cl" 'list-buffers) ; Props L2
+(define-key suntool-map "dl" 'undo) ; Undo L3
+(define-key suntool-map "el" 'ignore-key) ; Expose-Top L4
+(define-key suntool-map "fl" 'sun-select-region) ; Put L5
+(define-key suntool-map "f," 'copy-region-as-kill) ; C-Put L5
+(define-key suntool-map "gl" 'ignore-key) ; Open-Open L6
+(define-key suntool-map "hl" 'sun-yank-selection) ; Get L7
+(define-key suntool-map "h\M-l" 'sunview-yank-any-selection) ; M-Get L7
+(define-key suntool-map "h," 'yank) ; C-Get
+;; interactive regexp search ; Find L8
+(define-key suntool-map "iL" 're-isearch-forward) ; FIND (shift-Find)
+(define-key suntool-map "i\M-L" 're-isearch-backward) ; M-FIND (M-shift-Find)
+;; non-interactive versions:
+;; search again, using previous search arg as regexp.
+(define-key suntool-map "il" 'research-forward) ; Find
+(define-key suntool-map "i\M-l" 'research-backward) ; M-Find
+;; supply new arg
+(define-key suntool-map "i," 're-search-forward) ; C-Find
+(define-key suntool-map "i\M-," 're-search-backward) ; C-M-Find
+
+(define-key suntool-map "jL" 'yank) ; DELETE L9
+(define-key suntool-map "jl" 'kill-region-and-unmark) ; Delete
+(define-key suntool-map "j\M-l" 'exchange-point-and-mark); M-Delete
+(define-key suntool-map "j,"
+ '(lambda () (interactive) (pop-mark 1))) ; C-Delete
+(define-key suntool-map "pl" 'describe-mode) ; Help
+(define-key suntool-map "p\M-l" 'command-apropos) ; M-Help
+(define-key suntool-map "pL" 'describe-bindings) ; HELP
+;; Oops, Help is preempted by Xview, may need to modify xvetool
+(define-key suntool-map "p," 'help-for-help) ; C-Help
+(define-key suntool-map "p," 'help-for-dummies) ; C-Help
+
+(define-key suntool-map "bt" 'toggle-selective-display) ; t2
+(define-key suntool-map "cT" '(lambda(n) (interactive "p") (scroll-down n)))
+(define-key suntool-map "dT" '(lambda(n) (interactive "p") (scroll-up n)))
+(define-key suntool-map "ct" 'scroll-down-in-place) ; t3
+(define-key suntool-map "dt" 'scroll-up-in-place) ; t4
+(define-key suntool-map "et" 'shell) ; t5
+(define-key suntool-map "fT" 'shrink-window-horizontally) ; T6
+(define-key suntool-map "gT" 'enlarge-window-horizontally) ; T7
+(define-key suntool-map "ft" 'shrink-window) ; t6
+(define-key suntool-map "gt" 'enlarge-window) ; t7
+(define-key ctl-x-map "*" suntool-map)
+
+;;; Since .emacs gets loaded before this file, a hook is supplied
+;;; for you to put your own bindings in.
+
+;;; Example:
+;(setq suntool-map-hooks '( ; not your usual hook list
+; (define-key suntool-map "c\M-l" 'browse) ; Meta-Props
+; (define-key suntool-map "dr" 'goto-line) ; R4
+; (define-key suntool-map "d2" 'what-line) ; Control-R4
+; ))
+
+(defvar suntool-map-hooks nil
+ "List of forms to evaluate after setting suntool-map.
+This variable is processed by: (mapcar 'eval suntool-map-hooks)")
+
+(mapcar 'eval suntool-map-hooks)
+
+;;;
+;;; If running under emacstool, arrange to call suspend-emacstool
+;;; instead of suspend-emacs.
+;;;
+;;; First mouse blip is a clue that we are in emacstool.
+;;;
+;;; C-x C-@ is the mouse command prefix.
+
+(autoload 'sun-mouse-handler "sun-mouse"
+ "Sun Emacstool handler for mouse blips (not loaded)." t)
+
+(defun sun-mouse-once ()
+ "Converts to emacstool and sun-mouse-handler on first mouse hit."
+ (interactive)
+ (emacstool-init)
+ (sun-mouse-handler) ; Now, execute this mouse blip.
+ )
+(if (not window-system) ; don't do this for X!
+ (define-key ctl-x-map "\C-@" 'sun-mouse-once))
+
+(defun emacstool-init ()
+ "Set up Emacstool window, if you know you are in an emacstool."
+ ;; Make sure sun-mouse and sun-fns are loaded.
+ (require 'sun-fns)
+ (define-key ctl-x-map "\C-@" 'sun-mouse-handler)
+
+ (if (fboundp 'sun-window-init) ()
+ (error "SunWindows support not compiled in: #define HAVE_SUN_WINDOWS in config.h"))
+ (if (and (not (getenv "DISPLAY")) (< (sun-window-init) 0))
+ (message "Not a SunView Window"))
+ (progn
+ (substitute-key-definition 'suspend-emacs 'suspend-emacstool global-map)
+ (substitute-key-definition 'suspend-emacs 'suspend-emacstool esc-map)
+ (substitute-key-definition 'suspend-emacs 'suspend-emacstool ctl-x-map)
+ (send-string-to-terminal
+ (concat "\033]lEmacstool - GNU Emacs " emacs-version "\033\\")))
+ )
+
+;;; If Emacstool is being nice, and informs us of its presence:
+(if (getenv "IN_EMACSTOOL") (emacstool-init))
diff --git a/lisp/term/supdup.el b/lisp/term/supdup.el
new file mode 100644
index 00000000000..4e7ac2ab602
--- /dev/null
+++ b/lisp/term/supdup.el
@@ -0,0 +1,81 @@
+;; Losing unix doesn't know about the -real- control bit
+
+;; there should be some way to conditionalize this on the basis
+;; of %TOFCI -- except that the existing supdup server loses this information!
+;; It isn't clear-cut what to do in the server, as %tofci means that the user
+;; can generate full 9-bit MIT characters, which isn't what the `km' termcap
+;; flag means. On the other hand, being able to generate 8-bit characters
+;; (which is sort of what `km' is) isn't the same as %tofci.
+;; I think the problem is fundamental and cultural and irresolvable.
+
+;; unix supdup server uses 0237 as a control escape.
+;; c-a 001
+;; m-a 341
+;; c-m-a 201
+;; c-1 237 061
+;; m-1 261
+;; c-m-1 237 261
+;; c-m-_ 237 237
+
+(defvar supdup-control-map (make-keymap))
+(fillarray supdup-control-map 'ascii-loses)
+(defvar supdup-control-meta-map (make-keymap))
+(fillarray supdup-control-meta-map 'ascii-loses)
+(define-key supdup-control-meta-map "\C-_" nil) ; this is c-m-_
+(define-key supdup-control-map "\e" supdup-control-meta-map)
+(define-key global-map "\e\C-_" supdup-control-map)
+(let ((n ?0))
+ (while (<= n ?9)
+ (define-key supdup-control-map (char-to-string n) 'supdup-digit-argument)
+ (define-key supdup-control-meta-map (char-to-string n) 'supdup-digit-argument)
+ (setq n (1+ n)))
+ (define-key supdup-control-map "-" 'supdup-digit-argument)
+ (define-key supdup-control-meta-map "-" 'supdup-digit-argument))
+
+(defun ascii-loses ()
+ (interactive)
+ (if (= (aref (this-command-keys) 0) meta-prefix-char)
+ ;; loser typed <esc> c-_ <char>
+ (error "Undefined command: %s"
+ (mapconcat 'text-char-description (this-command-keys) " "))
+ ;; Get here from m-c-_ <char> for c-<char> or m-c-_ m-<char>
+ (error "Ascii loses: c-%s%c"
+ (if (> last-input-char ?\200) "m-" "")
+ (logand last-input-char ?\177))))
+
+
+(defun supdup-digit-argument (p)
+ (interactive "P")
+ (let ((n last-input-char))
+ (if (and (<= (+ ?\200 ?0) n) (<= n (+ ?\200 ?9)))
+ (setq n (- n ?\200)))
+ (cond ((or (= n ?-) (= n ?\M--))
+ (message "Arg: %s" (setq prefix-arg '-)))
+ ((or (< n ?0) (> n ?9))
+ (error "Lossage: %s" (this-command-keys)))
+ (t
+ (setq n (- n ?0))
+ (message "Arg: %d"
+ (setq prefix-arg
+ (cond ((listp p)
+ n)
+ ((eq p '-)
+ (- n))
+ ((>= p 0)
+ (+ (* p 10) n))
+ (t
+ (- (* p 10) n)))))))))
+
+;; Attempt to detect slimebollix machine serving as terminal.
+(if (let ((termcap (getenv "TERMCAP")))
+ (and termcap
+ (string-match ":co#131:li#52:\\|:co#135:li#50:" termcap)))
+ (message "In doing business with Symbolics, you are rewarding a wrong."))
+
+
+;; Mouse support works with Lambdas.
+;(autoload 'sup-mouse-report "sup-mouse"
+; "This command is sent by a special version of Supdup on the LMI Lambda
+;when the mouse is clicked." t)
+;(global-set-key "\C-x\C-@" 'sup-mouse-report)
+
diff --git a/lisp/term/unixpc.el b/lisp/term/unixpc.el
new file mode 100644
index 00000000000..3ebf4d25566
--- /dev/null
+++ b/lisp/term/unixpc.el
@@ -0,0 +1,148 @@
+;;; AT&T UnixPC keyboard definitions
+;;; Brant Cheikes (brant@linc.cis.upenn.edu, manta!brant)
+;;; 4 August 1987
+;;;
+;;; Tested on: GNU Emacs 18.47.1 of Fri Jul 24 1987 on manta (usg-unix-v)
+;;;
+;;; The AT&T Unix PC (aka PC7300, 3B1) has a bizarre keyboard with
+;;; lots of interestingly labeled function keys. This file tries to
+;;; assign useful actions to the function keys. Note that the Shift
+;;; and Ctrl keys have the same effect on function keys, so Shift-F1
+;;; is the same as Ctrl-F1.
+;;;
+;;; Most of the information needed to create this file was taken from
+;;; documentation found in lisp/keypad.el
+;;;
+;;; Bug: The "Beg" and "End" (unshifted) keys are not supported because
+;;; they generate <esc>9 and <esc>0 respectively, and I know not how to
+;;; deal with them.
+
+(require 'keypad)
+
+;;; There seem to be three prefixes for AT&T UnixPC function keys:
+;;; "<esc>O", "<esc>N", and "<esc>[". There seem to be a couple
+;;; keys that just generate "<esc><digit>".
+;;;
+;;; Note: for each mapping, I indicate the key on the Unix PC followed
+;;; by the Emacs command it is bound to (if any). Note that when I
+;;; couldn't figure out anything useful to do with a key, I simply bound
+;;; it to 'previous-line, arbitrarily. My goal was to get keys to do
+;;; "mnemonic" things.
+
+(defvar ATT-map-1 nil
+ "The bulk of the function keys on the AT&T Unix PC.")
+(defvar ATT-map-2 nil
+ "A few other random function keys on the AT&T Unix PC.")
+(defvar ATT-map-3 nil
+ "Some really random function keys on the AT&T Unix PC.")
+
+(defun enable-unixpc-keys ()
+ "Enable the use of the AT&T Unix PC function keys. Because of the
+nature of the Unix PC, this unavoidably breaks several standard Emacs
+prefixes; therefore, it is not done by default, but only if you give
+this command."
+ (interactive)
+ (global-set-key "\eO" ATT-map-1)
+ (global-set-key "\eN" ATT-map-2)
+ (global-set-key "\e[" ATT-map-3))
+
+;;; Create a few new keypad defaults. Here's what I think I'm doing here:
+;;; I look through "keypad.el" to find any unused entries in function-keymap
+;;; and then create my own bindings for them here. Then I use the newly
+;;; created ?x string in the setup-terminal-keymap.
+
+(keypad-default "2" 'advertised-undo)
+(keypad-default "4" 'save-buffers-kill-emacs)
+(keypad-default "5" 'save-buffer)
+(keypad-default "6" 'beginning-of-buffer)
+(keypad-default "8" 'end-of-buffer)
+(keypad-default "w" 'kill-word)
+(keypad-default "p" 'fill-paragraph)
+(keypad-default "," 'copy-region-as-kill)
+
+(if ATT-map-1
+ nil
+ (setq ATT-map-1 (make-keymap)) ; <ESC>O commands
+ (setup-terminal-keymap ATT-map-1
+ '(("a" . ?\^d) ; Clear Line (kill-line)
+ ("A" . ?\^d) ; Shift-Clear Line (kill-line)
+ ("b" . ?u) ; Ref
+ ("B" . ?u) ; Rstrt
+ ("c" . ?u) ; F1
+ ("d" . ?u) ; F2
+ ("e" . ?u) ; F3
+ ("f" . ?u) ; F4
+ ("g" . ?u) ; F5
+ ("h" . ?u) ; F6
+ ("i" . ?u) ; F7
+ ("j" . ?u) ; F8
+ ("k" . ?4) ; Exit (save-buffers-kill-emacs)
+ ("K" . ?4) ; Shift-Exit (save-buffers-kill-emacs)
+ ("m" . ??) ; Help (help-command)
+ ("M" . ??) ; Shift-Help (help-command)
+ ("n" . ?u) ; Creat
+ ("N" . ?u) ; Shift-Creat
+ ("o" . ?5) ; Save (save-buffer)
+ ("O" . ?5) ; Shift-Save (save-buffer)
+ ("r" . ?u) ; Opts
+ ("R" . ?u) ; Shift-Opts
+ ("s" . ?2) ; Undo (advertised-undo)
+ ("S" . ?2) ; Shift-Undo (advertised-undo)
+ ("t" . ?p) ; Redo (fill-paragraph)
+ ("T" . ?p) ; Shift-Redo (fill-paragraph)
+ ("u" . ?u) ; Cmd
+ ("U" . ?u) ; Shift-Cmd
+ ("v" . ?e) ; Open (open-line)
+ ("V" . ?\^d) ; Close (kill-line)
+ ("w" . ?u) ; Cancl
+ ("W" . ?u) ; Shift-Cancl
+ ("x" . ?\^c) ; Find (isearch-forward)
+ ("X" . ?f) ; Shift-Find (re-search-forward)
+ ("y" . ?0) ; Rplac (yank)
+ ("Y" . ?0) ; Shift-Rplac (yank)
+ ("z" . ?u) ; Print
+ )))
+
+(if ATT-map-2
+ nil
+ (setq ATT-map-2 (make-keymap)) ; <ESC>N commands
+ (setup-terminal-keymap ATT-map-2
+ '(("a" . ?C) ; Rfrsh (recenter)
+ ("B" . ?6) ; Shift-Beg (beginning-of-buffer)
+ ("c" . ?0) ; Move (yank)
+ ("C" . ?0) ; Shift-Move (yank)
+ ("d" . ?,) ; Copy (copy-region-as-kill)
+ ("D" . ?,) ; Shift-Copy (copy-region-as-kill)
+ ("e" . ?k) ; Dlete (kill-region)
+ ("E" . ?k) ; Shift-Dlete (kill-region)
+ ("f" . ?.) ; Dlete Char (delete-char)
+ ("F" . ?w) ; Shift-Dlete Char (kill-word)
+ ("g" . ?P) ; Prev (scroll-down)
+ ("G" . ?P) ; Shift-Prev (scroll-down)
+ ("h" . ?N) ; Next (scroll-up)
+ ("H" . ?N) ; Shift-Next (scroll-up)
+ ("i" . ?s) ; Mark (set-mark-command)
+ ("I" . ?s) ; Slect (set-mark-command)
+ ("j" . ?u) ; Input Mode
+ ("J" . ?u) ; Shift-Input Mode
+ ("K" . ?1) ; Shift-LeftArrow (backward-word)
+ ("L" . ?3) ; Shift-RightArrow (forward-word)
+ ("M" . ?h) ; Shift-Home (move-to-window-line)
+ ("N" . ?8) ; Shift-End (end-of-buffer)
+ )))
+
+(if ATT-map-3
+ nil
+ (setq ATT-map-3 (make-keymap)) ; <ESC>[ commands
+ (setup-terminal-keymap ATT-map-3
+ '(("A" . ?u) ; Up Arrow (previous-line)
+ ("B" . ?d) ; Down Arrow (next-line)
+ ("C" . ?r) ; Right Arrow (forward-char)
+ ("D" . ?l) ; Left Arrow (backward-char)
+ ("H" . ?h) ; Home (move-to-window-line)
+ ("J" . ?C) ; Clear (recenter)
+ ("S" . ?9) ; Shift-DownArrow (forward-paragraph)
+ ("T" . ?7) ; Shift-UpArrow (backward-paragraph)
+ ("U" . ?N) ; Page (scroll-up)
+ ("V" . ?P) ; Shift-Page (scroll-down)
+ )))
diff --git a/lisp/term/vt100.el b/lisp/term/vt100.el
new file mode 100644
index 00000000000..435157c9663
--- /dev/null
+++ b/lisp/term/vt100.el
@@ -0,0 +1,66 @@
+;; Map VT100 function key escape sequences
+;; into the standard slots in function-keymap.
+
+(require 'keypad)
+
+(defvar CSI-map nil
+ "The CSI-map maps the CSI function keys on the VT100 keyboard.
+The CSI keys are the arrow keys.")
+
+(if (not CSI-map)
+ (progn
+ (setq CSI-map (lookup-key global-map "\e["))
+ (if (not (keymapp CSI-map))
+ (setq CSI-map (make-sparse-keymap))) ;; <ESC>[ commands
+
+ (setup-terminal-keymap CSI-map
+ '(("A" . ?u) ; up arrow
+ ("B" . ?d) ; down-arrow
+ ("C" . ?r) ; right-arrow
+ ("D" . ?l))))) ; left-arrow
+
+(defun enable-arrow-keys ()
+ "Enable the use of the VT100 arrow keys for cursor motion.
+Because of the nature of the VT100, this unavoidably breaks
+the standard Emacs command ESC [; therefore, it is not done by default,
+but only if you give this command."
+ (interactive)
+ (global-set-key "\e[" CSI-map))
+
+(defvar SS3-map nil
+ "SS3-map maps the SS3 function keys on the VT100 keyboard.
+The SS3 keys are the numeric keypad keys in keypad application mode
+\(DECKPAM). SS3 is DEC's name for the sequence <ESC>O which is
+the common prefix of what these keys transmit.")
+
+(if (not SS3-map)
+ (progn
+
+ (setq SS3-map (lookup-key global-map "\eO"))
+ (if (not (keymapp SS3-map))
+ (setq SS3-map (make-keymap))) ;; <ESC>O commands
+ (setup-terminal-keymap SS3-map
+ '(("A" . ?u) ; up arrow
+ ("B" . ?d) ; down-arrow
+ ("C" . ?r) ; right-arrow
+ ("D" . ?l) ; left-arrow
+ ("M" . ?e) ; Enter
+ ("P" . ?\C-a) ; PF1
+ ("Q" . ?\C-b) ; PF2
+ ("R" . ?\C-c) ; PF3
+ ("S" . ?\C-d) ; PF4
+ ("l" . ?,) ; ,
+ ("m" . ?-) ; -
+ ("n" . ?.) ; .
+ ("p" . ?0) ; 0
+ ("q" . ?1) ; 1
+ ("r" . ?2) ; 2
+ ("s" . ?3) ; 3
+ ("t" . ?4) ; 4
+ ("u" . ?5) ; 5
+ ("v" . ?6) ; 6
+ ("w" . ?7) ; 7
+ ("x" . ?8) ; 8
+ ("y" . ?9))) ; 9
+
+ (define-key global-map "\eO" SS3-map)))
diff --git a/lisp/term/vt101.el b/lisp/term/vt101.el
new file mode 100644
index 00000000000..c35790b72c0
--- /dev/null
+++ b/lisp/term/vt101.el
@@ -0,0 +1 @@
+(load (concat term-file-prefix "vt100") nil t)
diff --git a/lisp/term/vt102.el b/lisp/term/vt102.el
new file mode 100644
index 00000000000..c35790b72c0
--- /dev/null
+++ b/lisp/term/vt102.el
@@ -0,0 +1 @@
+(load (concat term-file-prefix "vt100") nil t)
diff --git a/lisp/term/vt125.el b/lisp/term/vt125.el
new file mode 100644
index 00000000000..c35790b72c0
--- /dev/null
+++ b/lisp/term/vt125.el
@@ -0,0 +1 @@
+(load (concat term-file-prefix "vt100") nil t)
diff --git a/lisp/term/vt131.el b/lisp/term/vt131.el
new file mode 100644
index 00000000000..c35790b72c0
--- /dev/null
+++ b/lisp/term/vt131.el
@@ -0,0 +1 @@
+(load (concat term-file-prefix "vt100") nil t)
diff --git a/lisp/term/vt200.el b/lisp/term/vt200.el
index 162baecd7c1..a394de1cc3d 100644
--- a/lisp/term/vt200.el
+++ b/lisp/term/vt200.el
@@ -1,9 +1,85 @@
-(defun terminal-80-columns ()
- (interactive)
- (send-string-to-terminal "\033[?3l")
- (set-screen-width 80))
+;; vt200 series terminal stuff.
+;; April 1985, Joe Kelsey
+
+(require 'keypad)
-(defun terminal-132-columns ()
+(defvar CSI-map nil
+ "The CSI-map maps the CSI function keys on the VT200 keyboard.
+The CSI keys are the dark function keys, and are only active in
+VT200-mode, except for the arrow keys.")
+
+(defun enable-arrow-keys ()
+ "Enable the use of the VT200 arrow keys and dark function keys.
+Because of the nature of the VT200, this unavoidably breaks
+the standard Emacs command ESC [; therefore, it is not done by default,
+but only if you give this command."
(interactive)
- (send-string-to-terminal "\033[?3h")
- (set-screen-width 132))
+ (global-set-key "\e[" CSI-map))
+
+;; I suggest that someone establish standard mappings for all of
+;; the VT200 CSI function keys into the function-keymap.
+
+(if CSI-map
+ nil
+ (setq CSI-map (make-keymap)) ; <ESC>[ commands
+ (setup-terminal-keymap CSI-map
+ '(("A" . ?u) ; up arrow
+ ("B" . ?d) ; down-arrow
+ ("C" . ?r) ; right-arrow
+ ("D" . ?l) ; left-arrow
+ ("1~" . ?f) ; Find
+ ("2~" . ?I) ; Insert Here
+ ("3~" . ?k) ; Re-move
+ ("4~" . ?s) ; Select
+ ("5~" . ?P) ; Prev Screen
+ ("6~" . ?N) ; Next Screen
+ ("17~" . ?\C-f) ; F6
+ ("18~" . ?\C-g) ; F7
+ ("19~" . ?\C-h) ; F8
+ ("20~" . ?\C-i) ; F9
+ ("21~" . ?\C-j) ; F10
+ ("23~" . ESC-prefix) ; F11 (ESC)
+ ("24~" . ?\C-l) ; F12
+ ("25~" . ?\C-m) ; F13
+ ("26~" . ?\C-n) ; F14
+ ("31~" . ?\C-q) ; F17
+ ("32~" . ?\C-r) ; F18
+ ("33~" . ?\C-s) ; F19
+ ("34~" . ?\C-t) ; F20
+ ("28~" . ??) ; Help
+ ("29~" . ?x)))) ; Do
+
+(defvar SS3-map nil
+ "SS3-map maps the SS3 function keys on the VT200 keyboard.
+The SS3 keys are the numeric keypad keys in keypad application mode
+\(DECKPAM). SS3 is DEC's name for the sequence <ESC>O which is
+the common prefix of what these keys transmit.")
+
+(if SS3-map
+ nil
+ (setq SS3-map (make-keymap)) ; <ESC>O commands
+ (setup-terminal-keymap SS3-map
+ '(("A" . ?u) ; up arrow
+ ("B" . ?d) ; down-arrow
+ ("C" . ?r) ; right-arrow
+ ("D" . ?l) ; left-arrow
+ ("M" . ?e) ; Enter
+ ("P" . ?\C-a) ; PF1
+ ("Q" . ?\C-b) ; PF2
+ ("R" . ?\C-c) ; PF3
+ ("S" . ?\C-d) ; PF4
+ ("l" . ?,) ; ,
+ ("m" . ?-) ; -
+ ("n" . ?.) ; .
+ ("p" . ?0) ; 0
+ ("q" . ?1) ; 1
+ ("r" . ?2) ; 2
+ ("s" . ?3) ; 3
+ ("t" . ?4) ; 4
+ ("u" . ?5) ; 5
+ ("v" . ?6) ; 6
+ ("w" . ?7) ; 7
+ ("x" . ?8) ; 8
+ ("y" . ?9))) ; 9
+
+ (define-key global-map "\eO" SS3-map))
diff --git a/lisp/term/vt220.el b/lisp/term/vt220.el
new file mode 100644
index 00000000000..fdfa64d4f9d
--- /dev/null
+++ b/lisp/term/vt220.el
@@ -0,0 +1 @@
+(load (concat term-file-prefix "vt200") nil t)
diff --git a/lisp/term/vt240.el b/lisp/term/vt240.el
new file mode 100644
index 00000000000..fdfa64d4f9d
--- /dev/null
+++ b/lisp/term/vt240.el
@@ -0,0 +1 @@
+(load (concat term-file-prefix "vt200") nil t)
diff --git a/lisp/term/vt300.el b/lisp/term/vt300.el
new file mode 100644
index 00000000000..fdfa64d4f9d
--- /dev/null
+++ b/lisp/term/vt300.el
@@ -0,0 +1 @@
+(load (concat term-file-prefix "vt200") nil t)
diff --git a/lisp/term/wyse50.el b/lisp/term/wyse50.el
deleted file mode 100644
index 712e1062d00..00000000000
--- a/lisp/term/wyse50.el
+++ /dev/null
@@ -1,235 +0,0 @@
-; Like all the other files in this dir, this one needs to be redone
-; for the new way of handling function keys.
-
-; Terminal mode for Wyse 50
-; should work well for Televideo Tvi 925 though it's an overkill
-; Author Daniel Pfeiffer <pfeiffer@cix.cict.fr> january 1991
-
-(require 'keypad)
-
-; at least some of these should be transferred to keypad.el
-(keypad-default "A" '(lambda () (interactive)
- ; actually insert an empty line
- (beginning-of-line)
- (open-line 1)))
-(keypad-default "E" 'kill-line)
-; (keypad-default "h" 'execute-extended-command)
-(define-key function-keymap "h" 'execute-extended-command) ; bad, bad !!
-(keypad-default "H" 'shell-command)
-(keypad-default "I" '(lambda () (interactive)
- (insert ? ))) ; works even in overwrite-mode
-(keypad-default "L" '(lambda () (interactive)
- ; delete the whole line
- (beginning-of-line)
- (kill-line 1)))
-(keypad-default "M" 'overwrite-mode)
-(keypad-default "\^e" 'shell) ; F5
-(keypad-default "\^f" 'dired) ; F6
-(keypad-default "\^g" 'rnews) ; F7
-(keypad-default "\^h" 'rmail) ; F8
-
-(keypad-default "\^i" 'delete-other-windows) ; F9
-(keypad-default "\^j" 'other-window) ; F10
-(keypad-default "\^k" 'split-window-vertically) ; F11
-
-(keypad-default "\^m" 'help-for-help) ; F13
-(keypad-default "\^n" 'toggle-screen-width) ; F14
-(keypad-default "\^o" 'set-function-key) ; F15
-
-
-; Keys that don't conflict with Emacs defaults
-; I write \M-x and \C-x for what the user types, \ex and \^x for key sequences
-(setup-terminal-keymap global-map
- '(("\M-?" . ?\?) ; Esc ?
- ("\eI" . ?T) ; Shift Tab
- ("\eJ" . ?P) ; Shift Prev PAGE
- ("\eK" . ?N) ; PAGE Next
- ("\eY" . ?C) ; Shift Scrn CLR
- ("\eT" . ?E) ; CLR Line
- ("\^^" . ?h) ; Home
- ("\M-\^^" . ?H) ; Esc Home
- ("\eQ" . ?I) ; INS Char
- ("\eE" . ?A) ; Shift Line INS
- ("\eW" . ?D) ; DEL Char
- ("\eR" . ?L))) ; Shift Line DEL
-
-; Print -- put in some extra security
-(global-set-key "\eP" '(lambda () (interactive)
- (if (y-or-n-p
- (concat "Print buffer "
- (buffer-name) "? "))
- (print-buffer))))
-
-
-; this is an ugly hack for a nasty problem:
-; Wyse 50 takes one character cell to store video attributes (which seems to
-; explain width 79 rather than 80, column 1 is not used!!!).
-; On killing (C-x C-c) the end inverse code (on column 1 of line 24)
-; of the mode line is overwritten AFTER all the y-or-n questions.
-; This causes the attribute to remain in effect until the mode line has
-; scrolled of the screen. Suspending (C-z) does not cause this problem.
-; On such terminals, Emacs should sacrifice the first and last character of
-; each mode line, rather than a whole screen column!
-(setq kill-emacs-hook '(lambda () (interactive)
- (send-string-to-terminal
- (concat "\ea23R" (1+ (screen-width)) "C\eG0"))))
-
-
-; This function does more than its name which was copied from term/vt100.el
-; Some more neutral name should be used thru-out term/*.el to simplify
-; programming term-setup-hook
-(defun enable-arrow-keys ()
- "To be called by term-setup-hook. Overrides 6 Emacs standard keys
-whose functions are then typed as follows:
-C-a Funct left-arrow, C-a C-a
-C-h M-?
-LFD Funct Return, some modes override down-arrow via LFD
-C-k CLR Line
-C-l Shift Scrn CLR
-M-r M-x move-to-window-line, Funct up-arrow or down-arrow are similar
-All special keys except Send, Shift Ins, Shift Home and shifted functions keys
-are assigned some hopefully useful meaning."
- (interactive)
-
- ; Function keys
- (define-key global-map "\^a" (define-prefix-command 'Funct-prefix))
-
- ; Arrow keys
- (setup-terminal-keymap global-map
- '(("\C-a\C-a" . beginning-of-line) ; for auld lang syne
- ("\^a\^m\^m" . newline-and-indent)
-
- ("\^k" . ?u) ; up-arrow
- ("\^j" . ?d) ; down-arrow
- ("\^l" . ?r) ; right-arrow
- ("\^h" . ?l) ; left-arrow
-
- ; Terminal needs both Ins and Repl but Emacs knows how to toggle
- ; with just one key. No need to override Ins which is "\eq".
- ("\er" . ?M) ; Repl
-
- ("\^a\^i\^m" . ?t) ; Funct Tab
-
- ; Function keys F1 thru F16 (we don't define shifted function keys,
- ; they send the same code with the middle character in lowercase.
- ; eg. "Shift F2" is the same as "Funct a" which is more mnemonic but
- ; keypad.el doesn't provide enough codes to accomodate all these)
- ("\^a@\^m" . 1) ("\^aH\^m" . 9)
- ("\^aA\^m" . 2) ("\^aI\^m" . 10)
- ("\^aB\^m" . 3) ("\^aJ\^m" . 11)
- ("\^aC\^m" . 4) ("\^aK\^m" . 12)
- ("\^aD\^m" . 5) ("\^aL\^m" . 13)
- ("\^aE\^m" . 6) ("\^aM\^m" . 14)
- ("\^aF\^m" . 7) ("\^aN\^m" . 15)
- ("\^aG\^m" . 8) ("\^aO\^m" . 16)
-
- ; Funct Arrow keys
- ("\^a\^k\^m" . (lambda (n) (interactive "p")
- (move-to-window-line (1- n))))
- ("\^a\^j\^m" . (lambda (n) (interactive "p")
- (move-to-window-line (- n))))
- ("\^a\^h\^m" . beginning-of-line)
- ("\^a\^l\^m" . end-of-line)))
-
- ; forget self to put memory to some serious use
- (fmakunbound 'enable-arrow-keys))
-
-
-(defun toggle-screen-width ()
- "Alternate between 80 and 132 columns."
- (interactive)
- (if (<= (screen-width) 80)
- (progn
- (send-string-to-terminal "\e`;")
- (set-screen-width 131))
- (send-string-to-terminal "\e`:")
- (set-screen-width 79)))
-
-;-----------------------------------------------------------------------------
-; this function is completely independent of wyse, it should be auto-loadable
-; (presumably from keypad.el) for use in ~/emacs. It should be the only thing
-; users need to know about all this unintelligible "forwarding" gibberish.
-; This paves the way for a save-function-keys (some day or sleepless night)
-; that will edit calls like (set-function-key ?x 'do-whatever) in ~/.emacs.
-(defun set-function-key (key &optional def)
- "Prompt for a function or other special key and assign it a meaning.
-The key must have been \"forwarded\" to a character by term/*.el.
-
-As a function takes two args CHAR and DEF, with DEF as in define-key.
-If your terminals term/*.el forwards a physical key to CHAR (before or after
-calling this function), then that key will mean DEF, else it is ignored.
-CHAR is one of the following:
-For numbered function keys
- 0, 1, ..., 24 (or ?\\^@, ?\\^a, ..., ?\\^x which is the same)
-For keypad keys in application mode
- ?0, ?1, ..., ?9 -- keypad key labelled with that digit,
- but only if that key is not an arrow key (see ?u, ?d, ?r, ?l).
- ?- -- keypad key labelled `-'.
- ?. -- keypad key labelled `.'.
- ?, -- keypad key labelled `,'.
- ?e -- key labelled enter.
-For keys labelled with some words or a symbol
- ?a -- clear all tabs key.
- ?A -- insert line key.
- ?C -- clear screen key.
- ?c -- erase key.
- ?D -- delete character key.
- ?d -- down-arrow.
- ?E -- clear to end of line key.
- ?e -- key labelled enter.
- ?f -- find key or search key.
- ?F -- scroll forward key.
- ?H -- home-down.
- ?h -- home-position key.
- ?I -- insert character key
- If there is just an \"insert\" key, it should be this.
- ?k -- delete key or remove key.
- ?L -- delete line key.
- ?l -- left-arrow.
- ?M -- exit insert mode key.
- ?N -- next page key.
- ?p -- portrait mode.
- ?P -- previous page key.
- ?q -- landscape mode.
- ?r -- right-arrow.
- ?R -- scroll reverse key.
- ?S -- clear to end of screen key.
- ?s -- select key.
- ?t -- clear tab this column key.
- ?T -- set tab this column key.
- ?u -- up-arrow.
- ?x -- do key.
- ?\\? -- help."
- (interactive "kHit key to redefine")
- (let ((map function-keymap))
- (if (integerp key)
- ()
- ; reinvent lookup-key to get (map . char) instead of def of char in map
- (setq map (or (lookup-key global-map
- (substring key 0 (1- (length key))))
- global-map)
- key (string-to-char (substring key (1- (length key)))))
- (while (symbolp map)
- (setq map (symbol-function map)))
- (setq map (if (listp map)
- (cdr (assq key (cdr map)))
- (aref map key)))
- (if (and (consp map)
- (integerp (cdr map)))
- (setq key (cdr map)
- map (car map)) ; function-keymap usually
- (error "Key is not a \"forwarded\" definition.")))
- (if def
- ()
- (setq def (read-command "command (default last keyboard macro): "))
- (if (string-equal (symbol-name def) "")
- (setq def last-kbd-macro))
- (setq command-history ; nonsense really, since you don't see
- (cons ; key as in a function call (?char)
- (list 'set-function-key key
- (if (stringp def) def (list 'quote def)))
- command-history)))
- ; all we do when called as a function
- (define-key map (char-to-string key) def)))
-
-
diff --git a/lisp/term/x-win.el b/lisp/term/x-win.el
index feff6de1865..5d7670a66ac 100644
--- a/lisp/term/x-win.el
+++ b/lisp/term/x-win.el
@@ -1,615 +1,222 @@
;; Parse switches controlling how Emacs interfaces with X window system.
-;; Copyright (C) 1990 Free Software Foundation, Inc.
+;; Copyright (C) 1986, 1988 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
-;; 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.
-
-
-;; X-win.el: this file is loaded from ../lisp/startup.el when it recognizes
-;; that X windows are to be used. Command line switches are parsed and those
-;; pertaining to X are processed and removed from the command line. The
-;; X display is opened and hooks are set for popping up the initial window.
-
-;; startup.el will then examine startup files, and eventually call the hooks
-;; which create the first window (s).
-
-;; These are the standard X switches from the Xt Initialize.c file of
-;; Release 4.
-
-;; Command line Resource Manager string
-
-;; +rv *reverseVideo
-;; +synchronous *synchronous
-;; -background *background
-;; -bd *borderColor
-;; -bg *background
-;; -bordercolor *borderColor
-;; -borderwidth .borderWidth
-;; -bw .borderWidth
-;; -display .display
-;; -fg *foreground
-;; -fn *font
-;; -font *font
-;; -foreground *foreground
-;; -geometry .geometry
-;; -iconic .iconic
-;; -name .name
-;; -reverse *reverseVideo
-;; -rv *reverseVideo
-;; -selectionTimeout .selectionTimeout
-;; -synchronous *synchronous
-;; -title .title
-;; -xrm
-
-;; An alist of X options and the function which handles them. See
-;; ../startup.el.
-
-;; This is a temporary work-around while we the separate keymap
-;; stuff isn't yet fixed. These variables aren't used anymore,
-;; but the lisp code wants them to exist. -JimB
-(setq global-mouse-map (make-sparse-keymap))
-(setq global-function-map (make-sparse-keymap))
-
-(setq command-switch-alist
- (append '(("-dm" . x-establish-daemon-mode)
- ("-bw" . x-handle-numeric-switch)
- ("-d" . x-handle-display)
- ("-display" . x-handle-display)
- ("-name" . x-handle-switch)
- ("-T" . x-handle-switch)
- ("-r" . x-handle-switch)
- ("-rv" . x-handle-switch)
- ("-reverse" . x-handle-switch)
- ("-fn" . x-handle-switch)
- ("-font" . x-handle-switch)
- ("-ib" . x-handle-switch)
- ("-g" . x-handle-geometry)
- ("-geometry" . x-handle-geometry)
- ("-fg" . x-handle-switch)
- ("-foreground" . x-handle-switch)
- ("-bg" . x-handle-switch)
- ("-background" . x-handle-switch)
- ("-ms" . x-handle-switch)
- ("-ib" . x-handle-switch)
- ("-iconic" . x-handle-switch)
- ("-cr" . x-handle-switch)
- ("-vb" . x-handle-switch)
- ("-hb" . x-handle-switch)
- ("-bd" . x-handle-switch))
- command-switch-alist))
-
-(defvar x-switches-specified nil)
+;; 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 1, or (at your option)
+;; any later version.
-(defconst x-switch-definitions
- '(("-name" name)
- ("-T" name)
- ("-r" lose)
- ("-rv" lose)
- ("-reverse" lose)
- ("-fn" font)
- ("-font" font)
- ("-ib" internal-border-width)
- ("-fg" foreground-color)
- ("-foreground" foreground-color)
- ("-bg" background-color)
- ("-background" background-color)
- ("-ms" mouse-color)
- ("-cr" cursor-color)
- ("-ib" icon-type t)
- ("-iconic" iconic-startup t)
- ("-vb" vertical-scroll-bar t)
- ("-hb" horizontal-scroll-bar t)
- ("-bd" border-color)
- ("-bw" border-width)))
-
-;; Handler for switches of the form "-switch value" or "-switch".
+;; 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+(defconst window-system-version window-system-version
+ "*Window system version number now in use.")
+
+(defvar x-sigio-bug nil
+ "Non-NIL means don't use interrupts for input when using X.")
+
+(defvar x-processed-defaults nil
+ "Non-NIL means that user's X defaults have already been processed.")
+
+(defvar x-switches nil
+ "Alist of command switches and values for X window system interface.
+You can set this in your init file, if you want some defaults
+for these switches. Example:
+ (setq x-switches '((\"-r\" . t) (\"-font\" . \"foo\") (\"-b\" . \"8\")))
+This feature is currently broken for X11.")
+
+(if (= window-system-version 10)
+ (setq command-switch-alist
+ (append '(("-r" . x-handle-switch)
+ ("-i" . x-handle-switch)
+ ("-font" . x-handle-switch)
+ ("-w" . x-handle-switch)
+ ("-b" . x-handle-switch)
+ ("-ib" . x-handle-switch)
+ ("-fg" . x-handle-switch)
+ ("-bg" . x-handle-switch)
+ ("-bd" . x-handle-switch)
+ ("-cr" . x-handle-switch)
+ ("-ms" . x-handle-switch))
+ command-switch-alist))
+ (setq command-switch-alist
+ (append '(("-rn" . x-ignore-arg)
+ ("-xrm" . x-ignore-arg)
+ ("-r" . ignore)
+ ("-i" . ignore)
+ ("-rn" . x-ignore-arg)
+ ("-font" . x-ignore-arg)
+ ("-fn" . x-ignore-arg)
+ ("-wn" . x-ignore-arg)
+ ("-in" . x-ignore-arg)
+ ("-w" . x-ignore-arg)
+ ("-geometry" . x-ignore-arg)
+ ("-b" . x-ignore-arg)
+ ("-ib" . x-ignore-arg)
+ ("-fg" . x-ignore-arg)
+ ("-bg" . x-ignore-arg)
+ ("-bd" . x-ignore-arg)
+ ("-cr" . x-ignore-arg)
+ ("-ms" . x-ignore-arg))
+ command-switch-alist)))
+
+(defun x-ignore-arg (&rest ignore)
+ (setq command-line-args-left (cdr command-line-args-left)))
+
+;; This is run after the command args are parsed.
(defun x-handle-switch (switch)
- (let ((aelt (assoc switch x-switch-definitions)))
- (if aelt
- (if (nth 2 aelt)
- (setq x-switches-specified
- (cons (cons (nth 1 aelt) (nth 2 aelt))
- x-switches-specified))
- (setq x-switches-specified
- (cons (cons (nth 1 aelt)
- (car x-invocation-args))
- x-switches-specified)
- x-invocation-args (cdr x-invocation-args))))))
-
-;; Handler for switches of the form "-switch n"
-(defun x-handle-numeric-switch (switch)
- (let ((aelt (assoc switch x-switch-definitions)))
- (if aelt
- (setq x-switches-specified
- (cons (cons (nth 1 aelt)
- (string-to-int (car x-invocation-args)))
- x-switches-specified)
- x-invocation-args
- (cdr x-invocation-args)))))
-
-;; Handle the geometry option
-(defun x-handle-geometry (switch)
- (setq x-switches-specified (append x-switches-specified
- (x-geometry (car x-invocation-args)))
- x-invocation-args (cdr x-invocation-args)))
-
-;; The daemon stuff isn't really useful at the moment.
-(defvar x-daemon-mode nil
- "When set, means initially create just a minibuffer.")
-
-(defun x-establish-daemon-mode (switch)
- (setq x-daemon-mode t))
-
-(defvar x-display-name nil
- "The X display name specifying server and X screen.")
-
-(defun x-handle-display (switch)
- (setq x-display-name (car x-invocation-args)
- x-invocation-args (cdr x-invocation-args)))
-
-;; Here the X-related command line options are processed, before the user's
-;; startup file is loaded. These are present in ARGS (see startup.el).
-;; They are copied to x-invocation args from which the X-related things
-;; are extracted, first the switch (e.g., "-fg") in the following code,
-;; and possible values (e.g., "black") in the option handler code
-;; (e.g., x-handle-switch).
-
-;; When finished, only things not pertaining to X (e.g., "-q", filenames)
-;; are left in ARGS
-
-(defvar x-invocation-args nil)
+ (if (x-handle-switch-1 switch (car command-line-args-left))
+ (setq command-line-args-left (cdr command-line-args-left))))
+
+(defun x-handle-switch-1 (switch arg)
+ (cond ((string= switch "-r")
+ (x-flip-color)
+ nil)
+ ((string= switch "-i")
+ (x-set-icon t)
+ nil)
+ ((string= switch "-font")
+ (x-set-font arg)
+ t)
+ ((string= switch "-b")
+ (x-set-border-width (string-to-int arg))
+ t)
+ ((string= switch "-ib")
+ (x-set-internal-border-width (string-to-int arg))
+ t)
+ ((string= switch "-w")
+ (x-create-x-window arg)
+ t)
+ ((string= switch "-fg")
+ (x-set-foreground-color arg)
+ t)
+ ((string= switch "-bg")
+ (x-set-background-color arg)
+ t)
+ ((string= switch "-bd")
+ (x-set-border-color arg)
+ t)
+ ((string= switch "-cr")
+ (x-set-cursor-color arg)
+ t)
+ ((string= switch "-ms")
+ (x-set-mouse-color arg)
+ t)))
+
+;; Convert a string of the form "WWxHH+XO+YO",
+;; where WW, HH, XO and YO are numerals,
+;; into a list (WW HH XO YO).
+;; "xHH" may be omitted; then 0 is used for HH.
+;; XO and YO may be preceded by - instead of + to make them negative.
+;; Either YO or both XO and YO may be omitted; zero is used.
+(defun x-parse-edge-spec (arg)
+ (let ((cols-by-font 0)
+ (rows-by-font 0)
+ (xoffset 0)
+ (yoffset 0))
+ (if (string-match "^=" arg)
+ (setq cols-by-font (x-extract-number))
+ (error "Invalid X window size/position spec"))
+ (if (string-match "^x" arg) ;get rows-by-font
+ (setq rows-by-font (x-extract-number)))
+ (if (string-match "^[-+]" arg)
+ (setq xoffset (x-extract-number)))
+ (if (string-match "^[-+]" arg)
+ (setq yoffset (x-extract-number)))
+ (or (equal arg "")
+ (error "Invalid X window size/position spec"))
+ (list cols-by-font rows-by-font xoffset yoffset)))
+
+;; Subroutine to extract the next numeral from the front of arg,
+;; returning it and shortening arg to remove its text.
+;; If arg is negative, subtract 1 before returning it.
+(defun x-extract-number ()
+ (if (string-match "^[x=]" arg)
+ (setq arg (substring arg 1)))
+ (or (string-match "[-+]?[0-9]+" arg)
+ (error "Invalid X window size/position spec"))
+ (prog1
+ (+ (string-to-int arg)
+ (if (string-match "^-" arg) -1 0))
+ (setq arg
+ (substring arg
+ (or (string-match "[^0-9]" arg 1)
+ (length arg))))))
+
+(defun x-get-default-args ()
+ (setq x-processed-defaults t)
+ (let (value)
+ (if (not (string= (setq value (x-get-default "bodyfont")) ""))
+ (x-handle-switch-1 "-font" value))
+ (if (string-match "on" (x-get-default "bitmapicon"))
+ (x-handle-switch-1 "-i" t))
+ (if (not (string= (setq value (x-get-default "borderwidth")) ""))
+ (x-handle-switch-1 "-b" value))
+ (if (not (string= (setq value (x-get-default "internalborder")) ""))
+ (x-handle-switch-1 "-ib" value))
+ (if (not (string= (setq value (x-get-default "foreground")) ""))
+ (x-handle-switch-1 "-fg" value))
+ (if (not (string= (setq value (x-get-default "background")) ""))
+ (x-handle-switch-1 "-bg" value))
+ (if (not (string= (setq value (x-get-default "border")) ""))
+ (x-handle-switch-1 "-bd" value))
+ (if (not (string= (setq value (x-get-default "cursor")) ""))
+ (x-handle-switch-1 "-cr" value))
+ (if (not (string= (setq value (x-get-default "mouse")) ""))
+ (x-handle-switch-1 "-ms" value))
+ (if (string-match "on" (x-get-default "reversevideo"))
+ (x-handle-switch-1 "-r" t))))
+
+;; So far we have only defined some functions.
+;; Now we start processing X-related switches
+;; and redefining commands and variables,
+;; only if Emacs has been compiled to support direct interface to X.
(if (eq window-system 'x)
(progn
- (setq window-setup-hook 'x-pop-initial-window
- x-invocation-args args
- args nil)
(require 'x-mouse)
- (require 'screen)
- (setq suspend-hook
- '(lambda ()
- (error "Suspending an emacs running under X makes no sense")))
- (define-key global-map "" 'iconify-emacs)
- (while x-invocation-args
- (let* ((this-switch (car x-invocation-args))
- (aelt (assoc this-switch command-switch-alist)))
- (setq x-invocation-args (cdr x-invocation-args))
- (if aelt
- (funcall (cdr aelt) this-switch)
- (setq args (cons this-switch args)))))
- (setq args (nreverse args))
- (x-open-connection (or x-display-name
- (setq x-display-name (getenv "DISPLAY"))))
- ;;
- ;; This is the place to handle Xresources
- ;;
- )
- (error "Loading x-win.el but not compiled for X"))
-
-
-;; This is the function which creates the first X window. It is called
-;; from startup.el after the user's init file is processed.
-
-(defun x-pop-initial-window ()
- ;; xterm.c depends on using interrupt-driven input.
- (set-input-mode t nil t)
- (setq mouse-motion-handler 'x-track-pointer)
- (setq x-switches-specified (append x-switches-specified
- initial-screen-alist
- screen-default-alist))
- ;; see screen.el for this function
- (pop-initial-screen x-switches-specified)
- (delete-screen terminal-screen))
-
-
-;;
-;; Standard X cursor shapes, courtesy of Mr. Fox, who wanted ALL of them.
-;;
-
-(defconst x-pointer-X-cursor 0)
-(defconst x-pointer-arrow 2)
-(defconst x-pointer-based-arrow-down 4)
-(defconst x-pointer-based-arrow-up 6)
-(defconst x-pointer-boat 8)
-(defconst x-pointer-bogosity 10)
-(defconst x-pointer-bottom-left-corner 12)
-(defconst x-pointer-bottom-right-corner 14)
-(defconst x-pointer-bottom-side 16)
-(defconst x-pointer-bottom-tee 18)
-(defconst x-pointer-box-spiral 20)
-(defconst x-pointer-center-ptr 22)
-(defconst x-pointer-circle 24)
-(defconst x-pointer-clock 26)
-(defconst x-pointer-coffee-mug 28)
-(defconst x-pointer-cross 30)
-(defconst x-pointer-cross-reverse 32)
-(defconst x-pointer-crosshair 34)
-(defconst x-pointer-diamond-cross 36)
-(defconst x-pointer-dot 38)
-(defconst x-pointer-dotbox 40)
-(defconst x-pointer-double-arrow 42)
-(defconst x-pointer-draft-large 44)
-(defconst x-pointer-draft-small 46)
-(defconst x-pointer-draped-box 48)
-(defconst x-pointer-exchange 50)
-(defconst x-pointer-fleur 52)
-(defconst x-pointer-gobbler 54)
-(defconst x-pointer-gumby 56)
-(defconst x-pointer-hand1 58)
-(defconst x-pointer-hand2 60)
-(defconst x-pointer-heart 62)
-(defconst x-pointer-icon 64)
-(defconst x-pointer-iron-cross 66)
-(defconst x-pointer-left-ptr 68)
-(defconst x-pointer-left-side 70)
-(defconst x-pointer-left-tee 72)
-(defconst x-pointer-leftbutton 74)
-(defconst x-pointer-ll-angle 76)
-(defconst x-pointer-lr-angle 78)
-(defconst x-pointer-man 80)
-(defconst x-pointer-middlebutton 82)
-(defconst x-pointer-mouse 84)
-(defconst x-pointer-pencil 86)
-(defconst x-pointer-pirate 88)
-(defconst x-pointer-plus 90)
-(defconst x-pointer-question-arrow 92)
-(defconst x-pointer-right-ptr 94)
-(defconst x-pointer-right-side 96)
-(defconst x-pointer-right-tee 98)
-(defconst x-pointer-rightbutton 100)
-(defconst x-pointer-rtl-logo 102)
-(defconst x-pointer-sailboat 104)
-(defconst x-pointer-sb-down-arrow 106)
-(defconst x-pointer-sb-h-double-arrow 108)
-(defconst x-pointer-sb-left-arrow 110)
-(defconst x-pointer-sb-right-arrow 112)
-(defconst x-pointer-sb-up-arrow 114)
-(defconst x-pointer-sb-v-double-arrow 116)
-(defconst x-pointer-shuttle 118)
-(defconst x-pointer-sizing 120)
-(defconst x-pointer-spider 122)
-(defconst x-pointer-spraycan 124)
-(defconst x-pointer-star 126)
-(defconst x-pointer-target 128)
-(defconst x-pointer-tcross 130)
-(defconst x-pointer-top-left-arrow 132)
-(defconst x-pointer-top-left-corner 134)
-(defconst x-pointer-top-right-corner 136)
-(defconst x-pointer-top-side 138)
-(defconst x-pointer-top-tee 140)
-(defconst x-pointer-trek 142)
-(defconst x-pointer-ul-angle 144)
-(defconst x-pointer-umbrella 146)
-(defconst x-pointer-ur-angle 148)
-(defconst x-pointer-watch 150)
-(defconst x-pointer-xterm 152)
-
-;;
-;; Available colors
-;;
-
-(defvar x-colors '("aquamarine"
- "Aquamarine"
- "medium aquamarine"
- "MediumAquamarine"
- "black"
- "Black"
- "blue"
- "Blue"
- "cadet blue"
- "CadetBlue"
- "cornflower blue"
- "CornflowerBlue"
- "dark slate blue"
- "DarkSlateBlue"
- "light blue"
- "LightBlue"
- "light steel blue"
- "LightSteelBlue"
- "medium blue"
- "MediumBlue"
- "medium slate blue"
- "MediumSlateBlue"
- "midnight blue"
- "MidnightBlue"
- "navy blue"
- "NavyBlue"
- "navy"
- "Navy"
- "sky blue"
- "SkyBlue"
- "slate blue"
- "SlateBlue"
- "steel blue"
- "SteelBlue"
- "coral"
- "Coral"
- "cyan"
- "Cyan"
- "firebrick"
- "Firebrick"
- "brown"
- "Brown"
- "gold"
- "Gold"
- "goldenrod"
- "Goldenrod"
- "medium goldenrod"
- "MediumGoldenrod"
- "green"
- "Green"
- "dark green"
- "DarkGreen"
- "dark olive green"
- "DarkOliveGreen"
- "forest green"
- "ForestGreen"
- "lime green"
- "LimeGreen"
- "medium forest green"
- "MediumForestGreen"
- "medium sea green"
- "MediumSeaGreen"
- "medium spring green"
- "MediumSpringGreen"
- "pale green"
- "PaleGreen"
- "sea green"
- "SeaGreen"
- "spring green"
- "SpringGreen"
- "yellow green"
- "YellowGreen"
- "dark slate grey"
- "DarkSlateGrey"
- "dark slate gray"
- "DarkSlateGray"
- "dim grey"
- "DimGrey"
- "dim gray"
- "DimGray"
- "light grey"
- "LightGrey"
- "light gray"
- "LightGray"
- "gray"
- "grey"
- "Gray"
- "Grey"
- "khaki"
- "Khaki"
- "magenta"
- "Magenta"
- "maroon"
- "Maroon"
- "orange"
- "Orange"
- "orchid"
- "Orchid"
- "dark orchid"
- "DarkOrchid"
- "medium orchid"
- "MediumOrchid"
- "pink"
- "Pink"
- "plum"
- "Plum"
- "red"
- "Red"
- "indian red"
- "IndianRed"
- "medium violet red"
- "MediumVioletRed"
- "orange red"
- "OrangeRed"
- "violet red"
- "VioletRed"
- "salmon"
- "Salmon"
- "sienna"
- "Sienna"
- "tan"
- "Tan"
- "thistle"
- "Thistle"
- "turquoise"
- "Turquoise"
- "dark turquoise"
- "DarkTurquoise"
- "medium turquoise"
- "MediumTurquoise"
- "violet"
- "Violet"
- "blue violet"
- "BlueViolet"
- "wheat"
- "Wheat"
- "white"
- "White"
- "yellow"
- "Yellow"
- "green yellow"
- "GreenYellow")
- "The full list of X colors from the rgb.text file.")
-
-(defun x-defined-colors ()
- "Return a list of colors supported by the current X-Display."
- (let ((all-colors x-colors)
- (this-color nil)
- (defined-colors nil))
- (while all-colors
- (setq this-color (car all-colors)
- all-colors (cdr all-colors))
- (and (x-defined-color this-color)
- (setq defined-colors (cons this-color defined-colors))))
- defined-colors))
-
-
-;;
-;; Function key processing under X. Function keys are received through
-;; in the input stream as Lisp symbols.
-;;
-
-(defun define-function-key (map sym definition)
- (let ((exist (assq sym (cdr map))))
- (if exist
- (setcdr exist definition)
- (setcdr map
- (cons (cons sym definition)
- (cdr map))))))
-
-;; For unused keysyms. If this happens, it's probably a server or
-;; Xlib bug.
-
-(defun weird-x-keysym ()
- (interactive)
- (error "Bizarre X keysym received."))
-(define-function-key global-function-map 'xk-not-serious 'weird-x-keysym)
-
-;; Keypad type things
-
-(define-function-key global-function-map 'xk-home 'beginning-of-line)
-(define-function-key global-function-map 'xk-left 'backward-char)
-(define-function-key global-function-map 'xk-up 'previous-line)
-(define-function-key global-function-map 'xk-right 'forward-char)
-(define-function-key global-function-map 'xk-down 'next-line)
-(define-function-key global-function-map 'xk-prior 'previous-line)
-(define-function-key global-function-map 'xk-next 'next-line)
-(define-function-key global-function-map 'xk-end 'end-of-line)
-(define-function-key global-function-map 'xk-begin 'beginning-of-line)
-
- ;; IsMiscFunctionKey
-
-(define-function-key global-function-map 'xk-select nil)
-(define-function-key global-function-map 'xk-print nil)
-(define-function-key global-function-map 'xk-execute nil)
-(define-function-key global-function-map 'xk-insert nil)
-(define-function-key global-function-map 'xk-undo nil)
-(define-function-key global-function-map 'xk-redo nil)
-(define-function-key global-function-map 'xk-menu nil)
-(define-function-key global-function-map 'xk-find nil)
-(define-function-key global-function-map 'xk-cancel nil)
-(define-function-key global-function-map 'xk-help nil)
-(define-function-key global-function-map 'xk-break nil)
-
- ;; IsKeypadKey
-
-(define-function-key global-function-map 'xk-kp-space
- '(lambda nil (interactive)
- (insert " ")))
-(define-function-key global-function-map 'xk-kp-tab
- '(lambda nil (interactive)
- (insert "\t")))
-(define-function-key global-function-map 'xk-kp-enter
- '(lambda nil (interactive)
- (insert "\n")))
-
-(define-function-key global-function-map 'xk-kp-f1 nil)
-(define-function-key global-function-map 'xk-kp-f2 nil)
-(define-function-key global-function-map 'xk-kp-f3 nil)
-(define-function-key global-function-map 'xk-kp-f4 nil)
-
-(define-function-key global-function-map 'xk-kp-equal
- '(lambda nil (interactive)
- (insert "=")))
-(define-function-key global-function-map 'xk-kp-multiply
- '(lambda nil (interactive)
- (insert "*")))
-(define-function-key global-function-map 'xk-kp-add
- '(lambda nil (interactive)
- (insert "+")))
-(define-function-key global-function-map 'xk-kp-separator
- '(lambda nil (interactive)
- (insert ";")))
-(define-function-key global-function-map 'xk-kp-subtract
- '(lambda nil (interactive)
- (insert "-")))
-(define-function-key global-function-map 'xk-kp-decimal
- '(lambda nil (interactive)
- (insert ".")))
-(define-function-key global-function-map 'xk-kp-divide
- '(lambda nil (interactive)
- (insert "/")))
-
-(define-function-key global-function-map 'xk-kp-0
- '(lambda nil (interactive)
- (insert "0")))
-(define-function-key global-function-map 'xk-kp-1
- '(lambda nil (interactive)
- (insert "1")))
-(define-function-key global-function-map 'xk-kp-2
- '(lambda nil (interactive)
- (insert "2")))
-(define-function-key global-function-map 'xk-kp-3
- '(lambda nil (interactive)
- (insert "3")))
-(define-function-key global-function-map 'xk-kp-4
- '(lambda nil (interactive)
- (insert "4")))
-(define-function-key global-function-map 'xk-kp-5
- '(lambda nil (interactive)
- (insert "5")))
-(define-function-key global-function-map 'xk-kp-6
- '(lambda nil (interactive)
- (insert "6")))
-(define-function-key global-function-map 'xk-kp-7
- '(lambda nil (interactive)
- (insert "7")))
-(define-function-key global-function-map 'xk-kp-8
- '(lambda nil (interactive)
- (insert "8")))
-(define-function-key global-function-map 'xk-kp-9
- '(lambda nil (interactive)
- (insert "9")))
-
- ;; IsFunctionKey
-
-(define-function-key global-function-map 'xk-f1 'rmail)
-(define-function-key global-function-map 'xk-f2 nil)
-(define-function-key global-function-map 'xk-f3 nil)
-(define-function-key global-function-map 'xk-f4 nil)
-(define-function-key global-function-map 'xk-f5 nil)
-(define-function-key global-function-map 'xk-f6 nil)
-(define-function-key global-function-map 'xk-f7 nil)
-(define-function-key global-function-map 'xk-f8 nil)
-(define-function-key global-function-map 'xk-f9 nil)
-(define-function-key global-function-map 'xk-f10 nil)
-(define-function-key global-function-map 'xk-f11 nil)
-(define-function-key global-function-map 'xk-f12 nil)
-(define-function-key global-function-map 'xk-f13 nil)
-(define-function-key global-function-map 'xk-f14 nil)
-(define-function-key global-function-map 'xk-f15 nil)
-(define-function-key global-function-map 'xk-f16 nil)
-(define-function-key global-function-map 'xk-f17 nil)
-(define-function-key global-function-map 'xk-f18 nil)
-(define-function-key global-function-map 'xk-f19 nil)
-(define-function-key global-function-map 'xk-f20 nil)
-(define-function-key global-function-map 'xk-f21 nil)
-(define-function-key global-function-map 'xk-f22 nil)
-(define-function-key global-function-map 'xk-f23 nil)
-(define-function-key global-function-map 'xk-f24 nil)
-(define-function-key global-function-map 'xk-f25 nil)
-(define-function-key global-function-map 'xk-f26 nil)
-(define-function-key global-function-map 'xk-f27 nil)
-(define-function-key global-function-map 'xk-f28 nil)
-(define-function-key global-function-map 'xk-f29 nil)
-(define-function-key global-function-map 'xk-f30 nil)
-(define-function-key global-function-map 'xk-f31 nil)
-(define-function-key global-function-map 'xk-f32 nil)
-(define-function-key global-function-map 'xk-f33 nil)
-(define-function-key global-function-map 'xk-f34 nil)
-(define-function-key global-function-map 'xk-f35 nil)
+ (if (= window-system-version 10)
+ (progn
+ ;; xterm.c depends on using interrupt-driven input.
+ (set-input-mode t nil)
+
+ (defun x-new-display (display)
+ "This function takes one argument, the display where you wish to
+continue your editing session. Your current window will be unmapped and
+the current display will be closed. The new X display will be opened and
+the rubber-band outline of the new window will appear on the new X display."
+ (interactive "sDisplay to switch emacs to: ")
+ (x-change-display display)
+ (x-get-default-args))
+
+ ;; Not defvar! This is not DEFINING this variable, just specifying
+ ;; a value for it.
+ (setq window-setup-hook 'x-pop-up-window)
+
+ ;; Process switch settings made by .emacs file.
+ (while x-switches
+ (x-handle-switch-1 (car (car x-switches)) (cdr (car x-switches)))
+ (setq x-switches (cdr x-switches)))))
+
+ ;; On certain systems, turn off use of sigio, because it's broken.
+ (if x-sigio-bug
+ (set-input-mode nil nil))
+
+ (put 'suspend-emacs 'disabled
+ "Suspending a program running in an X window is silly
+and you would not be able to start it again. Just switch windows instead.\n")
+ (setq suspend-hook '(lambda () (error "Suspending an emacs running under X makes no sense")))
+ (substitute-key-definition 'suspend-emacs nil global-map)
+ (substitute-key-definition 'suspend-emacs nil esc-map)
+ (substitute-key-definition 'suspend-emacs nil ctl-x-map)
+ ;; Not needed any more -- done in C.
+ ;; (if (not x-processed-defaults) (x-get-default-args))
+))
diff --git a/lisp/term/xterm.el b/lisp/term/xterm.el
new file mode 100644
index 00000000000..abb8a85ce0d
--- /dev/null
+++ b/lisp/term/xterm.el
@@ -0,0 +1,2 @@
+;; Don't send the `ti' string when screen is cleared.
+(setq reset-terminal-on-clear nil)
diff --git a/lisp/terminal.el b/lisp/terminal.el
index d2a514048cb..70e83809d78 100644
--- a/lisp/terminal.el
+++ b/lisp/terminal.el
@@ -1,5 +1,5 @@
;; Terminal emulator for GNU Emacs.
-;; Copyright (C) 1986, 1987, 1988, 1989 Free Software Foundation, Inc.
+;; Copyright (C) 1986, 1987 Free Software Foundation, Inc.
;; Written by Richard Mlynarik, November 1986.
;; This file is part of GNU Emacs.
@@ -37,9 +37,9 @@ it through the emulator. Type ? after typing it for a list of
possible commands.
This variable is local to each terminal-emulator buffer.")
-(defvar terminal-scrolling t ;;>> Setting this to T sort-of defeats my whole aim in writing this package...
- "*If non-nil, the terminal-emulator will losingly `scroll' when output occurs
-past the bottom of the screen. If nil, output will win and `wrap' to the top
+(defvar terminal-scrolling t
+ "*If non-nil, the terminal-emulator will `scroll' when output occurs
+past the bottom of the screen. If nil, output will `wrap' to the top
of the screen.
This variable is local to each terminal-emulator buffer.")
@@ -88,8 +88,6 @@ performance.")
(define-key map "\C-o" 'te-flush-pending-output)
(define-key map "m" 'te-toggle-more-processing)
(define-key map "x" 'te-escape-extended-command)
- ;;>> What use is this? Why is it in the default terminal-emulator map?
- (define-key map "w" 'te-edit)
(define-key map "?" 'te-escape-help)
(define-key map (char-to-string help-char) 'te-escape-help)
(setq terminal-escape-map map)))
@@ -100,8 +98,6 @@ performance.")
nil
(setq te-escape-command-alist
'(("Set Escape Character" . te-set-escape-char)
- ;;>> What use is this? Why is it in the default terminal-emulator map?
- ("Edit" . te-edit)
("Refresh" . redraw-display)
("Record Output" . te-set-output-log)
("Photo" . te-set-output-log)
@@ -177,7 +173,7 @@ Other chars following \"%s\" are interpreted as follows:\n"
(princ (substitute-command-keys "\\{terminal-escape-map}\n"))
(princ (format "\nSubcommands of \"%s\" (%s)\n"
(where-is-internal 'te-escape-extended-command
- terminal-escape-map nil t)
+ terminal-escape-map t)
'te-escape-extended-command))
(let ((l (if (fboundp 'sortcar)
(sortcar (copy-sequence te-escape-command-alist)
@@ -258,7 +254,7 @@ Very poor man's file transfer protocol."
(save-excursion
(set-buffer (get-buffer-create name))
(fundamental-mode)
- (buffer-disable-undo (current-buffer))
+ (buffer-flush-undo (current-buffer))
(erase-buffer)))
(setq te-log-buffer (get-buffer name))
(message "Recording terminal emulator output into buffer \"%s\""
@@ -352,7 +348,7 @@ allowing the next page of output to appear"
(princ "Terminal-emulator more break.\n\n")
(princ (format "Type \"%s\" (te-more-break-resume)\n%s\n"
(where-is-internal 'te-more-break-resume
- terminal-more-break-map nil t)
+ terminal-more-break-map t)
(documentation 'te-more-break-resume)))
(princ (substitute-command-keys "\\{terminal-more-break-map}\n"))
(princ "Any other key is passed through to the program
@@ -393,19 +389,16 @@ the terminal emulator."
(defun te-pass-through ()
- "Character is passed to the program running under the terminal emulator.
-One characters is treated specially:
-the terminal escape character (normally C-^)
-lets you type a terminal emulator command."
+ "Send the last character typed through the terminal-emulator
+without any interpretation"
(interactive)
- (cond ((= last-input-char terminal-escape-char)
- (call-interactively 'te-escape))
- (t
- (and terminal-more-processing (null (cdr te-pending-output))
- (te-set-more-count nil))
- (send-string te-process (make-string 1 last-input-char))
- (te-process-output t))))
-
+ (if (eql last-input-char terminal-escape-char)
+ (call-interactively 'te-escape)
+ (and terminal-more-processing
+ (null (cdr te-pending-output))
+ (te-set-more-count nil))
+ (send-string te-process (make-string 1 last-input-char))
+ (te-process-output t)))
(defun te-set-window-start ()
(let* ((w (get-buffer-window (current-buffer)))
@@ -427,82 +420,6 @@ lets you type a terminal emulator command."
(setq length (+ length (length (car tem))) tem (cdr tem)))
length))
-;;>> What use is this terminal-edit stuff anyway?
-;;>> If nothing else, it was written by somebody who didn't
-;;>> competently understand the terminal-emulator...
-
-(defvar terminal-edit-map nil)
-(if terminal-edit-map
- nil
- (setq terminal-edit-map (make-sparse-keymap))
- (define-key terminal-edit-map "\C-c\C-c" 'terminal-cease-edit))
-
-;; Terminal Edit mode is suitable only for specially formatted data.
-(put 'terminal-edit-mode 'mode-class 'special)
-
-(defun terminal-edit-mode ()
- "Major mode for editing the contents of a terminal-emulator buffer.
-The editing commands are the same as in Fundamental mode,
-together with a command \\<terminal-edit-mode-map>to return to terminal emulation: \\[terminal-cease-edit]."
- (use-local-map terminal-edit-map)
- (setq major-mode 'terminal-edit-mode)
- (setq mode-name "Terminal Edit")
- (setq mode-line-modified (default-value 'mode-line-modified))
- (setq mode-line-process nil)
- (run-hooks 'terminal-edit-mode-hook))
-
-(defun te-edit ()
- "Start editing the terminal emulator buffer with ordinary Emacs commands."
- (interactive)
- (terminal-edit-mode)
- (set-buffer-modified-p (buffer-modified-p))
- ;; Make mode line update.
- (if (eq (key-binding "\C-c\C-c") 'terminal-cease-edit)
- (message "Editing: Type C-c C-c to return to Terminal")
- (message (substitute-command-keys
- "Editing: Type \\[terminal-cease-edit] to return to Terminal"))))
-
-(defun terminal-cease-edit ()
- "Finish editing message; switch back to Terminal proper."
- (interactive)
-
- ;;>> emulator will blow out if buffer isn't exactly te-width x te-height
- (let ((buffer-read-only nil))
- (widen)
- (let ((opoint (point-marker))
- (width te-width)
- (h (1- te-height)))
- (goto-char (point-min))
- (while (>= h 0)
- (let ((p (point)))
- (cond ((search-forward "\n" (+ p width) 'move)
- (forward-char -1)
- (insert-char ?\ (- width (- (point) p)))
- (forward-char 1))
- ((eobp)
- (insert-char ?\ (- width (- (point) p))))
- ((= (following-char) ?\n)
- (forward-char 1))
- (t
- (setq p (point))
- (if (search-forward "\n" nil t)
- (delete-region p (1- (point)))
- (delete-region p (point-max))))))
- (if (= h 0)
- (if (not (eobp)) (delete-region (point) (point-max)))
- (if (eobp) (insert ?\n)))
- (setq h (1- h)))
- (goto-char opoint)
- (set-marker opoint nil nil)
- (setq te-saved-point (point))
- (setq te-redisplay-count 0)
- (setq te-more-count -1)))
-
- (setq mode-line-modified (default-value 'mode-line-modified))
- (setq major-mode 'terminal-mode)
- (setq mode-name "terminal")
- (setq mode-line-process '(": %s")))
-
;;;; more break hair
(defun te-more-break ()
@@ -606,6 +523,28 @@ move to start of new line, clear to end of line."
(beginning-of-line)
(te-set-window-start))
+;; ^p ^j
+;; Handle the `do' or `nl' termcap capability.
+;;>> I am not sure why this broken, obsolete, capability is here.
+;;>> Perhaps it is for VIle. No comment was made about why it
+;;>> was added (in "Sun Dec 6 01:22:27 1987 Richard Stallman")
+(defun te-down-vertically-or-scroll ()
+ "Move down a line vertically, or scroll at bottom."
+ (let ((column (current-column)))
+ (end-of-line)
+ (if (eobp)
+ (progn
+ (delete-region (point-min) (+ (point-min) te-width))
+ (goto-char (point-min))
+ (delete-char 1)
+ (goto-char (point-max))
+ (insert ?\n)
+ (insert-char ?\ te-width)
+ (beginning-of-line))
+ (forward-line 1))
+ (move-to-column column))
+ (te-set-window-start))
+
; ^p = x+32 y+32
(defun te-move-to-position ()
;; must offset by #o40 since cretinous unix won't send a 004 char through
@@ -613,7 +552,7 @@ move to start of new line, clear to end of line."
(x (- (te-get-char) 32)))
(if (or (> x te-width)
(> y te-height))
- ()
+ () ;(error "fucked %d %d" x y)
(goto-char (+ (point-min) x (* y (1+ te-width))))
;(te-set-window-start?)
))
@@ -745,7 +684,9 @@ move to start of new line, clear to end of line."
;; Are we living twenty years in the past yet?
(defun te-losing-unix ()
- nil)
+ ;(what lossage)
+ ;(message "fucking-unix: %d" char)
+ )
;; ^i
(defun te-output-tab ()
@@ -755,28 +696,6 @@ move to start of new line, clear to end of line."
(progn (end-of-line) (- (point) p)))))
(goto-char (+ p l))))
-;; ^p ^j
-;; Handle the `do' or `nl' termcap capability.
-;;>> I am not sure why this broken, obsolete, capability is here.
-;;>> Perhaps it is for VIle. No comment was made about why it
-;;>> was added (in "Sun Dec 6 01:22:27 1987 Richard Stallman")
-(defun te-down-vertically-or-scroll ()
- "Move down a line vertically, or scroll at bottom."
- (let ((column (current-column)))
- (end-of-line)
- (if (eobp)
- (progn
- (delete-region (point-min) (+ (point-min) te-width))
- (goto-char (point-min))
- (delete-char 1)
- (goto-char (point-max))
- (insert ?\n)
- (insert-char ?\ te-width)
- (beginning-of-line))
- (forward-line 1))
- (move-to-column column))
- (te-set-window-start))
-
;; Also:
;; ^m => beginning-of-line (for which it -should- be using ^p ^a, right?!!)
;; ^g => te-beep (for which it should use ^p ^g)
@@ -798,7 +717,7 @@ move to start of new line, clear to end of line."
(setq te-log-buffer nil)
(set-buffer te-log-buffer)
(goto-char (point-max))
- (insert-before-markers string)
+ (insert string)
(set-buffer (process-buffer process))))
(setq te-pending-output (nconc te-pending-output (list string)))
(te-update-pending-output-display)
@@ -813,9 +732,7 @@ move to start of new line, clear to end of line."
(setq te-saved-point (point)))
(set-buffer obuf))))
-;; (A version of the following comment which might be distractingly offensive
-;; to some readers has been moved to term-nasty.el.)
-;; unix lacks ITS-style tty control...
+;; fucking unix has -such- braindamaged lack of tty control...
(defun te-process-output (preemptable)
;;>> There seems no good reason to ever disallow preemption
(setq preemptable t)
@@ -900,11 +817,11 @@ move to start of new line, clear to end of line."
;; I don't remember doing so, either.
;; (Perhaps some operating system or
;; other is completely incompetent...)
- (?\C-m . te-beginning-of-line)
- (?\C-g . te-beep)
- (?\C-h . te-backward-char)
- (?\C-i . te-output-tab))))
- 'te-losing-unix)))
+ (?\C-m . te-beginning-of-line) ;fuck me harder
+ (?\C-g . te-beep) ;again and again!
+ (?\C-h . te-backward-char) ;wa12id!!
+ (?\C-i . te-output-tab)))) ;(spiked)
+ 'te-losing-unix))) ;That feels better
(te-redisplay-if-necessary 1))
(and preemptable
(input-pending-p)
@@ -1114,17 +1031,16 @@ work with `terminfo' we will try to use it."
(progn (message
"Note: Meta key disabled due to maybe-eventually-reparable braindamage")
(sit-for 1)))
- (setq inhibit-quit t) ;sport death
- (use-local-map terminal-map)
- (run-hooks 'terminal-mode-hook)
(message "Entering emacs terminal-emulator... Type %s %s for help"
(single-key-description terminal-escape-char)
(mapconcat 'single-key-description
(where-is-internal 'te-escape-help
terminal-escape-map
- nil t)
- " ")))
-
+ t)
+ " "))
+ (setq inhibit-quit t) ;sport death
+ (use-local-map terminal-map)
+ (run-hooks 'terminal-mode-hook))
(defun te-parse-program-and-args (s)
(cond ((string-match "\\`\\([a-zA-Z0-9-+=_.@/:]+[ \t]*\\)+\\'" s)
@@ -1153,7 +1069,7 @@ work with `terminfo' we will try to use it."
One should not call this -- it is an internal function
of the terminal-emulator"
(kill-all-local-variables)
- (buffer-disable-undo (current-buffer))
+ (buffer-flush-undo (current-buffer))
(setq major-mode 'terminal-mode)
(setq mode-name "terminal")
; (make-local-variable 'Helper-return-blurb)
@@ -1196,33 +1112,33 @@ of the terminal-emulator"
;;;; what a complete loss
-(defun te-quote-arg-for-sh (string)
+(defun te-quote-arg-for-sh (fuckme)
(cond ((string-match "\\`[a-zA-Z0-9-+=_.@/:]+\\'"
- string)
- string)
- ((not (string-match "[$]" string))
+ fuckme)
+ fuckme)
+ ((not (string-match "[$]" fuckme))
;; "[\"\\]" are special to sh and the lisp reader in the same way
- (prin1-to-string string))
+ (prin1-to-string fuckme))
(t
(let ((harder "")
- (start 0)
- (end 0))
- (while (cond ((>= start (length string))
+ (cretin 0)
+ (stupid 0))
+ (while (cond ((>= cretin (length fuckme))
nil)
;; this is the set of chars magic with "..." in `sh'
- ((setq end (string-match "[\"\\$]"
- string start))
+ ((setq stupid (string-match "[\"\\$]"
+ fuckme cretin))
t)
(t (setq harder (concat harder
- (substring string start)))
+ (substring fuckme cretin)))
nil))
- (setq harder (concat harder (substring string start end)
+ (setq harder (concat harder (substring fuckme cretin stupid)
;; Can't use ?\\ since `concat'
;; unfortunately does prin1-to-string
;; on fixna. Amazing.
"\\"
- (substring string
- end
- (1+ end)))
- start (1+ end)))
- (concat "\"" harder "\""))))) \ No newline at end of file
+ (substring fuckme
+ stupid
+ (1+ stupid)))
+ cretin (1+ stupid)))
+ (concat "\"" harder "\"")))))
diff --git a/lisp/terminal.elc b/lisp/terminal.elc
new file mode 100644
index 00000000000..13e2bcc0c42
--- /dev/null
+++ b/lisp/terminal.elc
Binary files differ
diff --git a/lisp/tex-mode.el b/lisp/tex-mode.el
new file mode 100644
index 00000000000..d7126a22f1b
--- /dev/null
+++ b/lisp/tex-mode.el
@@ -0,0 +1,465 @@
+;; TeX mode commands.
+;; Copyright (C) 1985, 1986 Free Software Foundation, Inc.
+;; Rewritten following contributions by William F. Schelter
+;; and Dick King (king@kestrel).
+;; Modified August 1986 by Stephen Gildea <mit-erl!gildea> and
+;; Michael Prange <mit-erl!prange> to add LaTeX support and enhance
+;; TeX-region.
+;; Added TeX-directory and reorganized somewhat gildea 21 Nov 86
+
+;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;; Still to do:
+;; Make TAB indent correctly for TeX code. Then we can make linefeed
+;; do something more useful.
+;;
+;; Have spell understand TeX instead of assuming the entire world
+;; uses nroff.
+;;
+;; The code for finding matching $ needs to be fixed.
+
+(provide 'tex-mode)
+
+(defvar TeX-directory "/tmp/"
+ "*Directory in which to run TeX subjob. Temporary files are
+created in this directory.")
+(defvar TeX-dvi-print-command "lpr -d"
+ "*Command string used by \\[TeX-print] to print a .dvi file.")
+(defvar TeX-show-queue-command "lpq"
+ "*Command string used by \\[TeX-show-print-queue] to show the print queue
+that \\[TeX-print] put your job on.")
+(defvar TeX-default-mode 'plain-TeX-mode
+ "*Mode to enter for a new file when it can't be determined whether
+the file is plain TeX or LaTeX or what.")
+
+(defvar TeX-command nil
+ "The command to run TeX on a file. The name of the file will be appended
+to this string, separated by a space.")
+(defvar TeX-trailer nil
+ "String appended after the end of a region sent to TeX by \\[TeX-region].")
+(defvar TeX-start-of-header nil
+ "String used by \\[TeX-region] to delimit the start of the file's header.")
+(defvar TeX-end-of-header nil
+ "String used by \\[TeX-region] to delimit the end of the file's header.")
+(defvar TeX-shell-cd-command "cd"
+ "Command to give to shell running TeX to change directory. The value of
+TeX-directory will be appended to this, separated by a space.")
+(defvar TeX-zap-file nil
+ "Temporary file name used for text being sent as input to TeX.
+Should be a simple file name with no extension or directory specification.")
+
+(defvar TeX-mode-syntax-table nil
+ "Syntax table used while in TeX mode.")
+
+(defun TeX-define-common-keys (keymap)
+ "Define the keys that we want defined both in TeX-mode
+and in the TeX-shell."
+ (define-key keymap "\C-c\C-k" 'TeX-kill-job)
+ (define-key keymap "\C-c\C-l" 'TeX-recenter-output-buffer)
+ (define-key keymap "\C-c\C-q" 'TeX-show-print-queue)
+ (define-key keymap "\C-c\C-p" 'TeX-print)
+ )
+
+(defvar TeX-mode-map nil "Keymap for TeX mode")
+
+(if TeX-mode-map
+ nil
+ (setq TeX-mode-map (make-sparse-keymap))
+ (TeX-define-common-keys TeX-mode-map)
+ (define-key TeX-mode-map "\"" 'TeX-insert-quote)
+ (define-key TeX-mode-map "\n" 'TeX-terminate-paragraph)
+ (define-key TeX-mode-map "\e}" 'up-list)
+ (define-key TeX-mode-map "\e{" 'TeX-insert-braces)
+ (define-key TeX-mode-map "\C-c\C-r" 'TeX-region)
+ (define-key TeX-mode-map "\C-c\C-b" 'TeX-buffer)
+ (define-key TeX-mode-map "\C-c\C-f" 'TeX-close-LaTeX-block)
+ )
+
+(defvar TeX-shell-map nil
+ "Keymap for the TeX shell. A shell-mode-map with a few additions")
+
+;(fset 'TeX-mode 'tex-mode) ;in loaddefs.
+
+;;; This would be a lot simpler if we just used a regexp search,
+;;; but then it would be too slow.
+(defun tex-mode ()
+ "Major mode for editing files of input for TeX or LaTeX.
+Trys to intuit whether this file is for plain TeX or LaTeX and
+calls plain-tex-mode or latex-mode. If it cannot be determined
+\(e.g., there are no commands in the file), the value of
+TeX-default-mode is used."
+ (interactive)
+ (let (mode slash comment)
+ (save-excursion
+ (goto-char (point-min))
+ (while (and (setq slash (search-forward "\\" nil t))
+ (setq comment (let ((search-end (point)))
+ (save-excursion
+ (beginning-of-line)
+ (search-forward "%" search-end t))))))
+ (if (and slash (not comment))
+ (setq mode (if (looking-at "documentstyle")
+ 'latex-mode
+ 'plain-tex-mode))))
+ (if mode (funcall mode)
+ (funcall TeX-default-mode))))
+
+(fset 'plain-TeX-mode 'plain-tex-mode)
+(fset 'LaTeX-mode 'latex-mode)
+
+(defun plain-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-print] prints the .dvi file made by either of these.
+
+Use \\[validate-TeX-buffer] to check buffer for paragraphs containing
+mismatched $'s or braces.
+
+Special commands:
+\\{TeX-mode-map}
+
+Mode variables:
+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-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."
+ (interactive)
+ (TeX-common-initialization)
+ (setq mode-name "TeX")
+ (setq major-mode 'plain-TeX-mode)
+ (setq TeX-command "tex")
+ (setq TeX-start-of-header "%**start of header")
+ (setq TeX-end-of-header "%**end of header")
+ (setq TeX-trailer "\\bye\n")
+ (run-hooks 'text-mode-hook 'TeX-mode-hook 'plain-TeX-mode-hook))
+
+(defun latex-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-print] prints the .dvi file made by either of these.
+
+Use \\[validate-TeX-buffer] to check buffer for paragraphs containing
+mismatched $'s or braces.
+
+Special commands:
+\\{TeX-mode-map}
+
+Mode variables:
+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-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."
+ (interactive)
+ (TeX-common-initialization)
+ (setq mode-name "LaTeX")
+ (setq major-mode 'LaTeX-mode)
+ (setq TeX-command "latex")
+ (setq TeX-start-of-header "\\documentstyle")
+ (setq TeX-end-of-header "\\begin{document}")
+ (setq TeX-trailer "\\end{document}\n")
+ (run-hooks 'text-mode-hook 'TeX-mode-hook 'LaTeX-mode-hook))
+
+(defun TeX-common-initialization ()
+ (kill-all-local-variables)
+ (use-local-map TeX-mode-map)
+ (setq local-abbrev-table text-mode-abbrev-table)
+ (if (null TeX-mode-syntax-table)
+ (progn
+ (setq TeX-mode-syntax-table (make-syntax-table))
+ (set-syntax-table TeX-mode-syntax-table)
+ (modify-syntax-entry ?\\ ".")
+ (modify-syntax-entry ?\f ">")
+ (modify-syntax-entry ?\n ">")
+ (modify-syntax-entry ?$ "$$")
+ (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 TeX-mode-syntax-table))
+ (make-local-variable 'paragraph-start)
+ (setq paragraph-start "^[ \t]*$\\|^[\f\\\\%]")
+ (make-local-variable 'paragraph-separate)
+ (setq paragraph-separate paragraph-start)
+ (make-local-variable 'comment-start)
+ (setq comment-start "%")
+ (make-local-variable 'comment-start-skip)
+ (setq comment-start-skip "\\(\\(^\\|[^\\]\\)\\(\\\\\\\\\\)*\\)\\(%+ *\\)")
+ (make-local-variable 'comment-indent-hook)
+ (setq comment-indent-hook 'TeX-comment-indent)
+ (make-local-variable 'TeX-command)
+ (make-local-variable 'TeX-start-of-header)
+ (make-local-variable 'TeX-end-of-header)
+ (make-local-variable 'TeX-trailer))
+
+(defun TeX-comment-indent ()
+ (if (looking-at "%%%")
+ (current-column)
+ (skip-chars-backward " \t")
+ (max (if (bolp) 0 (1+ (current-column)))
+ comment-column)))
+
+(defun TeX-insert-quote (arg)
+ "Insert ``, '' or \" according to preceding character.
+With prefix argument, always insert \" characters."
+ (interactive "P")
+ (if arg
+ (let ((count (prefix-numeric-value arg)))
+ (if (listp arg)
+ (self-insert-command 1) ;C-u always inserts just one
+ (self-insert-command count)))
+ (insert
+ (cond
+ ((or (bobp)
+ (save-excursion
+ (forward-char -1)
+ (looking-at "[ \t\n]\\|\\s(")))
+ "``")
+ ((= (preceding-char) ?\\)
+ ?\")
+ (t "''")))))
+
+(defun validate-TeX-buffer ()
+ "Check current buffer for paragraphs containing mismatched $'s.
+As each such paragraph is found, a mark is pushed at its beginning,
+and the location is displayed for a few seconds."
+ (interactive)
+ (let ((opoint (point)))
+ (goto-char (point-max))
+ ;; Does not use save-excursion
+ ;; because we do not want to save the mark.
+ (unwind-protect
+ (while (and (not (input-pending-p)) (not (bobp)))
+ (let ((end (point)))
+ (search-backward "\n\n" nil 'move)
+ (or (TeX-validate-paragraph (point) end)
+ (progn
+ (push-mark (point))
+ (message "Mismatch found in pararaph starting here")
+ (sit-for 4)))))
+ (goto-char opoint))))
+
+(defun TeX-validate-paragraph (start end)
+ (condition-case ()
+ (save-excursion
+ (save-restriction
+ (narrow-to-region start end)
+ (goto-char start)
+ (forward-sexp (- end start))
+ t))
+ (error nil)))
+
+(defun TeX-terminate-paragraph (inhibit-validation)
+ "Insert two newlines, breaking a paragraph for TeX.
+Check for mismatched braces/$'s in paragraph being terminated.
+A prefix arg inhibits the checking."
+ (interactive "P")
+ (or inhibit-validation
+ (TeX-validate-paragraph
+ (save-excursion
+ (search-backward "\n\n" nil 'move)
+ (point))
+ (point))
+ (message "Paragraph being closed appears to contain a mismatch"))
+ (insert "\n\n"))
+
+(defun TeX-insert-braces ()
+ "Make a pair of braces and be poised to type inside of them."
+ (interactive)
+ (insert ?\{)
+ (save-excursion
+ (insert ?})))
+
+;;; Like TeX-insert-braces, but for LaTeX.
+(defun TeX-close-LaTeX-block ()
+ "Creates an \\end{...} to match \\begin{...} on the current line and
+puts point on the blank line between them."
+ (interactive "*")
+ (let ((fail-point (point)))
+ (end-of-line)
+ (if (re-search-backward "\\\\begin{\\([^}\n]*\\)}"
+ (save-excursion (beginning-of-line) (point)) t)
+ (let ((text (buffer-substring (match-beginning 1) (match-end 1)))
+ (indentation (current-column)))
+ (end-of-line)
+ (delete-horizontal-space)
+ (insert "\n\n")
+ (indent-to indentation)
+ (insert "\\end{" text "}")
+ (forward-line -1))
+ (goto-char fail-point)
+ (ding))))
+
+;;; Invoking TeX in an inferior shell.
+
+;;; Why use a shell instead of running TeX directly? Because if TeX
+;;; gets stuck, the user can switch to the shell window and type at it.
+
+;;; The utility functions:
+
+(defun TeX-start-shell ()
+ (require 'shell)
+ (save-excursion
+ (set-buffer (make-shell "TeX-shell" nil nil "-v"))
+ (setq TeX-shell-map (copy-keymap shell-mode-map))
+ (TeX-define-common-keys TeX-shell-map)
+ (use-local-map TeX-shell-map)
+ (if (zerop (buffer-size))
+ (sleep-for 1))))
+
+(defun set-buffer-directory (buffer directory)
+ "Set BUFFER's default directory to be DIRECTORY."
+ (setq directory (file-name-as-directory (expand-file-name directory)))
+ (if (not (file-directory-p directory))
+ (error "%s is not a directory" directory)
+ (save-excursion
+ (set-buffer buffer)
+ (setq default-directory directory))))
+
+;;; The commands:
+
+;;; It's a kludge that we have to create a special buffer just
+;;; to write out the TeX-trailer. It would nice if there were a
+;;; function like write-region that would write literal strings.
+
+(defun TeX-region (beg end)
+ "Run TeX on the current region. A temporary file (TeX-zap-file) is
+written in directory TeX-directory, and TeX is run in that directory.
+If the buffer has a header, it is written to the temporary file before
+the region itself. The buffer's header is all lines between the
+strings defined by TeX-start-of-header and TeX-end-of-header
+inclusive. The header must start in the first 100 lines. The value
+of TeX-trailer is appended to the temporary file after the region."
+ (interactive "r")
+ (if (get-buffer "*TeX-shell*")
+ (TeX-kill-job)
+ (TeX-start-shell))
+ (or TeX-zap-file (setq TeX-zap-file (make-temp-name "#tz")))
+ (let ((tex-out-file (concat TeX-zap-file ".tex"))
+ (temp-buffer (get-buffer-create " TeX-Output-Buffer"))
+ (zap-directory
+ (file-name-as-directory (expand-file-name TeX-directory))))
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (forward-line 100)
+ (let ((search-end (point))
+ (hbeg (point-min)) (hend (point-min))
+ (default-directory zap-directory))
+ (goto-char (point-min))
+ ;; Initialize the temp file with either the header or nothing
+ (if (search-forward TeX-start-of-header search-end t)
+ (progn
+ (beginning-of-line)
+ (setq hbeg (point)) ;mark beginning of header
+ (if (search-forward TeX-end-of-header nil t)
+ (progn (forward-line 1)
+ (setq hend (point))) ;mark end of header
+ (setq hbeg (point-min))))) ;no header
+ (write-region (min hbeg beg) hend tex-out-file nil nil)
+ (write-region (max beg hend) end tex-out-file t nil))
+ (let ((local-tex-trailer TeX-trailer))
+ (set-buffer temp-buffer)
+ (erase-buffer)
+ ;; make sure trailer isn't hidden by a comment
+ (insert-string "\n")
+ (if local-tex-trailer (insert-string local-tex-trailer))
+ (set-buffer-directory temp-buffer zap-directory)
+ (write-region (point-min) (point-max) tex-out-file t nil))))
+ (set-buffer-directory "*TeX-shell*" zap-directory)
+ (send-string "TeX-shell" (concat TeX-shell-cd-command " "
+ zap-directory "\n"))
+ (send-string "TeX-shell" (concat TeX-command " \""
+ tex-out-file "\"\n")))
+ (TeX-recenter-output-buffer 0))
+
+(defun TeX-buffer ()
+ "Run TeX on current buffer. See \\[TeX-region] for more information."
+ (interactive)
+ (TeX-region (point-min) (point-max)))
+
+(defun TeX-kill-job ()
+ "Kill the currently running TeX job."
+ (interactive)
+ (quit-process "TeX-shell" t))
+
+(defun TeX-recenter-output-buffer (linenum)
+ "Redisplay buffer of TeX job output so that most recent output can be seen.
+The last line of the buffer is displayed on
+line LINE of the window, or centered if LINE is nil."
+ (interactive "P")
+ (let ((tex-shell (get-buffer "*TeX-shell*"))
+ (old-buffer (current-buffer)))
+ (if (null tex-shell)
+ (message "No TeX output buffer")
+ (pop-to-buffer tex-shell)
+ (bury-buffer tex-shell)
+ (goto-char (point-max))
+ (recenter (if linenum
+ (prefix-numeric-value linenum)
+ (/ (window-height) 2)))
+ (pop-to-buffer old-buffer)
+ )))
+
+(defun TeX-print ()
+ "Print the .dvi file made by \\[TeX-region] or \\[TeX-buffer].
+Runs the shell command defined by TeX-dvi-print-command."
+ (interactive)
+ (send-string "TeX-shell"
+ (concat TeX-dvi-print-command " \"" TeX-zap-file ".dvi\"\n"))
+ (TeX-recenter-output-buffer nil))
+
+(defun TeX-show-print-queue ()
+ "Show the print queue that \\[TeX-print] put your job on.
+Runs the shell command defined by TeX-show-queue-command."
+ (interactive)
+ (if (not (get-buffer "*TeX-shell*"))
+ (TeX-start-shell))
+ (send-string "TeX-shell" (concat TeX-show-queue-command "\n"))
+ (TeX-recenter-output-buffer nil))
+
diff --git a/lisp/tex-mode.elc b/lisp/tex-mode.elc
new file mode 100644
index 00000000000..9815ba2064e
--- /dev/null
+++ b/lisp/tex-mode.elc
Binary files differ
diff --git a/lisp/tex-start.el b/lisp/tex-start.el
new file mode 100644
index 00000000000..0184114faf0
--- /dev/null
+++ b/lisp/tex-start.el
@@ -0,0 +1,11 @@
+; This file is for use by TeX82 (see man page) to allow switching to
+; Emacs at a line number given on the command line
+; It assumes that it has been called by:
+; emacs -l tex-start -e startline <linenumber> <file>
+
+(defun startline ()
+ ;(setq command-line-args (cdr command-line-args))
+ (find-file (car (cdr command-line-args-left)))
+ (goto-char (point-min))
+ (forward-line (1- (string-to-int (car command-line-args-left))))
+ (setq command-line-args-left ()))
diff --git a/lisp/textmodes/texinfmt.el b/lisp/texinfmt.el
index 07b2c9136f6..d28f279eb90 100644
--- a/lisp/textmodes/texinfmt.el
+++ b/lisp/texinfmt.el
@@ -1,9 +1,5 @@
-;;;; texinfmt.el
-;;;; Convert Texinfo files to Info files.
-
-;;;; Version 2.00 14 Dec 1990
-
-;; Copyright (C) 1985, 1986, 1988, 1990 Free Software Foundation, Inc.
+;; Convert texinfo files to info files.
+;; Copyright (C) 1985, 1986, 1988 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
@@ -21,11 +17,6 @@
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-;; Updated May 1990 to correspond, more or less, to version 2.8 of
-;; texinfo.tex. NOTE: texinfmt.el is being phased out; it is being
-;; replaced by makeinfo.c, which is faster and provides better error
-;; checking.
-;; Robert J. Chassell, bob@ai.mit.edu
(defvar texinfo-format-syntax-table nil)
@@ -66,40 +57,37 @@ Info-split to do these manually."
(message lastmessage)
(texinfo-format-buffer-1)
(if notagify
- nil
+ nil
(if (> (buffer-size) 30000)
- (progn
- (message (setq lastmessage "Making tags table for Info file..."))
- (Info-tagify)))
+ (progn
+ (message (setq lastmessage "Making tags table for Info file..."))
+ (Info-tagify)))
(if (> (buffer-size) 100000)
- (progn
- (message (setq lastmessage "Splitting Info file..."))
- (Info-split))))
+ (progn
+ (message (setq lastmessage "Splitting Info file..."))
+ (Info-split))))
(message (concat lastmessage
- (if (interactive-p) "done. Now save it." "done.")))))
-
+ (if (interactive-p) "done. Now save it." "done.")))))
(defun texinfo-format-buffer-1 ()
(let (texinfo-format-filename
- texinfo-example-start
- texinfo-command-start
- texinfo-command-end
- texinfo-command-name
- texinfo-last-node
- texinfo-vindex
- texinfo-findex
- texinfo-cindex
- texinfo-pindex
- texinfo-tindex
- texinfo-kindex
- texinfo-stack
- texinfo-node-names
- (texinfo-footnote-number 0)
- last-input-buffer
- outfile
- (fill-column fill-column)
- (input-buffer (current-buffer))
- (input-directory default-directory))
+ texinfo-example-start
+ texinfo-command-start
+ texinfo-command-end
+ texinfo-command-name
+ texinfo-last-node
+ texinfo-vindex
+ texinfo-findex
+ texinfo-cindex
+ texinfo-pindex
+ texinfo-tindex
+ texinfo-kindex
+ texinfo-stack
+ texinfo-node-names
+ outfile
+ (fill-column fill-column)
+ (input-buffer (current-buffer))
+ (input-directory default-directory))
(save-excursion
(goto-char (point-min))
(search-forward "@setfilename")
@@ -117,49 +105,47 @@ Info-split to do these manually."
;; Remove @bye at end of file, if it is there.
(goto-char (point-max))
(if (search-backward "@bye" nil t)
- (delete-region (point) (point-max)))
+ (delete-region (point) (point-max)))
;; Make sure buffer ends in a newline.
(or (= (preceding-char) ?\n)
- (insert "\n"))
+ (insert "\n"))
;; Scan the whole buffer, converting to Info format.
(texinfo-format-scan)
;; Return data for indices.
(goto-char (point-min))
(list outfile
- texinfo-vindex texinfo-findex texinfo-cindex
- texinfo-pindex texinfo-tindex texinfo-kindex)))
+ texinfo-vindex texinfo-findex texinfo-cindex
+ texinfo-pindex texinfo-tindex texinfo-kindex)))
(defvar texinfo-region-buffer-name "*Info Region*"
"*Name of the temporary buffer used by \\[texinfo-format-region].")
(defun texinfo-format-region (region-beginning region-ending)
- "Convert the current region of the Texinfo file to Info format.
+ "Convert the the current region of the Texinfo file to Info format.
This lets you see what that part of the file will look like in Info.
The command is bound to \\[texinfo-format-region]. The text that is
converted to Info is stored in a temporary buffer."
(interactive "r")
(message "Converting region to Info format...")
(let (texinfo-command-start
- texinfo-command-end
- texinfo-command-name
- texinfo-vindex
- texinfo-findex
- texinfo-cindex
- texinfo-pindex
- texinfo-tindex
- texinfo-kindex
- texinfo-stack
- texinfo-format-filename
- texinfo-example-start
- texinfo-last-node
- texinfo-node-names
- (texinfo-footnote-number 0)
- last-input-buffer
- (fill-column fill-column)
- (input-buffer (current-buffer))
- (input-directory default-directory)
- filename-beginning
- filename-ending)
+ texinfo-command-end
+ texinfo-command-name
+ texinfo-vindex
+ texinfo-findex
+ texinfo-cindex
+ texinfo-pindex
+ texinfo-tindex
+ texinfo-kindex
+ texinfo-stack
+ texinfo-format-filename
+ texinfo-example-start
+ texinfo-last-node
+ texinfo-node-names
+ (fill-column fill-column)
+ (input-buffer (current-buffer))
+ (input-directory default-directory)
+ filename-beginning
+ filename-ending)
;;; Find a buffer to use.
@@ -171,28 +157,28 @@ converted to Info is stored in a temporary buffer."
(save-excursion
(set-buffer input-buffer)
(save-excursion
- (save-restriction
- (widen)
- (goto-char (point-min))
- ;; Initialize the buffer with the filename
- ;; or else explain that a filename is needed.
- (or (search-forward "@setfilename"
- (save-excursion (forward-line 100) (point)) t)
- (error "The texinfo file needs a line saying: @setfilename <name>"))
- (beginning-of-line)
- (setq filename-beginning (point))
- (forward-line 1)
- (setq filename-ending (point)))))
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ ;; Initialize the buffer with the filename
+ ;; or else explain that a filename is needed.
+ (or (search-forward "@setfilename"
+ (save-excursion (forward-line 100) (point)) t)
+ (error "The texinfo file needs a line saying: @setfilename <name>"))
+ (beginning-of-line)
+ (setq filename-beginning (point))
+ (forward-line 1)
+ (setq filename-ending (point)))))
;; Insert the @setfilename line into the buffer.
(insert-buffer-substring input-buffer
- (min filename-beginning region-beginning)
- filename-ending)
+ (min filename-beginning region-beginning)
+ filename-ending)
;; Insert the region into the buffer.
(insert-buffer-substring input-buffer
- (max region-beginning filename-ending)
- region-ending)
+ (max region-beginning filename-ending)
+ region-ending)
(texinfo-mode)
@@ -203,10 +189,10 @@ converted to Info is stored in a temporary buffer."
;; discard everything after that.
(goto-char (point-max))
(if (re-search-backward "^@bye" nil t)
- (delete-region (point) (point-max)))
+ (delete-region (point) (point-max)))
;; Make sure buffer ends in a newline.
(or (= (preceding-char) ?\n)
- (insert "\n"))
+ (insert "\n"))
;; Now convert for real.
(goto-char (point-min))
@@ -214,50 +200,44 @@ converted to Info is stored in a temporary buffer."
(goto-char (point-min)))
(message "Done."))
-
;; Perform those texinfo-to-info conversions that apply to the whole input
;; uniformly.
(defun texinfo-format-scan ()
- ;; Convert left and right quotes to typewriter font quotes.
- (goto-char (point-min))
- (while (search-forward "``" nil t)
- (replace-match "\""))
- (goto-char (point-min))
- (while (search-forward "''" nil t)
- (replace-match "\""))
- ;; Scan for @-commands.
- (goto-char (point-min))
- (while (search-forward "@" nil t)
- (if (looking-at "[@{}'` *]")
- ;; Handle a few special @-followed-by-one-char commands.
- (if (= (following-char) ?*)
- (progn
- ;; remove command
- (delete-region (1- (point)) (1+ (point)))
- ;; insert return if not at end of line;
- ;; else line is already broken.
- (if (not (= (following-char) ?\n))
- (insert ?\n)))
- ;; The other characters are simply quoted. Delete the @.
- (delete-char -1)
- (forward-char 1))
- ;; @ is followed by a command-word; find the end of the word.
- (setq texinfo-command-start (1- (point)))
- (if (= (char-syntax (following-char)) ?w)
- (forward-word 1)
- (forward-char 1))
- (setq texinfo-command-end (point))
- ;; Call the handler for this command.
- (setq texinfo-command-name
- (intern (buffer-substring (1+ texinfo-command-start)
- texinfo-command-end)))
- (let ((cmd (get texinfo-command-name 'texinfo-format)))
- (if cmd (funcall cmd)
- (texinfo-unsupported)))))
- (cond (texinfo-stack
- (goto-char (nth 2 (car texinfo-stack)))
- (error "Unterminated @%s" (car (car texinfo-stack))))))
+ ;; Convert left and right quotes to typewriter font quotes.
+ (goto-char (point-min))
+ (while (search-forward "``" nil t)
+ (replace-match "\""))
+ (goto-char (point-min))
+ (while (search-forward "''" nil t)
+ (replace-match "\""))
+ ;; Scan for @-commands.
+ (goto-char (point-min))
+ (while (search-forward "@" nil t)
+ (if (looking-at "[@{}'` *]")
+ ;; Handle a few special @-followed-by-one-char commands.
+ (if (= (following-char) ?*)
+ ;; @* has no effect, since we are not filling.
+ (delete-region (1- (point)) (1+ (point)))
+ ;; The other characters are simply quoted. Delete the @.
+ (delete-char -1)
+ (forward-char 1))
+ ;; @ is followed by a command-word; find the end of the word.
+ (setq texinfo-command-start (1- (point)))
+ (if (= (char-syntax (following-char)) ?w)
+ (forward-word 1)
+ (forward-char 1))
+ (setq texinfo-command-end (point))
+ ;; Call the handler for this command.
+ (setq texinfo-command-name
+ (intern (buffer-substring (1+ texinfo-command-start)
+ texinfo-command-end)))
+ (let ((cmd (get texinfo-command-name 'texinfo-format)))
+ (if cmd (funcall cmd)
+ (texinfo-unsupported)))))
+ (cond (texinfo-stack
+ (goto-char (nth 2 (car texinfo-stack)))
+ (error "Unterminated @%s" (car (car texinfo-stack))))))
(put 'begin 'texinfo-format 'texinfo-format-begin)
(defun texinfo-format-begin ()
@@ -280,7 +260,6 @@ converted to Info is stored in a temporary buffer."
(skip-chars-forward " ")
(setq start (point))
(end-of-line)
- (skip-chars-backward " ")
(setq texinfo-command-end (1+ (point))))
((looking-at "{")
(setq start (1+ (point)))
@@ -332,19 +311,6 @@ converted to Info is stored in a temporary buffer."
(defun texinfo-discard-command ()
(delete-region texinfo-command-start texinfo-command-end))
-(defun texinfo-optional-braces-discard ()
- "Discard braces following command, if any."
- (goto-char texinfo-command-end)
- (let ((start (point)))
- (cond ((looking-at "[ \t]*\n")) ; do nothing
- ((looking-at "{") ; remove braces, if any
- (forward-list 1)
- (setq texinfo-command-end (point)))
- (t
- (error
- "Invalid `texinfo-optional-braces-discard' format \(need braces?\)")))
- (delete-region texinfo-command-start texinfo-command-end)))
-
(defun texinfo-format-parse-line-args ()
(let ((start (1- (point)))
next beg end
@@ -371,10 +337,6 @@ converted to Info is stored in a temporary buffer."
next beg end
args)
(search-forward "{")
- (save-excursion
- (texinfo-format-expand-region
- (point)
- (save-excursion (up-list 1) (1- (point)))))
(while (/= (preceding-char) ?\})
(skip-chars-forward " \t\n")
(setq beg (point))
@@ -422,42 +384,21 @@ converted to Info is stored in a temporary buffer."
(forward-char 1)
(nreverse args))))
-
-; 19 October 1990
-; @setfilename modifed to work with include files; see @include
-; (defun texinfo-format-setfilename ()
-; (let ((arg (texinfo-parse-arg-discard)))
-; (setq texinfo-format-filename
-; (file-name-nondirectory (expand-file-name arg)))
-; (insert "Info file: "
-; texinfo-format-filename ", -*-Text-*-\n"
-; "produced by texinfo-format-buffer\nfrom "
-; (if (buffer-file-name input-buffer)
-; (concat "file: "
-; (file-name-sans-versions
-; (file-name-nondirectory
-; (buffer-file-name input-buffer))))
-; (concat "buffer " (buffer-name input-buffer)))
-; "\n\n")))
-
(put 'setfilename 'texinfo-format 'texinfo-format-setfilename)
(defun texinfo-format-setfilename ()
(let ((arg (texinfo-parse-arg-discard)))
- (if (eq input-buffer last-input-buffer)
- nil ; only use first setfilename in buffer
- (message "Formatting Info file: %s" arg)
- (setq texinfo-format-filename
- (file-name-nondirectory (expand-file-name arg)))
- (insert "Info file: "
- texinfo-format-filename ", -*-Text-*-\n"
- "produced by texinfo-format-buffer\nfrom "
- (if (buffer-file-name input-buffer)
- (concat "file: "
- (file-name-sans-versions
- (file-name-nondirectory
- (buffer-file-name input-buffer))))
- (concat "buffer " (buffer-name input-buffer)))
- "\n\n"))))
+ (setq texinfo-format-filename
+ (file-name-nondirectory (expand-file-name arg)))
+ (insert "Info file: "
+ texinfo-format-filename ", -*-Text-*-\n"
+ "produced by texinfo-format-buffer\nfrom "
+ (if (buffer-file-name input-buffer)
+ (concat "file: "
+ (file-name-sans-versions
+ (file-name-nondirectory
+ (buffer-file-name input-buffer))))
+ (concat "buffer " (buffer-name input-buffer)))
+ "\n\n")))
(put 'node 'texinfo-format 'texinfo-format-node)
(defun texinfo-format-node ()
@@ -471,8 +412,7 @@ converted to Info is stored in a temporary buffer."
(let ((tem (downcase name)))
(if (assoc tem texinfo-node-names)
(error "Duplicate node name: %s" name)
- (setq texinfo-node-names (cons (list tem) texinfo-node-names))))
- (setq texinfo-footnote-number 0)
+ (setq texinfo-node-names (cons tem texinfo-node-names))))
(or (bolp)
(insert ?\n))
(insert "\^_\nFile: " texinfo-format-filename
@@ -515,11 +455,6 @@ converted to Info is stored in a temporary buffer."
; If fifth argument DOCUMENT is specified, produces
; See section <xref to NODE> [NAME, else NODE], page <xref to NODE>
; of DOCUMENT
-
-; @ref a reference that does not put `See' or `see' in
-; the hardcopy and is the same as @xref in Info
-(put 'ref 'texinfo-format 'texinfo-format-xref)
-
(put 'xref 'texinfo-format 'texinfo-format-xref)
(defun texinfo-format-xref ()
(let ((args (texinfo-format-parse-args)))
@@ -548,9 +483,7 @@ converted to Info is stored in a temporary buffer."
(defun texinfo-format-inforef ()
(let ((args (texinfo-format-parse-args)))
(texinfo-discard-command)
- (if (nth 1 args)
- (insert "*Note " (nth 1 args) ": (" (nth 2 args) ")" (car args))
- (insert "*Note " "(" (nth 2 args) ")" (car args) "::"))))
+ (insert "*Note " (nth 1 args) ": (" (nth 2 args) ")" (car args))))
(put 'chapheading 'texinfo-format 'texinfo-format-chapter)
(put 'ichapter 'texinfo-format 'texinfo-format-chapter)
@@ -596,7 +529,6 @@ converted to Info is stored in a temporary buffer."
(defun texinfo-format-chapter-1 (belowchar)
(let ((arg (texinfo-parse-arg-discard)))
- (message "Formatting: %s ... " arg) ; So we can see where we are.
(insert ?\n arg ?\n "@SectionPAD " belowchar ?\n)
(forward-line -2)))
@@ -625,132 +557,6 @@ converted to Info is stored in a temporary buffer."
(texinfo-discard-command)
(let ((indent-tabs-mode nil))
(center-line)))
-
-(put 'sp 'texinfo-format 'texinfo-format-sp)
-(defun texinfo-format-sp ()
- (let* ((arg (texinfo-parse-arg-discard))
- (num (read arg)))
- (insert-char ?\n num)))
-
-(put 'br 'texinfo-format 'texinfo-format-paragraph-break)
-(defun texinfo-format-paragraph-break ()
- "Force a paragraph break.
-If used within a line, follow `@br' with braces."
- (texinfo-optional-braces-discard)
- ;; insert one return if at end of line;
- ;; else insert two returns, to generate a blank line.
- (if (= (following-char) ?\n)
- (insert ?\n)
- (insert-char ?\n 2)))
-
-
-;;; @footnote
-
-; In Texinfo, footnotes are created with the `@footnote' command.
-; This command is followed immediately by a left brace, then by the text of
-; the footnote, and then by a terminating right brace. The
-; template for a footnote is:
-;
-; @footnote{TEXT}
-;
-; Info has two footnote styles:
-;
-; `End Node'
-; In the "End Node" style, all the footnotes for a single node
-; are placed at the end of that node. The footnotes are
-; separated from the rest of the node by a line of dashes with
-; the word `Footnotes' within it.
-;
-; `Make Node'
-; In the "Make Node" style, all the footnotes for a single node are
-; placed in an automatically constructed node of their own.
-
-(put 'footnote 'texinfo-format 'texinfo-format-footnote)
-
-(defvar texinfo-footnote-style 'MN "\
-*Footnote style, either EN for end node or MN for make node.")
-
-(defvar texinfo-footnote-number)
-
-(defun texinfo-format-footnote ()
- "Format a footnote in either `end node' or `make node' style.
-The texinfo-footnote-style variable controls which style is used."
- (setq texinfo-footnote-number (1+ texinfo-footnote-number))
- (cond ((eq texinfo-footnote-style 'EN) (texinfo-format-end-node))
- ((eq texinfo-footnote-style 'MN) (texinfo-format-make-node))))
-
-(defun texinfo-format-make-node ()
- "Format footnote in `MN', Make Node, style with notes in own node.
-The node is constructed automatically."
- (let* (start
- (arg (texinfo-parse-expanded-arg))
- (node-name-beginning
- (save-excursion
- (re-search-backward
- "^File: \\w+\\(\\w\\|\\s_\\|\\.\\)*[ \t]+Node:")
- (match-end 0)))
- (node-name
- (save-excursion
- (buffer-substring
- (progn (goto-char node-name-beginning) ; skip over node command
- (skip-chars-forward " \t") ; and over spaces
- (point))
- (if (search-forward
- ","
- (save-excursion (end-of-line) (point)) t) ; bound search
- (1- (point))
- (end-of-line) (point))))))
- (texinfo-discard-command)
- (insert (format "(%d) (*note %s-Footnotes::)"
- texinfo-footnote-number node-name))
- (fill-paragraph nil)
- (save-excursion
- (if (re-search-forward "^@node" nil 'move)
- (forward-line -1))
-
- ;; two cases: for the first footnote, we must insert a node header;
- ;; for the second and subsequent footnotes, we need only insert
- ;; the text of the footnote.
-
- (if (save-excursion
- (re-search-backward
- (concat node-name "-Footnotes, Up: ")
- node-name-beginning
- t))
- (progn ; already at least one footnote
- (setq start (point))
- (insert (format "\n(%d) %s\n" texinfo-footnote-number arg))
- (fill-region start (point)))
- ;; else not yet a footnote
- (insert "\n\^_\nFile: " texinfo-format-filename
- " Node: " node-name "-Footnotes, Up: " node-name "\n")
- (setq start (point))
- (insert (format "\n(%d) %s\n" texinfo-footnote-number arg))
- (fill-region start (point))))))
-
-(defun texinfo-format-end-node ()
- "Format footnote in `EN', End Node, style with notes at end of node."
- (let (start
- (arg (texinfo-parse-expanded-arg)))
- (texinfo-discard-command)
- (insert (format "(%d) " texinfo-footnote-number))
- (fill-paragraph nil)
- (save-excursion
- (if (search-forward "\n--------- Footnotes ---------\n" nil t)
- (progn ; already have footnote, put new one before end of node
- (if (re-search-forward "^@node" nil 'move)
- (forward-line -1))
- (setq start (point))
- (insert (format "\n(%d) %s\n" texinfo-footnote-number arg))
- (fill-region start (point)))
- ;; else no prior footnote
- (if (re-search-forward "^@node" nil 'move)
- (forward-line -1))
- (insert "\n--------- Footnotes ---------\n")
- (setq start (point))
- (insert (format "\n(%d) %s\n" texinfo-footnote-number arg))
- (fill-region start (point))))))
-
;; @itemize pushes (itemize "COMMANDS" STARTPOS) on texinfo-stack.
;; @enumerate pushes (enumerate 0 STARTPOS).
@@ -869,47 +675,6 @@ The node is constructed automatically."
(itemfont (car (cdr (car texinfo-stack)))))
(insert ?\b itemfont ?\{ arg "}\n \n"))
(forward-line -2))
-
-
-; @ftable
-
-; The `@ftable' command is like the `@table' command but it also
-; inserts each item in the first column into the function index.
-
-(put 'ftable 'texinfo-format 'texinfo-ftable)
-
-; The following function presumes that the first column of the table
-; should be in `@code' font; but the texinfo.tex source does not
-; presume this.
-; (defun texinfo-ftable ()
-; (texinfo-push-stack 'ftable "@code")
-; (setq fill-column (- fill-column 5))
-; (texinfo-discard-line))
-
-(defun texinfo-ftable ()
- (texinfo-push-stack 'ftable (texinfo-parse-arg-discard))
- (setq fill-column (- fill-column 5)))
-
-(put 'ftable 'texinfo-item 'texinfo-ftable-item)
-(defun texinfo-ftable-item ()
- (let ((item (texinfo-parse-arg-discard))
- (itemfont (car (cdr (car texinfo-stack))))
- (indexvar 'texinfo-findex))
- (insert ?\b itemfont ?\{ item "}\n \n")
- (set indexvar
- (cons
- (list item texinfo-last-node)
- (symbol-value indexvar)))
- (forward-line -2)))
-
-(put 'ftable 'texinfo-end 'texinfo-end-ftable)
-(defun texinfo-end-ftable ()
- (setq fill-column (+ fill-column 5))
- (texinfo-discard-command)
- (let ((stacktop
- (texinfo-pop-stack 'ftable)))
- (texinfo-do-itemize (nth 1 stacktop))))
-
(put 'ifinfo 'texinfo-format 'texinfo-discard-line)
(put 'ifinfo 'texinfo-end 'texinfo-discard-command)
@@ -934,30 +699,6 @@ The node is constructed automatically."
(put 'endtitlepage 'texinfo-format 'texinfo-discard-line)
-; @titlespec an alternative titling command; ignored by Info
-
-(put 'titlespec 'texinfo-format 'texinfo-format-titlespec)
-(defun texinfo-format-titlespec ()
- (delete-region texinfo-command-start
- (progn (search-forward "@end titlespec\n")
- (point))))
-
-(put 'endtitlespec 'texinfo-format 'texinfo-discard-line)
-
-; @today{}
-
-(put 'today 'texinfo-format 'texinfo-format-today)
-
-; Produces Day Month Year style of output. eg `1 Jan 1900'
-; The `@today{}' command requires a pair of braces, like `@dots{}'.
-(defun texinfo-format-today ()
- (texinfo-parse-arg-discard)
- (insert (format "%s %s %s"
- (substring (current-time-string) 8 10)
- (substring (current-time-string) 4 7)
- (substring (current-time-string) -4))))
-
-
(put 'ignore 'texinfo-format 'texinfo-format-ignore)
(defun texinfo-format-ignore ()
(delete-region texinfo-command-start
@@ -967,20 +708,15 @@ The node is constructed automatically."
(put 'endignore 'texinfo-format 'texinfo-discard-line)
(put 'var 'texinfo-format 'texinfo-format-var)
-; @sc a small caps font for TeX; formatted as `var' in Info
-(put 'sc 'texinfo-format 'texinfo-format-var)
(defun texinfo-format-var ()
(insert (upcase (texinfo-parse-arg-discard)))
(goto-char texinfo-command-start))
-; various noops
-
(put 'asis 'texinfo-format 'texinfo-format-noop)
(put 'b 'texinfo-format 'texinfo-format-noop)
(put 't 'texinfo-format 'texinfo-format-noop)
(put 'i 'texinfo-format 'texinfo-format-noop)
(put 'r 'texinfo-format 'texinfo-format-noop)
-(put 'titlefont 'texinfo-format 'texinfo-format-noop)
(put 'key 'texinfo-format 'texinfo-format-noop)
(put 'w 'texinfo-format 'texinfo-format-noop)
(defun texinfo-format-noop ()
@@ -1010,13 +746,10 @@ The node is constructed automatically."
(put 'bullet 'texinfo-format 'texinfo-format-bullet)
(defun texinfo-format-bullet ()
- "Insert an asterisk.
-If used within a line, follow `@bullet' with braces."
- (texinfo-optional-braces-discard)
+ (texinfo-discard-command)
(insert "*"))
(put 'smallexample 'texinfo-format 'texinfo-format-example)
-(put 'smalllisp 'texinfo-format 'texinfo-format-example)
(put 'example 'texinfo-format 'texinfo-format-example)
(put 'quotation 'texinfo-format 'texinfo-format-example)
(put 'lisp 'texinfo-format 'texinfo-format-example)
@@ -1056,41 +789,6 @@ If used within a line, follow `@bullet' with braces."
(end-of-line)
(insert "\n ")))
-
-;; @flushright ... @end flushright
-
-; The @flushright command right justifies every line but leaves the
-; left end ragged.
-
-(put 'flushright 'texinfo-format 'texinfo-format-flushright)
-(defun texinfo-format-flushright ()
- (texinfo-push-stack 'flushright nil)
- (texinfo-discard-line))
-
-(put 'flushright 'texinfo-end 'texinfo-end-flushright)
-(defun texinfo-end-flushright ()
- (texinfo-discard-command)
-
- (let ((stacktop
- (texinfo-pop-stack 'flushright)))
-
- (texinfo-do-flushright (nth 1 stacktop))))
-
-(defun texinfo-do-flushright (from)
- (save-excursion
- (while (progn (forward-line -1)
- (>= (point) from))
-
- (beginning-of-line)
- (insert
- (make-string
- (- fill-column
- (save-excursion
- (end-of-line)
- (current-column)))
- ? )))))
-
-
(put 'ctrl 'texinfo-format 'texinfo-format-ctrl)
(defun texinfo-format-ctrl ()
(let ((str (texinfo-parse-arg-discard)))
@@ -1108,9 +806,7 @@ If used within a line, follow `@bullet' with braces."
(put 'minus 'texinfo-format 'texinfo-format-minus)
(defun texinfo-format-minus ()
- "Insert a minus sign.
-If used within a line, follow `@minus' with braces."
- (texinfo-optional-braces-discard)
+ (texinfo-parse-arg-discard)
(insert "-"))
(put 'dots 'texinfo-format 'texinfo-format-dots)
@@ -1123,8 +819,12 @@ If used within a line, follow `@minus' with braces."
(texinfo-discard-command)
(fill-paragraph nil))
+(put 'sp 'texinfo-format 'texinfo-format-sp)
+(defun texinfo-format-sp ()
+ (texinfo-discard-command)
+ (insert "\n"))
-;;; Index generation
+;; Index generation
(put 'vindex 'texinfo-format 'texinfo-format-vindex)
(defun texinfo-format-vindex ()
@@ -1165,83 +865,7 @@ If used within a line, follow `@minus' with braces."
("pg" . texinfo-pindex)
("ky" . texinfo-kindex)))
-
-;;; @defindex @defcodeindex
-(put 'defindex 'texinfo-format 'texinfo-format-defindex)
-(put 'defcodeindex 'texinfo-format 'texinfo-format-defindex)
-
-(defun texinfo-format-defindex ()
- (let* ((index-name (texinfo-parse-arg-discard)) ; eg: `aa'
- (indexing-command (intern (concat index-name "index")))
- (index-formatting-command ; eg: `texinfo-format-aaindex'
- (intern (concat "texinfo-format-" index-name "index")))
- (index-alist-name ; eg: `texinfo-aaindex'
- (intern (concat "texinfo-" index-name "index"))))
-
- (set index-alist-name nil)
-
- (put indexing-command ; eg, aaindex
- 'texinfo-format
- index-formatting-command) ; eg, texinfo-format-aaindex
-
- ;; eg: "aa" . texinfo-aaindex
- (or (assoc index-name texinfo-indexvar-alist)
- (setq texinfo-indexvar-alist
- (cons
- (cons index-name
- index-alist-name)
- texinfo-indexvar-alist)))
-
- (fset index-formatting-command
- (list 'lambda 'nil
- (list 'texinfo-index
- (list 'quote index-alist-name))))))
-
-
-;;; @synindex @syncodeindex
-
-(put 'synindex 'texinfo-format 'texinfo-format-synindex)
-(put 'syncodeindex 'texinfo-format 'texinfo-format-synindex)
-
-(defun texinfo-format-synindex ()
- (let* ((args (texinfo-parse-arg-discard))
- (second (cdr (read-from-string args)))
- (joiner (symbol-name (car (read-from-string args))))
- (joined (symbol-name (car (read-from-string args second)))))
-
- (if (assoc joiner texinfo-short-index-cmds-alist)
- (put
- (cdr (assoc joiner texinfo-short-index-cmds-alist))
- 'texinfo-format
- (or (cdr (assoc joined texinfo-short-index-format-cmds-alist))
- (intern (concat "texinfo-format-" joined "index"))))
- (put
- (intern (concat joiner "index"))
- 'texinfo-format
- (or (cdr(assoc joined texinfo-short-index-format-cmds-alist))
- (intern (concat "texinfo-format-" joined "index")))))))
-
-(defconst texinfo-short-index-cmds-alist
- '(("cp" . cindex)
- ("fn" . findex)
- ("vr" . vindex)
- ("tp" . tindex)
- ("pg" . pindex)
- ("ky" . kindex)))
-
-(defconst texinfo-short-index-format-cmds-alist
- '(("cp" . texinfo-format-cindex)
- ("fn" . texinfo-format-findex)
- ("vr" . texinfo-format-vindex)
- ("tp" . texinfo-format-tindex)
- ("pg" . texinfo-format-pindex)
- ("ky" . texinfo-format-kindex)))
-
-
-;;; @printindex
-
(put 'printindex 'texinfo-format 'texinfo-format-printindex)
-
(defun texinfo-format-printindex ()
(let ((indexelts (symbol-value
(cdr (assoc (texinfo-parse-arg-discard)
@@ -1250,9 +874,8 @@ If used within a line, follow `@minus' with braces."
(insert "\n* Menu:\n\n")
(setq opoint (point))
(texinfo-print-index nil indexelts)
-
- (if (eq system-type 'vax-vms)
- (texinfo-sort-region opoint (point))
+ (if (eq system-type 'vax-vms)
+ (texinfo-sort-region opoint (point))
(shell-command-on-region opoint (point) "sort -fd" 1))))
(defun texinfo-print-index (file indexelts)
@@ -1267,47 +890,7 @@ If used within a line, follow `@minus' with braces."
(setq indexelts (cdr indexelts))))
-;;; NOTATIONS: @equiv, @error, etc
-
-;; @equiv to show that two expressions are equivalent
-;; @error to show an error message
-;; @expansion to show what a macro expands to
-;; @point to show the location of point in an example
-;; @print to show what an evaluated expression prints
-;; @result to indicate the value returned by an expression
-
-(put 'equiv 'texinfo-format 'texinfo-format-equiv)
-(defun texinfo-format-equiv ()
- (texinfo-parse-arg-discard)
- (insert "=="))
-
-(put 'error 'texinfo-format 'texinfo-format-error)
-(defun texinfo-format-error ()
- (texinfo-parse-arg-discard)
- (insert "error-->"))
-
-(put 'expansion 'texinfo-format 'texinfo-format-expansion)
-(defun texinfo-format-expansion ()
- (texinfo-parse-arg-discard)
- (insert "==>"))
-
-(put 'point 'texinfo-format 'texinfo-format-point)
-(defun texinfo-format-point ()
- (texinfo-parse-arg-discard)
- (insert "-!-"))
-
-(put 'print 'texinfo-format 'texinfo-format-print)
-(defun texinfo-format-print ()
- (texinfo-parse-arg-discard)
- (insert "-|"))
-
-(put 'result 'texinfo-format 'texinfo-format-result)
-(defun texinfo-format-result ()
- (texinfo-parse-arg-discard)
- (insert "=>"))
-
-
-;;;; Description formatting: @deffn, @defun, etc
+;;;; Lisp Definitions
(defun texinfo-format-defun ()
(texinfo-push-stack 'defun nil)
@@ -1319,115 +902,34 @@ If used within a line, follow `@minus' with braces."
(defun texinfo-format-defun-1 (first-p)
(let ((args (texinfo-format-parse-defun-args))
- (command-type (get texinfo-command-name 'texinfo-defun-type))
- (class "")
- (name "")
- (classification "")
- (data-type ""))
+ (type (get texinfo-command-name 'texinfo-defun-type)))
(texinfo-discard-command)
-
- (cond
- ;; Generalized object oriented entity: `category class name [args...]'
- ;; In Info, `Category on class: name ARG'
- ((eq (eval (car command-type)) 'defop-type)
- (setq category (car args))
- (setq class (car (cdr args)))
- (setq name (car args))
- (setq args (cdr (cdr args))))
-
- ;; Specialized object oriented entity: @defmethod, @defivar
- ;; "Instance Variable" `class name [args...]'
- ;; In Info, `Instance variable of class: name'
- ((eq (eval (car command-type)) 'defmethod-type)
- (setq category (car (cdr command-type)))
- (setq class (car args))
- (setq name (car args))
- (setq args (cdr args)))
-
- ;; Generalized function-like or variable-like entity:
- ;; `category name [args...]'
- ;; In Info, `Category: name ARGS'
- ((or (eq (eval (car command-type)) 'deffn-type)
- (eq (eval (car command-type)) 'deftp-type))
- (setq category (car args))
- (setq args (cdr args))
- (setq name (car args)))
-
- ;; Specialized function-like or variable-like entity:
- ;; "Macro" `name [args...]'
- ;; In Info, `Macro: Name ARGS'
- ((eq (eval (car command-type)) 'defun-type)
- (setq category (car (cdr command-type)))
- (setq name (car args)))
-
- ;; Generalized typed-function-like or typed-variable-like entity:
- ;; `Classification data-type name [args...]'
- ;; In Info, `Classification: data-type name ARGS'
- ((or (eq (eval (car command-type)) 'deftypefn-type)
- (eq (eval (car command-type)) 'deftypevr-type))
- (setq classification (car args))
- (setq data-type (car (cdr args)))
- (setq name (car (cdr (cdr args))))
- (setq args (cdr (cdr (cdr args)))))
-
- ;; Specialized typed-function-like or typed-variable-like entity:
- ;; `data-type name [args...]'
- ;; In Info, `Function: data-type name ARGS'
- ;; or, `Variable: data-type name'
- ((or (eq (eval (car command-type)) 'deftypefun-type)
- (eq (eval (car command-type)) 'deftypevar-type))
- (setq classification (car (cdr command-type)))
- (setq data-type (car args))
- (setq name (car (cdr args)))
- (setq args (cdr (cdr args)))))
-
+ (if (eq type 'arg)
+ (progn (setq type (car args))
+ (setq args (cdr args))))
+ (let ((formatter (get texinfo-command-name 'texinfo-defun-format-type)))
+ (if formatter
+ (setq type (funcall formatter type args))))
;; Delete extra newline inserted after previous header line.
(if (not first-p)
(delete-char -1))
-
- (let ((formatter (get texinfo-command-name 'texinfo-defun-format-type)))
- (cond
- ;; if typed function or variable
- ((eq formatter 'texinfo-format-deftypefn-type)
- (insert "* " classification ": " data-type " " name)
- (let ((args args))
- (while args
- (insert " " (car args))
- (setq args (cdr args)))))
- (t
- ;; and if object oriented, set category
- (if (or (eq formatter 'texinfo-format-defop-type)
- (eq formatter 'texinfo-format-defcv-type))
- (setq category (funcall formatter category class)))
- (insert "* " category ": " name)
- (let ((args (cdr args)))
- (while args
- (insert " "
- (if (or (= ?& (aref (car args) 0))
- (eq (eval (car command-type)) 'deftp-type))
- (car args)
- (upcase (car args))))
- (setq args (cdr args)))))))
-
+ (insert "* " type ": " (car args))
+ (let ((args (cdr args)))
+ (while args
+ (insert " "
+ (if (= ?& (aref (car args) 0))
+ (car args)
+ (upcase (car args))))
+ (setq args (cdr args))))
;; Insert extra newline so that paragraph filling does not mess
;; with header line.
(insert "\n\n")
(rplaca (cdr (cdr (car texinfo-stack))) (point))
-
(let ((indexvar (get texinfo-command-name 'texinfo-defun-index))
- (index-formatter
- (get texinfo-command-name 'texinfo-defun-format-index)))
+ (formatter (get texinfo-command-name 'texinfo-defun-format-index)))
(set indexvar
- (cons (list
- (cond
- ;; if object oriented
- ((or (eq index-formatter 'texinfo-format-defop-index)
- (eq index-formatter 'texinfo-format-defcv-index))
- (funcall index-formatter name class))
- ((eq index-formatter 'texinfo-format-deftypefn-index)
- (funcall index-formatter name data-type))
- (t (car args)))
- texinfo-last-node)
+ (cons (list (if formatter (funcall formatter type args) (car args))
+ texinfo-last-node)
(symbol-value indexvar))))))
(defun texinfo-end-defun ()
@@ -1440,95 +942,67 @@ If used within a line, follow `@minus' with braces."
(goto-char start)
(delete-char -1))))
-(defun texinfo-format-defop-type (category class)
- (format "%s on %s" category class))
-
-(defun texinfo-format-defop-index (name class)
- (format "%s on %s" name class))
-
-(defun texinfo-format-defcv-type (category class)
- (format "%s of %s" category class))
-
-(defun texinfo-format-defcv-index (name class)
- (format "%s of %s" name class))
-
(put 'deffn 'texinfo-format 'texinfo-format-defun)
(put 'deffnx 'texinfo-format 'texinfo-format-defunx)
(put 'deffn 'texinfo-end 'texinfo-end-defun)
-(put 'deffn 'texinfo-defun-type '('deffn-type nil))
-(put 'deffnx 'texinfo-defun-type '('deffn-type nil))
+(put 'deffn 'texinfo-defun-type 'arg)
+(put 'deffnx 'texinfo-defun-type 'arg)
(put 'deffn 'texinfo-defun-index 'texinfo-findex)
(put 'deffnx 'texinfo-defun-index 'texinfo-findex)
(put 'defun 'texinfo-format 'texinfo-format-defun)
(put 'defunx 'texinfo-format 'texinfo-format-defunx)
(put 'defun 'texinfo-end 'texinfo-end-defun)
-(put 'defun 'texinfo-defun-type '('defun-type "Function"))
-(put 'defunx 'texinfo-defun-type '('defun-type "Function"))
+(put 'defun 'texinfo-defun-type "Function")
+(put 'defunx 'texinfo-defun-type "Function")
(put 'defun 'texinfo-defun-index 'texinfo-findex)
(put 'defunx 'texinfo-defun-index 'texinfo-findex)
(put 'defmac 'texinfo-format 'texinfo-format-defun)
(put 'defmacx 'texinfo-format 'texinfo-format-defunx)
(put 'defmac 'texinfo-end 'texinfo-end-defun)
-(put 'defmac 'texinfo-defun-type '('defun-type "Macro"))
-(put 'defmacx 'texinfo-defun-type '('defun-type "Macro"))
+(put 'defmac 'texinfo-defun-type "Macro")
+(put 'defmacx 'texinfo-defun-type "Macro")
(put 'defmac 'texinfo-defun-index 'texinfo-findex)
(put 'defmacx 'texinfo-defun-index 'texinfo-findex)
(put 'defspec 'texinfo-format 'texinfo-format-defun)
(put 'defspecx 'texinfo-format 'texinfo-format-defunx)
(put 'defspec 'texinfo-end 'texinfo-end-defun)
-(put 'defspec 'texinfo-defun-type '('defun-type "Special form"))
-(put 'defspecx 'texinfo-defun-type '('defun-type "Special form"))
+(put 'defspec 'texinfo-defun-type "Special form")
+(put 'defspecx 'texinfo-defun-type "Special form")
(put 'defspec 'texinfo-defun-index 'texinfo-findex)
(put 'defspecx 'texinfo-defun-index 'texinfo-findex)
(put 'defvr 'texinfo-format 'texinfo-format-defun)
(put 'defvrx 'texinfo-format 'texinfo-format-defunx)
(put 'defvr 'texinfo-end 'texinfo-end-defun)
-(put 'defvr 'texinfo-defun-type '('deffn-type nil))
-(put 'defvrx 'texinfo-defun-type '('deffn-type nil))
+(put 'defvr 'texinfo-defun-type 'arg)
+(put 'defvrx 'texinfo-defun-type 'arg)
(put 'defvr 'texinfo-defun-index 'texinfo-vindex)
(put 'defvrx 'texinfo-defun-index 'texinfo-vindex)
(put 'defvar 'texinfo-format 'texinfo-format-defun)
(put 'defvarx 'texinfo-format 'texinfo-format-defunx)
(put 'defvar 'texinfo-end 'texinfo-end-defun)
-(put 'defvar 'texinfo-defun-type '('defun-type "Variable"))
-(put 'defvarx 'texinfo-defun-type '('defun-type "Variable"))
+(put 'defvar 'texinfo-defun-type "Variable")
+(put 'defvarx 'texinfo-defun-type "Variable")
(put 'defvar 'texinfo-defun-index 'texinfo-vindex)
(put 'defvarx 'texinfo-defun-index 'texinfo-vindex)
-(put 'defconst 'texinfo-format 'texinfo-format-defun)
-(put 'defconstx 'texinfo-format 'texinfo-format-defunx)
-(put 'defconst 'texinfo-end 'texinfo-end-defun)
-(put 'defconst 'texinfo-defun-type '('defun-type "Constant"))
-(put 'defconstx 'texinfo-defun-type '('defun-type "Constant"))
-(put 'defconst 'texinfo-defun-index 'texinfo-vindex)
-(put 'defconstx 'texinfo-defun-index 'texinfo-vindex)
-
-(put 'defcmd 'texinfo-format 'texinfo-format-defun)
-(put 'defcmdx 'texinfo-format 'texinfo-format-defunx)
-(put 'defcmd 'texinfo-end 'texinfo-end-defun)
-(put 'defcmd 'texinfo-defun-type '('defun-type "Command"))
-(put 'defcmdx 'texinfo-defun-type '('defun-type "Command"))
-(put 'defcmd 'texinfo-defun-index 'texinfo-findex)
-(put 'defcmdx 'texinfo-defun-index 'texinfo-findex)
-
(put 'defopt 'texinfo-format 'texinfo-format-defun)
(put 'defoptx 'texinfo-format 'texinfo-format-defunx)
(put 'defopt 'texinfo-end 'texinfo-end-defun)
-(put 'defopt 'texinfo-defun-type '('defun-type "User Option"))
-(put 'defoptx 'texinfo-defun-type '('defun-type "User Option"))
+(put 'defopt 'texinfo-defun-type "User Option")
+(put 'defoptx 'texinfo-defun-type "User Option")
(put 'defopt 'texinfo-defun-index 'texinfo-vindex)
(put 'defoptx 'texinfo-defun-index 'texinfo-vindex)
(put 'deftp 'texinfo-format 'texinfo-format-defun)
(put 'deftpx 'texinfo-format 'texinfo-format-defunx)
(put 'deftp 'texinfo-end 'texinfo-end-defun)
-(put 'deftp 'texinfo-defun-type '('deftp-type nil))
-(put 'deftpx 'texinfo-defun-type '('deftp-type nil))
+(put 'deftp 'texinfo-defun-type 'arg)
+(put 'deftpx 'texinfo-defun-type 'arg)
(put 'deftp 'texinfo-defun-index 'texinfo-tindex)
(put 'deftpx 'texinfo-defun-index 'texinfo-tindex)
@@ -1537,8 +1011,8 @@ If used within a line, follow `@minus' with braces."
(put 'defop 'texinfo-format 'texinfo-format-defun)
(put 'defopx 'texinfo-format 'texinfo-format-defunx)
(put 'defop 'texinfo-end 'texinfo-end-defun)
-(put 'defop 'texinfo-defun-type '('defop-type nil))
-(put 'defopx 'texinfo-defun-type '('defop-type nil))
+(put 'defop 'texinfo-defun-type 'arg)
+(put 'defopx 'texinfo-defun-type 'arg)
(put 'defop 'texinfo-defun-format-type 'texinfo-format-defop-type)
(put 'defopx 'texinfo-defun-format-type 'texinfo-format-defop-type)
(put 'defop 'texinfo-defun-index 'texinfo-findex)
@@ -1549,8 +1023,8 @@ If used within a line, follow `@minus' with braces."
(put 'defmethod 'texinfo-format 'texinfo-format-defun)
(put 'defmethodx 'texinfo-format 'texinfo-format-defunx)
(put 'defmethod 'texinfo-end 'texinfo-end-defun)
-(put 'defmethod 'texinfo-defun-type '('defmethod-type "Operation"))
-(put 'defmethodx 'texinfo-defun-type '('defmethod-type "Operation"))
+(put 'defmethod 'texinfo-defun-type "Operation")
+(put 'defmethodx 'texinfo-defun-type "Operation")
(put 'defmethod 'texinfo-defun-format-type 'texinfo-format-defop-type)
(put 'defmethodx 'texinfo-defun-format-type 'texinfo-format-defop-type)
(put 'defmethod 'texinfo-defun-index 'texinfo-findex)
@@ -1558,11 +1032,17 @@ If used within a line, follow `@minus' with braces."
(put 'defmethod 'texinfo-defun-format-index 'texinfo-format-defop-index)
(put 'defmethodx 'texinfo-defun-format-index 'texinfo-format-defop-index)
+(defun texinfo-format-defop-type (type args)
+ (format "%s on %s" type (car args)))
+
+(defun texinfo-format-defop-index (type args)
+ (format "%s on %s" (car (cdr args)) (car args)))
+
(put 'defcv 'texinfo-format 'texinfo-format-defun)
(put 'defcvx 'texinfo-format 'texinfo-format-defunx)
(put 'defcv 'texinfo-end 'texinfo-end-defun)
-(put 'defcv 'texinfo-defun-type '('defop-type nil))
-(put 'defcvx 'texinfo-defun-type '('defop-type nil))
+(put 'defcv 'texinfo-defun-type 'arg)
+(put 'defcvx 'texinfo-defun-type 'arg)
(put 'defcv 'texinfo-defun-format-type 'texinfo-format-defcv-type)
(put 'defcvx 'texinfo-defun-format-type 'texinfo-format-defcv-type)
(put 'defcv 'texinfo-defun-index 'texinfo-vindex)
@@ -1573,8 +1053,8 @@ If used within a line, follow `@minus' with braces."
(put 'defivar 'texinfo-format 'texinfo-format-defun)
(put 'defivarx 'texinfo-format 'texinfo-format-defunx)
(put 'defivar 'texinfo-end 'texinfo-end-defun)
-(put 'defivar 'texinfo-defun-type '('defmethod-type "Instance variable"))
-(put 'defivarx 'texinfo-defun-type '('defmethod-type "Instance variable"))
+(put 'defivar 'texinfo-defun-type "Instance variable")
+(put 'defivarx 'texinfo-defun-type "Instance variable")
(put 'defivar 'texinfo-defun-format-type 'texinfo-format-defcv-type)
(put 'defivarx 'texinfo-defun-format-type 'texinfo-format-defcv-type)
(put 'defivar 'texinfo-defun-index 'texinfo-vindex)
@@ -1582,140 +1062,58 @@ If used within a line, follow `@minus' with braces."
(put 'defivar 'texinfo-defun-format-index 'texinfo-format-defcv-index)
(put 'defivarx 'texinfo-defun-format-index 'texinfo-format-defcv-index)
-;;; Typed functions and variables
-
-(defun texinfo-format-deftypefn-type (classification data-type)
- (format "%s" classification data-type))
-
-(defun texinfo-format-deftypefn-index (name data-type)
- (format "%s of type %s" name data-type))
-
-
-(put 'deftypefn 'texinfo-format 'texinfo-format-defun)
-(put 'deftypefnx 'texinfo-format 'texinfo-format-defunx)
-(put 'deftypefn 'texinfo-end 'texinfo-end-defun)
-(put 'deftypefn 'texinfo-defun-type '('deftypefn-type nil))
-(put 'deftypefnx 'texinfo-defun-type '('deftypefn-type nil))
-(put 'deftypefn 'texinfo-defun-format-type 'texinfo-format-deftypefn-type)
-(put 'deftypefnx 'texinfo-defun-format-type 'texinfo-format-deftypefn-type)
-(put 'deftypefn 'texinfo-defun-index 'texinfo-findex)
-(put 'deftypefnx 'texinfo-defun-index 'texinfo-findex)
-(put 'deftypefn 'texinfo-defun-format-index 'texinfo-format-deftypefn-index)
-(put 'deftypefnx 'texinfo-defun-format-index 'texinfo-format-deftypefn-index)
-
-(put 'deftypefun 'texinfo-format 'texinfo-format-defun)
-(put 'deftypefunx 'texinfo-format 'texinfo-format-defunx)
-(put 'deftypefun 'texinfo-end 'texinfo-end-defun)
-(put 'deftypefun 'texinfo-defun-type '('deftypefun-type "Function"))
-(put 'deftypefunx 'texinfo-defun-type '('deftypefun-type "Function"))
-(put 'deftypefun 'texinfo-defun-format-type 'texinfo-format-deftypefn-type)
-(put 'deftypefunx 'texinfo-defun-format-type 'texinfo-format-deftypefn-type)
-(put 'deftypefun 'texinfo-defun-index 'texinfo-findex)
-(put 'deftypefunx 'texinfo-defun-index 'texinfo-findex)
-(put 'deftypefun 'texinfo-defun-format-index 'texinfo-format-deftypefn-index)
-(put 'deftypefunx 'texinfo-defun-format-index 'texinfo-format-deftypefn-index)
-
-(put 'deftypevr 'texinfo-format 'texinfo-format-defun)
-(put 'deftypevrx 'texinfo-format 'texinfo-format-defunx)
-(put 'deftypevr 'texinfo-end 'texinfo-end-defun)
-(put 'deftypevr 'texinfo-defun-type '('deftypefn-type nil))
-(put 'deftypevrx 'texinfo-defun-type '('deftypefn-type nil))
-(put 'deftypevr 'texinfo-defun-format-type 'texinfo-format-deftypefn-type)
-(put 'deftypevrx 'texinfo-defun-format-type 'texinfo-format-deftypefn-type)
-(put 'deftypevr 'texinfo-defun-index 'texinfo-vindex)
-(put 'deftypevrx 'texinfo-defun-index 'texinfo-vindex)
-(put 'deftypevr 'texinfo-defun-format-index 'texinfo-format-deftypefn-index)
-(put 'deftypevrx 'texinfo-defun-format-index 'texinfo-format-deftypefn-index)
-
-(put 'deftypevar 'texinfo-format 'texinfo-format-defun)
-(put 'deftypevarx 'texinfo-format 'texinfo-format-defunx)
-(put 'deftypevar 'texinfo-end 'texinfo-end-defun)
-(put 'deftypevar 'texinfo-defun-type '('deftypevar-type "Variable"))
-(put 'deftypevarx 'texinfo-defun-type '('deftypevar-type "Variable"))
-(put 'deftypevar 'texinfo-defun-format-type 'texinfo-format-deftypefn-type)
-(put 'deftypevarx 'texinfo-defun-format-type 'texinfo-format-deftypefn-type)
-(put 'deftypevar 'texinfo-defun-index 'texinfo-vindex)
-(put 'deftypevarx 'texinfo-defun-index 'texinfo-vindex)
-(put 'deftypevar 'texinfo-defun-format-index 'texinfo-format-deftypefn-index)
-(put 'deftypevarx 'texinfo-defun-format-index 'texinfo-format-deftypefn-index)
+(defun texinfo-format-defcv-type (type args)
+ (format "%s of %s" type (car args)))
+(defun texinfo-format-defcv-index (type args)
+ (format "%s of %s" (car (cdr args)) (car args)))
-;; process included files: `@include' command
-
-;; Updated 19 October 1990
-;; In the original version, include files were ignored by Info but
-;; incorporated in to the printed manual. To make references to the
-;; included file, the Texinfo source file has to refer to the included
-;; files using the `(filename)nodename' format for refering to other
-;; Info files. Also, the included files had to be formatted on their
-;; own. It was just like they were another file.
-
-;; Currently, include files are inserted into the buffer that is
-;; formatted for Info. If large, the resulting info file is split and
-;; tagified. For current include files to work, the master menu must
-;; refer to all the nodes, and the highest level nodes in the include
-;; files must have the correct next, prev, and up pointers.
-
-;; The included file may have an @setfilename and even an @settitle,
-;; but not an /input texinfo
-
-; Original definition:
-; (defun texinfo-format-include ()
-; (let ((filename (texinfo-parse-arg-discard))
-; (default-directory input-directory)
-; subindex)
-; (setq subindex
-; (save-excursion
-; (progn (find-file
-; (cond ((file-readable-p (concat filename ".texinfo"))
-; (concat filename ".texinfo"))
-; ((file-readable-p (concat filename ".texi"))
-; (concat filename ".texi"))
-; ((file-readable-p (concat filename ".tex"))
-; (concat filename ".tex"))
-; ((file-readable-p filename)
-; filename)
-; (t (error "@include'd file %s not found"
-; filename))))
-; (texinfo-format-buffer-1))))
-; (texinfo-subindex 'texinfo-vindex (car subindex) (nth 1 subindex))
-; (texinfo-subindex 'texinfo-findex (car subindex) (nth 2 subindex))
-; (texinfo-subindex 'texinfo-cindex (car subindex) (nth 3 subindex))
-; (texinfo-subindex 'texinfo-pindex (car subindex) (nth 4 subindex))
-; (texinfo-subindex 'texinfo-tindex (car subindex) (nth 5 subindex))
-; (texinfo-subindex 'texinfo-kindex (car subindex) (nth 6 subindex))))
+;; process included files
+(put 'include 'texinfo-format 'texinfo-format-include)
+(defun texinfo-format-include ()
+ (let ((filename (texinfo-parse-arg-discard))
+ (default-directory input-directory)
+ subindex)
+ (setq subindex
+ (save-excursion
+ (progn (find-file
+ (cond ((file-readable-p (concat filename ".texinfo"))
+ (concat filename ".texinfo"))
+ ((file-readable-p (concat filename ".tex"))
+ (concat filename ".tex"))
+ ((file-readable-p filename)
+ filename)
+ (t (error "@include'd file %s not found"
+ filename))))
+ (texinfo-format-buffer-1))))
+ (texinfo-subindex 'texinfo-vindex (car subindex) (nth 1 subindex))
+ (texinfo-subindex 'texinfo-findex (car subindex) (nth 2 subindex))
+ (texinfo-subindex 'texinfo-cindex (car subindex) (nth 3 subindex))
+ (texinfo-subindex 'texinfo-pindex (car subindex) (nth 4 subindex))
+ (texinfo-subindex 'texinfo-tindex (car subindex) (nth 5 subindex))
+ (texinfo-subindex 'texinfo-kindex (car subindex) (nth 6 subindex))))
(defun texinfo-subindex (indexvar file content)
(set indexvar (cons (list 'recurse file content)
(symbol-value indexvar))))
-(put 'include 'texinfo-format 'texinfo-format-include)
-(defun texinfo-format-include ()
- (let ((filename (concat input-directory
- (texinfo-parse-arg-discard)))
- (default-directory input-directory))
- (message "Reading: %s" filename)
- (save-excursion
- (insert-file-contents filename)))
- (setq last-input-buffer input-buffer) ; to bypass setfilename
- )
-
-
;; Lots of bolio constructs do nothing in texinfo.
+(put 'need 'texinfo-format 'texinfo-discard-line-with-args)
(put 'page 'texinfo-format 'texinfo-discard-line-with-args)
(put 'c 'texinfo-format 'texinfo-discard-line-with-args)
(put 'comment 'texinfo-format 'texinfo-discard-line-with-args)
(put 'setchapternewpage 'texinfo-format 'texinfo-discard-line-with-args)
(put 'contents 'texinfo-format 'texinfo-discard-line-with-args)
(put 'summarycontents 'texinfo-format 'texinfo-discard-line-with-args)
-(put 'shortcontents 'texinfo-format 'texinfo-discard-line-with-args)
(put 'nopara 'texinfo-format 'texinfo-discard-line-with-args)
(put 'noindent 'texinfo-format 'texinfo-discard-line-with-args)
(put 'setx 'texinfo-format 'texinfo-discard-line-with-args)
(put 'setq 'texinfo-format 'texinfo-discard-line-with-args)
(put 'settitle 'texinfo-format 'texinfo-discard-line-with-args)
+(put 'defindex 'texinfo-format 'texinfo-discard-line-with-args)
+(put 'synindex 'texinfo-format 'texinfo-discard-line-with-args)
(put 'hsize 'texinfo-format 'texinfo-discard-line-with-args)
(put 'parindent 'texinfo-format 'texinfo-discard-line-with-args)
(put 'lispnarrowing 'texinfo-format 'texinfo-discard-line-with-args)
@@ -1723,7 +1121,6 @@ If used within a line, follow `@minus' with braces."
(put 'headings 'texinfo-format 'texinfo-discard-line-with-args)
(put 'group 'texinfo-format 'texinfo-discard-line-with-args)
(put 'group 'texinfo-end 'texinfo-discard-line-with-args)
-(put 'need 'texinfo-format 'texinfo-discard-line-with-args)
(put 'bye 'texinfo-format 'texinfo-discard-line)
(put 'smallbook 'texinfo-format 'texinfo-discard-line)
@@ -1793,7 +1190,7 @@ For example, invoke
(progn
(if buffer-file-name (kill-buffer (current-buffer)))
(find-file file)
- (buffer-disable-undo (current-buffer))
+ (buffer-flush-undo (current-buffer))
(set-buffer-modified-p nil)
(texinfo-mode)
(message "texinfo formatting %s..." file)
diff --git a/lisp/texinfmt.elc b/lisp/texinfmt.elc
new file mode 100644
index 00000000000..b27eefe2632
--- /dev/null
+++ b/lisp/texinfmt.elc
Binary files differ
diff --git a/lisp/texinfo.el b/lisp/texinfo.el
new file mode 100644
index 00000000000..32306d5edd8
--- /dev/null
+++ b/lisp/texinfo.el
@@ -0,0 +1,175 @@
+;; Major mode for editing texinfo files.
+;; Copyright (C) 1985, 1988 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+(defvar texinfo-mode-syntax-table nil)
+
+(if texinfo-mode-syntax-table
+ nil
+ (setq texinfo-mode-syntax-table (make-syntax-table))
+ (modify-syntax-entry ?\" " " texinfo-mode-syntax-table)
+ (modify-syntax-entry ?\\ " " texinfo-mode-syntax-table)
+ (modify-syntax-entry ?@ "\\" texinfo-mode-syntax-table)
+ (modify-syntax-entry ?\^q "\\" texinfo-mode-syntax-table)
+ (modify-syntax-entry ?\[ "(]" texinfo-mode-syntax-table)
+ (modify-syntax-entry ?\] ")[" texinfo-mode-syntax-table)
+ (modify-syntax-entry ?{ "(}" texinfo-mode-syntax-table)
+ (modify-syntax-entry ?} "){" texinfo-mode-syntax-table)
+ (modify-syntax-entry ?\' "w" texinfo-mode-syntax-table))
+
+(defvar texinfo-mode-map nil)
+
+(if texinfo-mode-map
+ nil
+ (setq texinfo-mode-map (make-sparse-keymap))
+ (define-key texinfo-mode-map "\C-c\C-f" 'texinfo-format-region)
+ (define-key texinfo-mode-map "\C-c\C-s" 'texinfo-show-structure)
+ (define-key texinfo-mode-map "\e}" 'up-list)
+ (define-key texinfo-mode-map "\e{" 'texinfo-insert-braces)
+ (define-key texinfo-mode-map "\C-c\C-cv" 'texinfo-insert-@var)
+ (define-key texinfo-mode-map "\C-c\C-cs" 'texinfo-insert-@samp)
+ (define-key texinfo-mode-map "\C-c\C-cn" 'texinfo-insert-@node)
+ (define-key texinfo-mode-map "\C-c\C-ci" 'texinfo-insert-@item)
+ (define-key texinfo-mode-map "\C-c\C-ce" 'texinfo-insert-@end)
+ (define-key texinfo-mode-map "\C-c\C-cd" 'texinfo-insert-@dfn)
+ (define-key texinfo-mode-map "\C-c\C-cc" 'texinfo-insert-@code))
+
+(defun texinfo-insert-@var ()
+ "Insert the string @var in a texinfo buffer."
+ (interactive)
+ (insert "@var{}")
+ (backward-char))
+
+(defun texinfo-insert-@samp ()
+ "Insert the string @samp in a texinfo buffer."
+ (interactive)
+ (insert "@samp{}")
+ (backward-char))
+
+(defun texinfo-insert-@node ()
+ "Insert the string @node in a texinfo buffer,
+along with a comment indicating the arguments to @node."
+ (interactive)
+ (insert "@node \n@comment node-name, next, previous, up")
+ (forward-line -1)
+ (forward-char 6))
+
+(defun texinfo-insert-@item ()
+ "Insert the string @item in a texinfo buffer."
+ (interactive)
+ (insert "@item")
+ (newline))
+
+(defun texinfo-insert-@end ()
+ "Insert the string @end in a texinfo buffer."
+ (interactive)
+ (insert "@end "))
+
+(defun texinfo-insert-@dfn ()
+ "Insert the string @dfn in a texinfo buffer."
+ (interactive)
+ (insert "@dfn{}")
+ (backward-char))
+
+(defun texinfo-insert-@code ()
+ "Insert the string @code in a texinfo buffer."
+ (interactive)
+ (insert "@code{}")
+ (backward-char))
+
+(defun texinfo-insert-braces ()
+ "Make a pair of braces and be poised to type inside of them.
+Use \\[up-list] to move forward out of the braces."
+ (interactive)
+ (insert "{}")
+ (backward-char))
+
+(defun texinfo-mode ()
+ "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 by \\[texinfo-format-buffer].
+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 \\[texinfo-format-region]. This command runs Info on the current region
+of the Texinfo file and formats it properly.
+
+ 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 @node, @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.
+
+Entering Texinfo mode calls the value of text-mode-hook, and then the
+value of texinfo-mode-hook."
+ (interactive)
+ (kill-all-local-variables)
+ (setq mode-name "Texinfo")
+ (setq major-mode 'texinfo-mode)
+ (use-local-map texinfo-mode-map)
+ (set-syntax-table texinfo-mode-syntax-table)
+ (setq local-abbrev-table text-mode-abbrev-table)
+ (make-local-variable 'require-final-newline)
+ (setq require-final-newline t)
+ (make-local-variable 'paragraph-separate)
+ (setq paragraph-separate (concat "^\b\\|^@[a-zA-Z]*[ \n]\\|" paragraph-separate))
+ (make-local-variable 'paragraph-start)
+ (setq paragraph-start (concat "^\b\\|^@[a-zA-Z]*[ \n]\\|" paragraph-start))
+ (make-local-variable 'fill-column)
+ (setq fill-column 72)
+ (make-local-variable 'comment-start)
+ (setq comment-start "@c ")
+ (make-local-variable 'comment-start-skip)
+ (setq comment-start-skip "@c +")
+ (run-hooks 'text-mode-hook 'texinfo-mode-hook))
+
+(defvar texinfo-heading-pattern
+ "^@\\(chapter\\|unnum\\|appendix\\|sect\\|sub\\|heading\\|major\\|node\\)"
+ "This is a regular expression to match Texinfo lines that are chapter
+or sections headings or like such.")
+
+(defun texinfo-show-structure ()
+ "Show the structure of a Texinfo file by listing the lines with the
+@-sign commands for @node, @chapter, @section and the like. Lines
+with structuring commands in them 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."
+ (interactive)
+ (save-excursion
+ (goto-char (point-min))
+ (occur texinfo-heading-pattern))
+ (pop-to-buffer "*Occur*")
+ (goto-char (point-min))
+ (flush-lines "-----"))
diff --git a/lisp/texinfo.elc b/lisp/texinfo.elc
new file mode 100644
index 00000000000..ea4c7061518
--- /dev/null
+++ b/lisp/texinfo.elc
@@ -0,0 +1,84 @@
+
+(defvar texinfo-mode-syntax-table nil)
+
+(if texinfo-mode-syntax-table nil (setq texinfo-mode-syntax-table (make-syntax-table)) (modify-syntax-entry 34 " " texinfo-mode-syntax-table) (modify-syntax-entry 92 " " texinfo-mode-syntax-table) (modify-syntax-entry 64 "\\" texinfo-mode-syntax-table) (modify-syntax-entry 17 "\\" texinfo-mode-syntax-table) (modify-syntax-entry 91 "(]" texinfo-mode-syntax-table) (modify-syntax-entry 93 ")[" texinfo-mode-syntax-table) (modify-syntax-entry 123 "(}" texinfo-mode-syntax-table) (modify-syntax-entry 125 "){" texinfo-mode-syntax-table) (modify-syntax-entry 39 "w" texinfo-mode-syntax-table))
+
+(defvar texinfo-mode-map nil)
+
+(if texinfo-mode-map nil (setq texinfo-mode-map (make-sparse-keymap)) (define-key texinfo-mode-map "" (quote texinfo-format-region)) (define-key texinfo-mode-map "" (quote texinfo-show-structure)) (define-key texinfo-mode-map "}" (quote up-list)) (define-key texinfo-mode-map "{" (quote texinfo-insert-braces)) (define-key texinfo-mode-map "v" (quote texinfo-insert-@var)) (define-key texinfo-mode-map "s" (quote texinfo-insert-@samp)) (define-key texinfo-mode-map "n" (quote texinfo-insert-@node)) (define-key texinfo-mode-map "i" (quote texinfo-insert-@item)) (define-key texinfo-mode-map "e" (quote texinfo-insert-@end)) (define-key texinfo-mode-map "d" (quote texinfo-insert-@dfn)) (define-key texinfo-mode-map "c" (quote texinfo-insert-@code)))
+
+(defun texinfo-insert-@var nil "\
+Insert the string @var in a texinfo buffer." (interactive) (byte-code "ÀˆÁcˆÂ ‡" [nil "@var{}" backward-char] 2))
+
+(defun texinfo-insert-@samp nil "\
+Insert the string @samp in a texinfo buffer." (interactive) (byte-code "ÀˆÁcˆÂ ‡" [nil "@samp{}" backward-char] 2))
+
+(defun texinfo-insert-@node nil "\
+Insert the string @node in a texinfo buffer,
+along with a comment indicating the arguments to @node." (interactive) (byte-code "ÀˆÁcˆÂÃ!ˆÄÅ!‡" [nil "@node
+@comment node-name, next, previous, up" forward-line -1 forward-char 6] 3))
+
+(defun texinfo-insert-@item nil "\
+Insert the string @item in a texinfo buffer." (interactive) (byte-code "ÀˆÁcˆÂ ‡" [nil "@item" newline] 2))
+
+(defun texinfo-insert-@end nil "\
+Insert the string @end in a texinfo buffer." (interactive) (byte-code "ÀˆÁc‡" [nil "@end "] 1))
+
+(defun texinfo-insert-@dfn nil "\
+Insert the string @dfn in a texinfo buffer." (interactive) (byte-code "ÀˆÁcˆÂ ‡" [nil "@dfn{}" backward-char] 2))
+
+(defun texinfo-insert-@code nil "\
+Insert the string @code in a texinfo buffer." (interactive) (byte-code "ÀˆÁcˆÂ ‡" [nil "@code{}" backward-char] 2))
+
+(defun texinfo-insert-braces nil "\
+Make a pair of braces and be poised to type inside of them.
+Use \\[up-list] to move forward out of the braces." (interactive) (byte-code "ÀˆÁcˆÂ ‡" [nil "{}" backward-char] 2))
+
+(defun texinfo-mode nil "\
+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 by \\[texinfo-format-buffer].
+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 \\[texinfo-format-region]. This command runs Info on the current region
+of the Texinfo file and formats it properly.
+
+ 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 @node, @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.
+
+Entering Texinfo mode calls the value of text-mode-hook, and then the
+value of texinfo-mode-hook." (interactive) (byte-code "͈ΠˆÏ‰ˆÐ‰ˆÑ
+!ˆÒ !ˆ ‰ˆÓÆ!ˆÇ‰ˆÓÈ!ˆÔP‰ˆÓÉ!ˆÔ P‰ ˆÓÊ!ˆÕ‰
+ˆÓË!ˆÖ‰ ˆÓÌ!ˆ×‰ ˆØÙÚ\"‡" [mode-name major-mode texinfo-mode-map texinfo-mode-syntax-table local-abbrev-table text-mode-abbrev-table require-final-newline t paragraph-separate paragraph-start fill-column comment-start comment-start-skip nil kill-all-local-variables "Texinfo" texinfo-mode use-local-map set-syntax-table make-local-variable "^\\|^@[a-zA-Z]*[
+]\\|" 72 "@c " "@c +" run-hooks text-mode-hook texinfo-mode-hook] 12))
+
+(defvar texinfo-heading-pattern "^@\\(chapter\\|unnum\\|appendix\\|sect\\|sub\\|heading\\|major\\|node\\)" "\
+This is a regular expression to match Texinfo lines that are chapter
+or sections headings or like such.")
+
+(defun texinfo-show-structure nil "\
+Show the structure of a Texinfo file by listing the lines with the
+@-sign commands for @node, @chapter, @section and the like. Lines
+with structuring commands in them 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." (interactive) (byte-code "ÁˆŠebˆÂ!)ˆÃÄ!ˆebˆÅÆ!‡" [texinfo-heading-pattern nil occur pop-to-buffer "*Occur*" flush-lines "-----"] 4))
diff --git a/lisp/textmodes/text-mode.el b/lisp/text-mode.el
index ba54cb845f6..6b1e372f12f 100644
--- a/lisp/textmodes/text-mode.el
+++ b/lisp/text-mode.el
@@ -32,11 +32,7 @@
(modify-syntax-entry ?\\ ". " text-mode-syntax-table)
(modify-syntax-entry ?' "w " text-mode-syntax-table))
-(defvar text-mode-map nil
- "Keymap for Text mode.
-Many other modes, such as Mail mode, Outline mode and Indented Text mode,
-inherit all the commands defined in this map.")
-
+(defvar text-mode-map nil "")
(if text-mode-map
()
(setq text-mode-map (make-sparse-keymap))
@@ -53,7 +49,7 @@ inherit all the commands defined in this map.")
(defun text-mode ()
"Major mode for editing text intended for humans to read. Special commands:\\{text-mode-map}
-Turning on text-mode calls the value of the variable `text-mode-hook',
+Turning on text-mode calls the value of the variable text-mode-hook,
if that value is non-nil."
(interactive)
(kill-all-local-variables)
@@ -64,18 +60,17 @@ if that value is non-nil."
(set-syntax-table text-mode-syntax-table)
(run-hooks 'text-mode-hook))
-(defvar indented-text-mode-map ()
- "Keymap for Indented Text mode.
-All the commands defined in Text mode are inherited unless overridden.")
-
+(defvar indented-text-mode-map ())
(if indented-text-mode-map
()
- (setq indented-text-mode-map (nconc (make-sparse-keymap) text-mode-map))
- (define-key indented-text-mode-map "\t" 'indent-relative))
+ (setq indented-text-mode-map (make-sparse-keymap))
+ (define-key indented-text-mode-map "\t" 'indent-relative)
+ (define-key indented-text-mode-map "\es" 'center-line)
+ (define-key indented-text-mode-map "\eS" 'center-paragraph))
(defun indented-text-mode ()
"Major mode for editing indented text intended for humans to read.\\{indented-text-mode-map}
-Turning on indented-text-mode calls the value of the variable `text-mode-hook',
+Turning on indented-text-mode calls the value of the variable text-mode-hook,
if that value is non-nil."
(interactive)
(kill-all-local-variables)
@@ -90,20 +85,8 @@ if that value is non-nil."
(setq major-mode 'indented-text-mode)
(run-hooks 'text-mode-hook))
-(defun change-log-mode ()
- "Major mode for editing ChangeLog files. See M-x add-change-log-entry.
-Almost the same as Indented Text mode, but prevents numeric backups
-and sets `left-margin' to 8 and `fill-column' to 74."
- (interactive)
- (indented-text-mode)
- (setq left-margin 8)
- (setq fill-column 74)
- (make-local-variable 'version-control)
- (setq version-control 'never)
- (run-hooks 'change-log-mode-hook))
-
(defun center-paragraph ()
- "Center each nonblank line in the paragraph at or after point.
+ "Center each line in the paragraph at or after point.
See center-line for more info."
(interactive)
(save-excursion
@@ -114,7 +97,7 @@ See center-line for more info."
(center-region (point) end))))
(defun center-region (from to)
- "Center each nonblank line starting in the region.
+ "Center each line starting in the region.
See center-line for more info."
(interactive "r")
(if (> from to)
@@ -125,13 +108,12 @@ See center-line for more info."
(narrow-to-region from to)
(goto-char from)
(while (not (eobp))
- (or (save-excursion (skip-chars-forward " \t") (eolp))
- (center-line))
+ (center-line)
(forward-line 1)))))
(defun center-line ()
"Center the line point is on, within the width specified by `fill-column'.
-This means adjusting the indentation so that it equals
+This means adjusting the indentation to match
the distance between the end of the text and `fill-column'."
(interactive)
(save-excursion
diff --git a/lisp/text-mode.elc b/lisp/text-mode.elc
new file mode 100644
index 00000000000..712cc34b2bc
--- /dev/null
+++ b/lisp/text-mode.elc
Binary files differ
diff --git a/lisp/textmodes/bib-mode.el b/lisp/textmodes/bib-mode.el
deleted file mode 100644
index af6f2ded3f0..00000000000
--- a/lisp/textmodes/bib-mode.el
+++ /dev/null
@@ -1,233 +0,0 @@
-;; bib-mode, major mode for editing bib files.
-;; Copyright (C) 1989 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-
-;; Bib-Mode
-;; 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.
-
-(provide 'bib-mode)
-
-(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 capitialized 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)))
diff --git a/lisp/textmodes/fill.el b/lisp/textmodes/fill.el
deleted file mode 100644
index d7526a192b5..00000000000
--- a/lisp/textmodes/fill.el
+++ /dev/null
@@ -1,246 +0,0 @@
-;; Fill commands for Emacs
-;; Copyright (C) 1985, 1986 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-
-(defun set-fill-prefix ()
- "Set the fill-prefix to the current line up to point.
-Filling expects lines to start with the fill prefix and
-reinserts the fill prefix in each resulting line."
- (interactive)
- (setq fill-prefix (buffer-substring
- (save-excursion (beginning-of-line) (point))
- (point)))
- (if (equal fill-prefix "")
- (setq fill-prefix nil))
- (if fill-prefix
- (message "fill-prefix: \"%s\"" fill-prefix)
- (message "fill-prefix cancelled")))
-
-(defconst adaptive-fill-mode t
- "*Non-nil means determine a paragraph's fill prefix from its text.")
-
-(defconst adaptive-fill-regexp "[ \t]*\\([>*] +\\)?"
- "*Regexp to match text at start of line that constitutes indentation.
-If Adaptive Fill mode is enabled, whatever text matches this pattern
-on the second line of a paragraph is used as the standard indentation
-for the paragraph.")
-
-(defun fill-region-as-paragraph (from to &optional justify-flag)
- "Fill region as one paragraph: break lines to fit fill-column.
-Prefix arg means justify too.
-From program, pass args FROM, TO and JUSTIFY-FLAG."
- (interactive "r\nP")
- ;; Don't let Adaptive Fill mode alter the fill prefix permanently.
- (let ((fill-prefix fill-prefix))
- ;; Figure out how this paragraph is indented, if desired.
- (if adaptive-fill-mode
- (save-excursion
- (goto-char (min from to))
- (if (eolp) (forward-line 1))
- (forward-line 1)
- (if (< (point) (max from to))
- (let ((start (point)))
- (re-search-forward adaptive-fill-regexp)
- (setq fill-prefix (buffer-substring start (point))))
- (goto-char (min from to))
- (if (eolp) (forward-line 1))
- ;; If paragraph has only one line, don't assume
- ;; that additional lines would have the same starting
- ;; decoration. Instead, assume they would have white space
- ;; reaching to the same column.
- (re-search-forward adaptive-fill-regexp)
- (setq fill-prefix (make-string (current-column) ?\ )))))
-
- (save-restriction
- (narrow-to-region from to)
- (goto-char (point-min))
- (skip-chars-forward "\n")
- (narrow-to-region (point) (point-max))
- (setq from (point))
- (goto-char (point-max))
- (let ((fpre (and fill-prefix (not (equal fill-prefix ""))
- (regexp-quote fill-prefix))))
- ;; Delete the fill prefix from every line except the first.
- ;; The first line may not even have a fill prefix.
- (and fpre
- (progn
- (if (>= (length fill-prefix) fill-column)
- (error "fill-prefix too long for specified width"))
- (goto-char (point-min))
- (forward-line 1)
- (while (not (eobp))
- (if (looking-at fpre)
- (delete-region (point) (match-end 0)))
- (forward-line 1))
- (goto-char (point-min))
- (and (looking-at fpre) (forward-char (length fill-prefix)))
- (setq from (point)))))
- ;; from is now before the text to fill,
- ;; but after any fill prefix on the first line.
-
- ;; Make sure sentences ending at end of line get an extra space.
- ;; loses on split abbrevs ("Mr.\nSmith")
- (goto-char from)
- (while (re-search-forward "[.?!][])\"']*$" nil t)
- (insert ? ))
-
- ;; Then change all newlines to spaces.
- (subst-char-in-region from (point-max) ?\n ?\ )
-
- ;; Flush excess spaces, except in the paragraph indentation.
- (goto-char from)
- (skip-chars-forward " \t")
- ;; nuke tabs while we're at it; they get screwed up in a fill
- ;; this is quick, but loses when a sole tab follows the end of a sentence.
- ;; actually, it is difficult to tell that from "Mr.\tSmith".
- ;; blame the typist.
- (subst-char-in-region (point) (point-max) ?\t ?\ )
- (while (re-search-forward " *" nil t)
- (delete-region
- (+ (match-beginning 0)
- (if (save-excursion
- (skip-chars-backward " ])\"'")
- (memq (preceding-char) '(?. ?? ?!)))
- 2 1))
- (match-end 0)))
- (goto-char (point-max))
- (delete-horizontal-space)
- (insert " ")
- (goto-char (point-min))
-
- (let ((prefixcol 0))
- (while (not (eobp))
- (move-to-column (1+ fill-column))
- (if (eobp)
- nil
- (skip-chars-backward "^ \n")
- (if (if (zerop prefixcol) (bolp) (>= prefixcol (current-column)))
- (skip-chars-forward "^ \n")
- (forward-char -1)))
- ;; Inserting the newline first prevents losing track of point.
- (skip-chars-backward " ")
- (insert ?\n)
- (delete-horizontal-space)
- (and (not (eobp)) fill-prefix (not (equal fill-prefix ""))
- (progn
- (insert fill-prefix)
- (setq prefixcol (current-column))))
- (and justify-flag (not (eobp))
- (progn
- (forward-line -1)
- (justify-current-line)
- (forward-line 1))))))))
-
-(defun fill-paragraph (arg)
- "Fill paragraph at or after point. Prefix arg means justify as well."
- (interactive "P")
- (save-excursion
- (forward-paragraph)
- (or (bolp) (newline 1))
- (let ((end (point)))
- (backward-paragraph)
- (fill-region-as-paragraph (point) end arg))))
-
-(defun fill-region (from to &optional justify-flag)
- "Fill each of the paragraphs in the region.
-Prefix arg (non-nil third arg, if called from program) means justify as well."
- (interactive "r\nP")
- (save-restriction
- (narrow-to-region from to)
- (goto-char (point-min))
- (while (not (eobp))
- (let ((initial (point))
- (end (progn
- (forward-paragraph 1) (point))))
- (forward-paragraph -1)
- (if (>= (point) initial)
- (fill-region-as-paragraph (point) end justify-flag)
- (goto-char end))))))
-
-(defun justify-current-line ()
- "Add spaces to line point is in, so it ends at `fill-column'."
- (interactive)
- (save-excursion
- (save-restriction
- (let (ncols beg indent)
- (beginning-of-line)
- (forward-char (length fill-prefix))
- (skip-chars-forward " \t")
- (setq indent (current-column))
- (setq beg (point))
- (end-of-line)
- (narrow-to-region beg (point))
- (goto-char beg)
- (while (re-search-forward " *" nil t)
- (delete-region
- (+ (match-beginning 0)
- (if (save-excursion
- (skip-chars-backward " ])\"'")
- (memq (preceding-char) '(?. ?? ?!)))
- 2 1))
- (match-end 0)))
- (goto-char beg)
- (while (re-search-forward "[.?!][])""']*\n" nil t)
- (forward-char -1)
- (insert ? ))
- (goto-char (point-max))
- ;; Note that the buffer bounds start after the indentation,
- ;; so the columns counted by INDENT don't appear in (current-column).
- (setq ncols (- fill-column (current-column) indent))
- (if (search-backward " " nil t)
- (while (> ncols 0)
- (let ((nmove (+ 3 (random 3))))
- (while (> nmove 0)
- (or (search-backward " " nil t)
- (progn
- (goto-char (point-max))
- (search-backward " ")))
- (skip-chars-backward " ")
- (setq nmove (1- nmove))))
- (insert " ")
- (skip-chars-backward " ")
- (setq ncols (1- ncols))))))))
-
-(defun fill-individual-paragraphs (min max &optional justifyp mailp)
- "Fill each paragraph in region according to its individual fill prefix.
-Calling from a program, pass range to fill as first two arguments.
-Optional third and fourth arguments JUSTIFY-FLAG and MAIL-FLAG:
-JUSTIFY-FLAG to justify paragraphs (prefix arg),
-MAIL-FLAG for a mail message, i. e. don't fill header lines."
- (interactive "r\nP")
- (let (fill-prefix)
- (save-restriction
- (save-excursion
- (goto-char min)
- (if mailp
- (while (looking-at "[^ \t\n]*:")
- (forward-line 1)))
- (narrow-to-region (point) max)
- (while (progn
- (skip-chars-forward " \t\n")
- (not (eobp)))
- (setq fill-prefix
- (buffer-substring (point) (progn (beginning-of-line) (point))))
- (let ((fin (save-excursion (forward-paragraph) (point)))
- (start (point)))
- (fill-region-as-paragraph (point) fin justifyp)
- (goto-char start)
- (forward-paragraph)))))))
-
-
diff --git a/lisp/textmodes/ispell4.el b/lisp/textmodes/ispell4.el
deleted file mode 100644
index 782ea43103c..00000000000
--- a/lisp/textmodes/ispell4.el
+++ /dev/null
@@ -1,541 +0,0 @@
-;;This is the GNU EMACS interface to GNU ISPELL version 3.
-;; Copyright (C) 1990 Free Software Foundation, Inc.
-;;
-;;This file is part of GNU ISPELL.
-;;
-;;GNU ISPELL 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 1, or (at your option)
-;;any later version.
-;;
-;;GNU ISPELL 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 ISPELL; see the file COPYING. If not, write to
-;;the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-(defvar ispell-have-new-look t
- "T if default 'look' program has the -r flag.")
-
-(defvar ispell-enable-tex-parser nil
- "T to enable experimental tex parser in ispell for tex buffers.")
-
-(defvar ispell-process nil "The process running ISPELL")
-(defvar ispell-next-message nil
- "An integer telling where in the *ispell* buffer where
-to look for the next message from the ISPELL program.")
-
-;Each marker in this list points to the start of a word that
-;ispell thought was bad last time it did the :file command.
-;Notice that if the user accepts or inserts a word into his
-;private dictionary, then some "good" words will be on the list.
-;We would like to deal with this by looking up the words again just before
-;presenting them to the user, but that is too slow on machines
-;without the select system call. Therefore, see the variable
-;ispell-recently-accepted.
-(defvar ispell-bad-words nil
- "A list of markers corresponding to the output of the ISPELL :file command.")
-
-;list of words that the user has accepted, but that might still
-;be on the bad-words list
-(defvar ispell-recently-accepted nil)
-
-;t when :dump command needed
-(defvar ispell-dump-needed nil)
-
-(defun ispell-flush-bad-words ()
- (while ispell-bad-words
- (if (markerp (car ispell-bad-words))
- (set-marker (car ispell-bad-words) nil))
- (setq ispell-bad-words (cdr ispell-bad-words)))
- (setq ispell-recently-accepted nil))
-
-(defun kill-ispell ()
- "Kill the ispell process.
-Any changes the your private dictionay
-that have not already been dumped will be lost."
- (interactive)
- (if ispell-process
- (delete-process ispell-process))
- (setq ispell-process nil)
- (ispell-flush-bad-words))
-
-(put 'ispell-startup-error 'error-conditions
- '(ispell-startup-error error))
-(put 'ispell-startup-error 'error-message
- "Problem starting ispell - see buffer *ispell*")
-
-(defun start-ispell ()
- "Start an ispell subprocess; check the version; and display the greeting."
- (message "Starting ispell ...")
- (let ((buf (get-buffer "*ispell*")))
- (if buf
- (kill-buffer buf)))
- (condition-case err
- (setq ispell-process (start-process "ispell" "*ispell*" "ispell" "-S"))
- (file-error (signal 'ispell-startup-error nil)))
- (process-kill-without-query ispell-process)
- (buffer-disable-undo (process-buffer ispell-process))
- (accept-process-output ispell-process)
- (let (last-char)
- (save-excursion
- (set-buffer (process-buffer ispell-process))
- (bury-buffer (current-buffer))
- (setq last-char (- (point-max) 1))
- (while (not (eq (char-after last-char) ?=))
- (cond ((not (eq (process-status ispell-process) 'run))
- (kill-ispell)
- (signal 'ispell-startup-error nil)))
- (accept-process-output ispell-process)
- (setq last-char (- (point-max) 1)))
- (goto-char (point-min))
- (let ((greeting (read (current-buffer))))
- (if (not (= (car greeting) 1))
- (error "Bad ispell version: wanted 1, got %d" (car greeting)))
- (message (car (cdr greeting))))
- (delete-region (point-min) last-char))))
-
-;leaves buffer set to *ispell*, point at '='
-(defun ispell-sync (intr)
- "Make sure ispell is ready for a command."
- (if (or (null ispell-process)
- (not (eq (process-status ispell-process) 'run)))
- (start-ispell))
- (if intr
- (interrupt-process ispell-process))
- (let (last-char)
- (set-buffer (process-buffer ispell-process))
- (bury-buffer (current-buffer))
- (setq last-char (- (point-max) 1))
- (while (not (eq (char-after last-char) ?=))
- (accept-process-output ispell-process)
- (setq last-char (- (point-max) 1)))
- (goto-char last-char)))
-
-(defun ispell-cmd (&rest strings)
- "Send a command to ispell. Choices are:
-
-word any word is checked for spelling. Result is
-
- nil not found
- t spelled ok
- list of strings near misses
-
-:file filename scan the named file, and print the file offsets of
- any misspelled words
-
-:insert word put word in private dictonary
-
-:accept word don't complain about word any more this session
-
-:dump write out the current private dictionary, if necessary.
-
-:reload reread ~/ispell.words
-
-:tex
-:troff
-:generic set type of parser to use when scanning whole files
-"
- (save-excursion
- (ispell-sync t)
- (set-buffer (process-buffer ispell-process))
- (bury-buffer (current-buffer))
- (erase-buffer)
- (setq ispell-next-message (point-min))
- (while strings
- (process-send-string ispell-process (car strings))
- (setq strings (cdr strings)))
- (process-send-string ispell-process "\n")
- (accept-process-output ispell-process)
- (ispell-sync nil)))
-
-(defun ispell-dump ()
- (cond (ispell-dump-needed
- (setq ispell-dump-needed nil)
- (ispell-cmd ":dump"))))
-
-(defun ispell-insert (word)
- (ispell-cmd ":insert " word)
- (if ispell-bad-words
- (setq ispell-recently-accepted (cons word ispell-recently-accepted)))
- (setq ispell-dump-needed t))
-
-(defun ispell-accept (word)
- (ispell-cmd ":accept " word)
- (if ispell-bad-words
- (setq ispell-recently-accepted (cons word ispell-recently-accepted))))
-
-
-(defun ispell-next-message ()
- "Return the next message sent by the ispell subprocess."
- (save-excursion
- (set-buffer (process-buffer ispell-process))
- (bury-buffer (current-buffer))
- (save-restriction
- (goto-char ispell-next-message)
- (narrow-to-region (point)
- (progn (forward-sexp 1) (point)))
- (setq ispell-next-message (point))
- (goto-char (point-min))
- (read (current-buffer)))))
-
-(defun ispell-tex-buffer-p ()
- (memq major-mode '(plain-TeX-mode LaTeX-mode)))
-
-(defun ispell (&optional buf start end)
- "Run ispell over current buffer's visited file.
-First the file is scanned for misspelled words, then ispell
-enters a loop with the following commands for every misspelled word:
-
-DIGIT Near miss selector. If the misspelled word is close to
- some words in the dictionary, they are offered as near misses.
-r Replace. Replace the word with a string you type. Each word
- of your new string is also checked.
-i Insert. Insert this word in your private dictonary (kept in
- `$HOME/ispell.words').
-a Accept. Accept this word for the rest of this editing session,
- but don't put it in your private dictonary.
-l Lookup. Look for a word in the dictionary by fast binary
- search, or search for a regular expression in the dictionary
- using grep.
-SPACE Accept the word this time, but complain if it is seen again.
-q, \\[keyboard-quit] Leave the command loop. You can come back later with \\[ispell-next]."
- (interactive)
- (if (null start)
- (setq start 0))
- (if (null end)
- (setq end 0))
-
- (if (null buf)
- (setq buf (current-buffer)))
- (setq buf (get-buffer buf))
- (if (null buf)
- (error "Can't find buffer"))
- (save-excursion
- (set-buffer buf)
- (let ((filename buffer-file-name)
- (delete-temp nil))
- (unwind-protect
- (progn
- (cond ((null filename)
- (setq filename (make-temp-name "/usr/tmp/ispell"))
- (setq delete-temp t)
- (write-region (point-min) (point-max) filename))
- ((and (buffer-modified-p buf)
- (y-or-n-p (format "Save file %s? " filename)))
- (save-buffer)))
- (message "Ispell scanning file...")
- (if (and ispell-enable-tex-parser
- (ispell-tex-buffer-p))
- (ispell-cmd ":tex")
- (ispell-cmd ":generic"))
- (ispell-cmd (format ":file %s %d %d" filename start end)))
- (if delete-temp
- (condition-case ()
- (delete-file filename)
- (file-error nil)))))
- (message "Parsing ispell output ...")
- (ispell-flush-bad-words)
- (let (pos bad-words)
- (while (numberp (setq pos (ispell-next-message)))
- ;;ispell may check the words on the line following the end
- ;;of the region - therefore, don't record anything out of range
- (if (or (= end 0)
- (< pos end))
- (setq bad-words (cons (set-marker (make-marker) (+ pos 1))
- bad-words))))
- (setq bad-words (cons pos bad-words))
- (setq ispell-bad-words (nreverse bad-words))))
- (cond ((not (markerp (car ispell-bad-words)))
- (setq ispell-bad-words nil)
- (message "No misspellings."))
- (t
- (message "Ispell parsing done.")
- (ispell-next))))
-
-(defun ispell-next ()
- "Resume command loop for most recent ispell command."
- (interactive)
- (unwind-protect
- (catch 'quit
- (save-window-excursion
- (save-excursion
- (let (next)
- (while (markerp (setq next (car ispell-bad-words)))
- (switch-to-buffer (marker-buffer next))
- (push-mark)
- (ispell-point next "at saved position.")
- (setq ispell-bad-words (cdr ispell-bad-words))
- (set-marker next nil))))))
- (cond ((null ispell-bad-words)
- (error "Ispell has not yet been run."))
- ((markerp (car ispell-bad-words))
- (message (substitute-command-keys
- "Type \\[ispell-next] to continue.")))
- ((eq (car ispell-bad-words) nil)
- (setq ispell-bad-words nil)
- (message "No more misspellings (but checker was interrupted.)"))
- ((eq (car ispell-bad-words) t)
- (setq ispell-bad-words nil)
- (message "Ispell done."))
- (t
- (setq ispell-bad-words nil)
- (message "Bad ispell internal list"))))
- (ispell-dump))
-
-
-(defun ispell-word ()
- "Check the spelling of the word under the cursor.
-See `ispell' for more information."
- (interactive)
- (condition-case err
- (catch 'quit
- (save-window-excursion
- (ispell-point (point) "at point."))
- (ispell-dump))
- (ispell-startup-error
- (cond ((y-or-n-p "Problem starting ispell, use old-style spell instead? ")
- (load-library "spell")
- (define-key esc-map "$" 'spell-word)
- (spell-word))))))
-
-(defun ispell-region (start &optional end)
- "Check the spelling for all of the words in the region."
- (interactive "r")
- (ispell (current-buffer) start end))
-
-(defun ispell-letterp (c)
- (and c
- (or (and (>= c ?A) (<= c ?Z))
- (and (>= c ?a) (<= c ?z))
- (>= c 128))))
-
-(defun ispell-letter-or-quotep (c)
- (and c
- (or (and (>= c ?A) (<= c ?Z))
- (and (>= c ?a) (<= c ?z))
- (= c ?')
- (>= c 128))))
-
-(defun ispell-find-word-start ()
- ;;backward to a letter
- (if (not (ispell-letterp (char-after (point))))
- (while (and (not (bobp))
- (not (ispell-letterp (char-after (- (point) 1)))))
- (backward-char)))
- ;;backward to beginning of word
- (while (ispell-letter-or-quotep (char-after (- (point) 1)))
- (backward-char))
- (skip-chars-forward "'"))
-
-(defun ispell-find-word-end ()
- (while (ispell-letter-or-quotep (char-after (point)))
- (forward-char))
- (skip-chars-backward "'"))
-
-(defun ispell-next-word ()
- (while (and (not (eobp))
- (not (ispell-letterp (char-after (point)))))
- (forward-char)))
-
-;if end is nil, then do one word at start
-;otherwise, do all words from the beginning of the word where
-;start points, to the end of the word where end points
-(defun ispell-point (start message)
- (let ((wend (make-marker))
- rescan
- end)
- (save-excursion
- (goto-char start)
- (ispell-find-word-start) ;find correct word start
- (setq start (point-marker))
- (ispell-find-word-end) ;now find correct end
- (setq end (point-marker))
- (if (>= start end)
- (error "No word %s" message))
- (while (< start end)
- (goto-char start)
- (ispell-find-word-end) ;find end of current word
- ;could be before 'end' if
- ;user typed replacement
- ;that is more than one word
- (set-marker wend (point))
- (setq rescan nil)
- (setq word (buffer-substring start wend))
- (cond ((ispell-still-bad word)
- (goto-char start);just to show user where we are working
- (sit-for 0)
- (message (format "Ispell checking %s" word))
- (ispell-cmd word)
- (let ((message (ispell-next-message)))
- (cond ((eq message t)
- (message "%s: ok" word))
- ((or (null message)
- (consp message))
- (setq rescan
- (ispell-command-loop word start wend message)))
- (t
- (error "unknown ispell response %s" message))))))
- (cond ((null rescan)
- (goto-char wend)
- (ispell-next-word)
- (set-marker start (point)))))
- ;;clear the choices buffer; otherwise it's hard for the user to tell
- ;;when we get back to the command loop
- (let ((buf (get-buffer "*ispell choices*")))
- (cond (buf
- (set-buffer buf)
- (erase-buffer))))
- (set-marker start nil)
- (set-marker end nil)
- (set-marker wend nil))))
-
-(defun ispell-still-bad (word)
- (let ((words ispell-recently-accepted)
- (ret t)
- (case-fold-search t))
- (while words
- (cond ((eq (string-match (car words) word) 0)
- (setq ret nil)
- (setq words nil)))
- (setq words (cdr words)))
- ret))
-
-(defun ispell-show-choices (word message first-line)
- ;;if there is only one window on the screen, make the ispell
- ;;messages winow be small. otherwise just use the other window
- (let* ((selwin (selected-window))
- (resize (eq selwin (next-window)))
- (buf (get-buffer-create "*ispell choices*"))
- w)
- (setq w (display-buffer buf))
- (buffer-disable-undo buf)
- (if resize
- (unwind-protect
- (progn
- (select-window w)
- (enlarge-window (- 6 (window-height w))))
- (select-window selwin)))
- (save-excursion
- (set-buffer buf)
- (bury-buffer buf)
- (set-window-point w (point-min))
- (set-window-start w (point-min))
- (erase-buffer)
- (insert first-line "\n")
- (insert
- "SPC skip; A accept; I insert; DIGIT select; R replace; \
-L lookup; Q quit\n")
- (cond ((not (null message))
- (let ((i 0))
- (while (< i 3)
- (let ((j 0))
- (while (< j 3)
- (let* ((n (+ (* j 3) i))
- (choice (nth n message)))
- (cond (choice
- (let ((str (format "%d %s" n choice)))
- (insert str)
- (insert-char ? (- 20 (length str)))))))
- (setq j (+ j 1))))
- (insert "\n")
- (setq i (+ i 1)))))))))
-
-(defun ispell-command-loop (word start end message)
- (let ((flag t)
- (rescan nil)
- first-line)
- (if (null message)
- (setq first-line (concat "No near misses for '" word "'"))
- (setq first-line (concat "Near misses for '" word "'")))
- (while flag
- (ispell-show-choices word message first-line)
- (message "Ispell command: ")
- (let ((c (downcase (read-char)))
- replacement)
- (cond ((and (>= c ?0)
- (<= c ?9)
- (setq replacement (nth (- c ?0) message)))
- (ispell-replace start end replacement)
- (setq flag nil))
- ((= c ?q)
- (throw 'quit nil))
- ((= c ? )
- (setq flag nil))
- ((= c ?r)
- (ispell-replace start end (read-string "Replacement: "))
- (setq rescan t)
- (setq flag nil))
- ((= c ?i)
- (ispell-insert word)
- (setq flag nil))
- ((= c ?a)
- (ispell-accept word)
- (setq flag nil))
- ((= c ?l)
- (let ((val (ispell-do-look word)))
- (setq first-line (car val))
- (setq message (cdr val))))
- ((= c ??)
- (message
- "Type 'C-h d ispell' to the emacs main loop for more help")
- (sit-for 2))
- (t
- (message "Bad ispell command")
- (sit-for 2)))))
- rescan))
-
-(defun ispell-do-look (bad-word)
- (let (regex buf words)
- (cond ((null ispell-have-new-look)
- (setq regex (read-string "Lookup: ")))
- (t
- (setq regex (read-string "Lookup (regex): " "^"))))
- (setq buf (get-buffer-create "*ispell look*"))
- (save-excursion
- (set-buffer buf)
- (delete-region (point-min) (point-max))
- (if ispell-have-new-look
- (call-process "look" nil buf nil "-r" regex)
- (call-process "look" nil buf nil regex))
- (goto-char (point-min))
- (forward-line 10)
- (delete-region (point) (point-max))
- (goto-char (point-min))
- (while (not (= (point-min) (point-max)))
- (end-of-line)
- (setq words (cons (buffer-substring (point-min) (point)) words))
- (forward-line)
- (delete-region (point-min) (point)))
- (kill-buffer buf)
- (cons (format "Lookup '%s'" regex)
- (reverse words)))))
-
-(defun ispell-replace (start end new)
- (goto-char start)
- (insert new)
- (delete-region (point) end))
-
-(defun reload-ispell ()
- "Tell ispell to re-read your private dictionary."
- (interactive)
- (ispell-cmd ":reload"))
-
-(define-key esc-map "$" 'ispell-word)
-;; This conflicts with set-selective-display. What should we do???
-;;(define-key ctl-x-map "$" 'ispell-next)
-
-(defun batch-make-ispell ()
- (byte-compile-file "ispell.el")
- (find-file "ispell.texinfo")
- (let ((old-dir default-directory)
- (default-directory "/tmp"))
- (texinfo-format-buffer))
- (Info-validate)
- (if (get-buffer " *problems in info file*")
- (kill-emacs 1))
- (write-region (point-min) (point-max) "ispell.info"))
-
diff --git a/lisp/textmodes/page-ext.el b/lisp/textmodes/page-ext.el
deleted file mode 100644
index c17fa187551..00000000000
--- a/lisp/textmodes/page-ext.el
+++ /dev/null
@@ -1,745 +0,0 @@
-;;;; page-ext.el
-
-;;; Page handling commands
-;;; by Robert J. Chassell
-
-;;; You may use these commands to handle an address list or other
-;;; small data base.
-
-;;; Copyright (C) 1990 Free Software Foundation
-;;; Please send bug reports to bob@ai.mit.edu
-
-;;; Change Log ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Version 0.043
-;;; 24 May 1990 - When the cursor is at the end of the pages directory
-;;; buffer (which is empty), a `C-c C-c' (pages-directory-goto)
-;;; command now takes you to the end of the buffer.
-;;;
-;;; Version 0.042
-;;; 16 May 1990 - Since people often handle address and other files
-;;; differently, variable `pages-directory-for-addresses-narrowing-p'
-;;; now specifies whether `pages-directory-goto' should narrow
-;;; addresses buffer to entry to which it goes.
-;;; `pages-directory-buffer-narrowing-p' continues to control
-;;; narrowing of pages buffer.
-;;;
-;;; `add-new-page' documentation string now explains
-;;; that the value of the inserted page-delimiter is a `^L'.
-;;;
-;;; `pages-directory-previous-regexp' definition reworded.
-;;;
-;;; Removed unneeded defvar for `pages-directory-buffer'.
-;;;
-;;; Version 0.041
-;;; 14 May 1990 - `pages-last-search' bound to nil initially.
-;;; Remove unnecessary lines from `search-pages' definition.
-;;;
-;;; Version 0.04
-;;; 18 Mar 1990 - `pages-directory' creates a directory for only the
-;;; accessible portion of the buffer; it does not automatically widen
-;;; the buffer.
-;;;
-;;; However, `pages-directory-for-addresses' does widen the addresses'
-;;; buffer before constructing the addresses' directory.
-;;;
-;;; Version 0.032
-;;; 20 Feb 1990 - `pages-directory-for-addresses' no longer copies
-;;; first line of addresses directory to kill-ring
-;;;
-;;; Remove `(kill-all-local-variables)' line from
-;;; `pages-directory-address-mode' so Emacs will not be told to forget
-;;; the name of the file containing the addresses!
-;;;
-;;; Version 0.031
-;;; 15 Feb 1990 - `pages-directory-goto' no longer erroneously selects
-;;; the entry on the following line when the cursor is at the end of
-;;; the line, but selects the entry on which the cursor rests.
-;;;
-;;; `pages-directory-address-mode' now sets local variables and enables
-;;; `describe-mode' to describe Addresses Directory mode.
-;;;
-;;; `pages-directory-for-addresses' now sets the buffer-modifed flag
-;;; for the Addresses Directory to nil.
-;;;
-;;; The documentation string for both `pages-directory-mode' and
-;;; `pages-directory-address-mode' now provide a lookup for the
-;;; `pages-directory-goto' keybinding.
-;;;
-;;; Version 0.03
-;;; 10 Feb 1990 - Incorporated a specialized extension of the
-;;; `pages-directory' command called `pages-directory-for-addresses'
-;;; and bound it to ctl-x-ctl-p-map "d" for integration with other
-;;; page functions. This function finds a file, creates a directory
-;;; for it using the `pages-directory' command, and displays the
-;;; directory. It is primarily for lists of addresses and the like.
-;;;
-;;; The difference between this and the `pages-directory' command is
-;;; that the `pages-directory-for-addresses' command presumes a
-;;; default addresses file (although you may optionally specify a file
-;;; name) and it switches you to the directory for the file, but the
-;;; `pages-directory' command creates a directory for the current
-;;; buffer, and pops to the directory in another window.
-;;;
-;;; `pages-directory' now places the cursor over the header line of
-;;; the page in which point was located in the pages buffer.
-;;;
-;;; New `set-page-delimiter' command sets the buffer local value of
-;;; the page-delimiter variable. With prefix arg, resets function to
-;;; original value. (Quicker to use than `edit-options'.)
-;;;
-;;; Version 0.02
-;;; 9 Feb 1990 - `pages-directory' now displays the
-;;; first line that contains a non-blank character that follows the
-;;; `page-delimiter'; this may be the rest of the line that contains
-;;; the `page-delimiter' or a line following. (In most instances, the
-;;; line containing a non-blank character is a line of text.)
-;;; Modification includes changes to `pages-copy-header-and-position'.
-;;;
-;;; Each directory created by `pages-directory' now possesses a name
-;;; derived on the name of the pages buffer. Consequently, you may
-;;; create several different directories, one for each pages buffer.
-;;;
-;;; `sort-pages-in-region' no longers requires the text to start on
-;;; the line immediately following the line containing the
-;;; page-delimiter.
-;;;
-;;; `pages-directory-goto' no longer narrows to the page
-;;; automatically. Instead, if you wish it to narrow to the page, set
-;;; variable pages-directory-buffer-narrowing-p to a non-nil value.
-;;; Default is nil; this is an experiment to see whether it is useful
-;;; to see the surrounding context.
-;;;
-;;; Version 0.011
-;;; 2 Feb 1990 - `add-new-page': removed extraneous space.
-;;;
-;;; Version 0.01
-;;; 28 Jan 1990 - Initial definitions.
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-
-;;;; Summary
-
-; The current page commands are:
-
-; forward-page C-x ]
-; backward-page C-x [
-; narrow-to-page C-x p
-; count-lines-page C-x l
-; mark-page C-x C-p (change this to C-x C-p C-m)
-; sort-pages not bound
-; what-page not bound
-
-; The new page handling commands all use `C-x C-p' as a prefix. This
-; means that the key binding for `mark-page' must be changed.
-; Otherwise, no other changes are made to the current commands or
-; their bindings.
-
-; New page handling commands:
-
-; next-page C-x C-p C-n
-; previous-page C-x C-p C-p
-; search-pages C-x C-p C-s
-; add-new-page C-x C-p C-a
-; sort-pages-buffer C-x C-p s
-; set-page-delimiter C-x C-p C-l
-; pages-directory C-x C-p C-d
-; pages-directory-for-addresses C-x C-p d
-; goto-page C-c C-c
-
-
-;;;; Using the page commands
-;
-; The page commands are helpful in several different contexts. For
-; example, programmers often divide source files into sections using the
-; `page-delimiter'; you can use the `pages-directory' command to list
-; the sections.
-
-; You may change the buffer local value of the `page-delimiter' with
-; the `set-page-delimiter' command. This command is bound to `C-x C-p
-; C-l' The command prompts you for a new value for the page-delimiter.
-; Called with a prefix-arg, the command resets the value of the
-; page-delimiter to its original value.
-
-
-;;;; Handling an address list or small data base
-
-; You may use the page commands to handle an address list or other
-; small data base. Put each address or entry on its own page. The
-; first line of text in each page is a `header line' and is listed by
-; the `pages-directory' or `pages-directory-for-addresses' command.
-
-; Specifically:
-;
-; 1. Begin each entry with a `page-delimiter' (which is, by default,
-; `^L' at the beginning of the line).
-;
-; 2. The first line of text in each entry is the `heading line'; it
-; will appear in the pages-directory-buffer which is constructed
-; using the `C-x C-p C-d' (pages-directory) command or the `C-x
-; C-p d' (pages-directory-for-addresses) command.
-;
-; The heading line may be on the same line as the page-delimiter
-; or it may follow after. It is the first non-blank line on the
-; page. Conventionally, the heading line is placed on the line
-; immediately following the line containing page-delimiter.
-;
-; 3. Follow the heading line with the body of the entry. The body
-; extends up to the next `page-delimiter'. The body may be of any
-; length. It is conventional to place a blank line after the last
-; line of the body.
-
-; For example, a file might look like this:
-;
-; FSF
-; Free Software Foundation
-; 675 Massachusetts Avenue
-; Cambridge, MA 02139 USA
-; (617) 876-3296
-; gnu@prep.ai.mit.edu
-;
-;
-; House Subcommittee on Intellectual Property,
-; U.S. House of Representatives,
-; Washington, DC 20515
-;
-; Congressional committee concerned with permitting or preventing
-; monopolistic restictions on the use of software technology
-;
-;
-; George Lakoff
-; ``Women, Fire, and Dangerous Things:
-; What Categories Reveal about the Mind''
-; 1987, Univ. of Chicago Press
-;
-; About philosophy, Whorfian effects, and linguistics.
-;
-;
-; OBI (On line text collection.)
-; Open Book Initiative
-; c/o Software Tool & Die
-; 1330 Beacon St, Brookline, MA 02146 USA
-; (617) 739-0202
-; obi@world.std.com
-
-; In this example, the heading lines are:
-;
-; FSF
-; House Subcommittee on Intellectual Property
-; George Lakoff
-; OBI (On line text collection.)
-
-; The `C-x C-p s' (sort-pages-buffer) command sorts the entries in the
-; buffer alphabetically.
-
-; You may use any of the page commands, including the `next-page',
-; `previous-page', `add-new-page', `mark-page', and `search-pages'
-; commands.
-
-; You may use either the `C-x C-p d' (pages-directory-for-addresses)
-; or the `C-x C-p C-d' (pages-directory) command to construct and
-; dislay a directory of all the heading lines.
-
-; In the directory, you may position the cursor over a heading line
-; and type `C-c C-c' to go to the entry to which it refers in the
-; pages buffer.
-
-; When used in conjunction with the `pages-directory-for-addresses'
-; command, the `C-c C-c' (pages-directory-goto) command narrows to the
-; entry to which it goes. But, when used in conjunction with the
-; `pages-directory' command, the `C-c C-c' (pages-directory-goto)
-; command does not narrow to the entry, but widens the buffer so you
-; can see the context surrounding the entry.
-
-; If you wish, you may create several different directories,
-; one for each different buffer.
-
-;; `pages-directory-for-addresses' in detail
-
-; The `pages-directory-for-addresses' assumes a default addresses
-; file. You do not need to specify the addresses file but merely type
-; `C-x C-p d' from any buffer. The command finds the file, constructs
-; a directory for it, and switches you to the directory. If you call
-; the command with a prefix arg, `C-u C-x C-p d', it prompts you for a
-; file name.
-
-;; `pages-directory' in detail
-
-; Call the `pages-directory' from the buffer for which you want a
-; directory created; it creates a directory for the buffer and pops
-; you to the directory.
-
-; The `pages-directory' command has several options:
-
-; Called with a prefix arg, `C-u C-x C-p C-d', the `pages-directory'
-; prompts you for a regular expression and only lists only those
-; header lines that are part of pages that contain matches to the
-; regexp. In the example above, `C-u C-x C-p C-d 617 RET' would
-; match the telephone area code of the first and fourth entries, so
-; only the header lines of those two entries would appear in the
-; pages-directory-buffer.
-;
-; Called with a numeric argument, the `pages-directory' command
-; lists the number of lines in each page. This is helpful when you
-; are printing hardcopy.
-
-; Called with a negative numeric argument, the `pages-directory'
-; command lists the lengths of pages whose contents match a regexp.
-
-
-;;;; Key bindings for page handling functions
-
-(global-unset-key "\C-x\C-p")
-
-(defvar ctl-x-ctl-p-map (make-sparse-keymap)
- "Keymap for subcommands of C-x C-p, which are for page handling.")
-
-(define-key ctl-x-map "\C-p" 'ctl-x-ctl-p-prefix)
-(fset 'ctl-x-ctl-p-prefix ctl-x-ctl-p-map)
-
-(define-key ctl-x-ctl-p-map "\C-n" 'next-page)
-(define-key ctl-x-ctl-p-map "\C-p" 'previous-page)
-(define-key ctl-x-ctl-p-map "\C-a" 'add-new-page)
-(define-key ctl-x-ctl-p-map "\C-m" 'mark-page)
-(define-key ctl-x-ctl-p-map "\C-s" 'search-pages)
-(define-key ctl-x-ctl-p-map "s" 'sort-pages-buffer)
-(define-key ctl-x-ctl-p-map "\C-l" 'set-page-delimiter)
-(define-key ctl-x-ctl-p-map "\C-d" 'pages-directory)
-(define-key ctl-x-ctl-p-map "d" 'pages-directory-for-addresses)
-
-
-;;;; Page movement function definitions
-
-(defun next-page (&optional count)
- "Move to the next page bounded by the `page-delimiter' variable.
-With arg (prefix if interactive), move that many pages."
- (interactive "p")
- (or count (setq count 1))
- (widen)
- ;; Cannot use forward-page because of problems at page boundaries.
- (while (and (> count 0) (not (eobp)))
- (if (re-search-forward page-delimiter nil t)
- nil
- (goto-char (point-max)))
- (setq count (1- count)))
- (while (and (< count 0) (not (bobp)))
- (if (re-search-backward page-delimiter nil t)
- (goto-char (match-beginning 0))
- (goto-char (point-min)))
- (setq count (1+ count)))
- (narrow-to-page)
- (goto-char (point-min))
- (recenter 0))
-
-(defun previous-page (&optional count)
- "Move to the previous page bounded by the `page-delimiter' variable.
-With arg (prefix if interactive), move that many pages."
- (interactive "p")
- (or count (setq count 1))
- (next-page (- count)))
-
-
-;;;; Adding and searching pages
-
-(defun add-new-page (header-line)
- "Insert new page at point; prompt for header line.
-Page begins with a `^L' as the page-delimiter.
-Point is left in the body of page."
- (interactive "sHeader line: ")
- (widen)
- (insert (format "\n \n%s\n\n" header-line))
- ;; don't renarrow; stay unnarrowed to see context
- (forward-line -1))
-
-(defvar pages-last-search nil
- "Value of last regexp searched for. Initially, nil.")
-
-(defun search-pages (regexp)
- "Search for REGEXP, starting from point, and narrow to page it is in."
- (interactive (list
- (read-string
- (format "Search for `%s' (end with RET): "
- (or pages-last-search "regexp")))))
- (if (equal regexp "")
- (setq regexp pages-last-search)
- (setq pages-last-search regexp))
- (widen)
- (re-search-forward regexp)
- (narrow-to-page))
-
-
-;;;; Sorting pages
-
-(autoload 'sort-subr "sort" "Primary function for sorting." t nil)
-
-(defun sort-pages-in-region (reverse beg end)
- "Sort pages in region alphabetically. Prefix arg means reverse order.
-
-Called from a program, there are three arguments:
-REVERSE (non-nil means reverse order), BEG and END (region to sort)."
-
-;;; This sort function handles ends of pages differently than
-;;; `sort-pages' and works better with lists of addresses and similar
-;;; files.
-
- (interactive "P\nr")
- (save-restriction
- (narrow-to-region beg end)
- (goto-char (point-min))
- ;;; `sort-subr' takes three arguments
- (sort-subr reverse
-
- ;; NEXTRECFUN is called with point at the end of the
- ;; previous record. It moves point to the start of the
- ;; next record.
- (function (lambda ()
- (re-search-forward page-delimiter nil t)
- (skip-chars-forward " \t\n")
- ))
-
- ;; ENDRECFUN is is called with point within the record.
- ;; It should move point to the end of the record.
- (function (lambda ()
- (if (re-search-forward
- page-delimiter
- nil
- t)
- (goto-char (match-beginning 0))
- (goto-char (point-max))))))))
-
-(defun sort-pages-buffer (&optional reverse)
- "Sort pages alphabetically in buffer. Prefix arg means reverse order.
-\(Non-nil arg if not interactive.\)"
-
- (interactive "P")
- (or reverse (setq reverse nil))
- (widen)
- (let ((beginning (point-min))
- (end (point-max)))
- (sort-pages-in-region reverse beginning end)))
-
-
-;;;; Pages directory ancillary definitions
-
-(defvar pages-directory-buffer-narrowing-p nil
- "*If non-nil, `pages-directory-goto' narrows pages buffer to entry.")
-
-(defvar pages-directory-previous-regexp nil
- "Value of previous regexp used by `pages-directory'.
-\(This regular expression may be used to select only those pages that
-contain matches to the regexp.\)")
-
-(defvar pages-buffer nil
- "The buffer for which the pages-directory function creates the directory.")
-
-(defvar pages-directory-prefix "*Directory for:"
- "Prefix of name of temporary buffer for pages-directory.")
-
-(defvar pages-pos-list nil
- "List containing the positions of the pages in the pages-buffer.")
-
-(defvar pages-directory-map nil
- "Keymap for the pages-directory-buffer.")
-
-(if pages-directory-map
- ()
- (setq pages-directory-map (make-sparse-keymap))
- (define-key pages-directory-map "\C-c\C-c"
- 'pages-directory-goto))
-
-(defun set-page-delimiter (regexp reset-p)
- "Set buffer local value of page-delimiter to REGEXP.
-Called interactively with a prefix argument, reset `page-delimiter' to
-its original value.
-
-In a program, non-nil second arg causes first arg to be ignored and
-resets the page-delimiter to the original value."
-
- (interactive
- (if current-prefix-arg
- (list original-page-delimiter nil)
- (list (read-string "Set page-delimiter to regexp: " page-delimiter)
- nil)))
- (make-local-variable 'original-page-delimiter)
- (make-local-variable 'page-delimiter)
- (setq original-page-delimiter
- (or original-page-delimiter page-delimiter))
- (if (not reset-p)
- (setq page-delimiter regexp)
- (setq page-delimiter original-page-delimiter))
- (if (interactive-p)
- (message "The value of `page-delimiter' is now: %s" page-delimiter)))
-
-
-;;;; Pages directory main definitions
-
-(defun pages-directory
- (pages-list-all-headers-p count-lines-p &optional regexp)
- "Display a directory of the page headers in a temporary buffer.
-A header is the first non-blank line after the page-delimiter.
-\\[pages-directory-mode]
-You may move point to one of the lines in the temporary buffer,
-then use \\<pages-directory-goto> to go to the same line in the pages buffer.
-
-In interactive use:
-
- 1. With no prefix arg, display all headers.
-
- 2. With prefix arg, display the headers of only those pages that
- contain matches to a regular expression for which you are
- prompted.
-
- 3. With numeric prefix arg, for every page, print the number of
- lines within each page.
-
- 4. With negative numeric prefix arg, for only those pages that
- match a regular expression, print the number of lines within
- each page.
-
-When called from a program, non-nil first arg means list all headers;
-non-nil second arg means print numbers of lines in each page; if first
-arg is nil, optional third arg is regular expression.
-
-If the buffer is narrowed, the `pages-directory' command creates a
-directory for only the accessible portion of the buffer."
-
- (interactive
- (cond ((not current-prefix-arg)
- (list t nil nil))
- ((listp current-prefix-arg)
- (list nil
- nil
- (read-string
- (format "Select according to `%s' (end with RET): "
- (or pages-directory-previous-regexp "regexp")))))
- ((> (prefix-numeric-value current-prefix-arg) 0)
- (list t t nil))
- ((< (prefix-numeric-value current-prefix-arg) 0)
- (list nil
- t
- (read-string
- (format "Select according to `%s' (end with RET): "
- (or pages-directory-previous-regexp "regexp")))))))
-
- (if (equal regexp "")
- (setq regexp pages-directory-previous-regexp)
- (setq pages-directory-previous-regexp regexp))
-
- (if (interactive-p)
- (message "Creating directory for: %s "
- (buffer-name)))
-
- (let ((buffer (current-buffer))
- (pages-directory-buffer
- (concat pages-directory-prefix " " (buffer-name) " "))
- (linenum 1)
- (pages-buffer-original-position (point))
- (pages-buffer-original-page 0))
-
- ;; `with-output-to-temp-buffer' binds the value of the variable
- ;; `standard-output' to the buffer named as its first argument,
- ;; but does not switch to that buffer.
- (with-output-to-temp-buffer pages-directory-buffer
- (save-excursion
- (set-buffer standard-output)
- (pages-directory-mode)
- (insert
- "==== Pages Directory: use `C-c C-c' to go to page under cursor. ====" ?\n)
- (setq pages-buffer buffer)
- (setq pages-pos-list nil))
-
- (if pages-list-all-headers-p
-
- ;; 1. If no prefix argument, list all headers
- (save-excursion
- (goto-char (point-min))
-
- ;; (a) Point is at beginning of buffer; but the first
- ;; page may not begin with a page-delimiter
- (save-restriction
- ;; If page delimiter is at beginning of buffer, skip it
- (if (and (save-excursion
- (re-search-forward page-delimiter nil t))
- (= 1 (match-beginning 0)))
- (goto-char (match-end 0)))
- (narrow-to-page)
- (pages-copy-header-and-position count-lines-p))
-
- ;; (b) Search within pages buffer for next page-delimiter
- (while (re-search-forward page-delimiter nil t)
- (pages-copy-header-and-position count-lines-p)))
-
- ;; 2. Else list headers whose pages match regexp.
- (save-excursion
- ;; REMOVED save-restriction AND widen FROM HERE
- (goto-char (point-min))
-
- ;; (a) Handle first page
- (save-restriction
- (narrow-to-page)
- ;; search for selection regexp
- (if (save-excursion (re-search-forward regexp nil t))
- (pages-copy-header-and-position count-lines-p)))
-
- ;; (b) Search for next page-delimiter
- (while (re-search-forward page-delimiter nil t)
- (save-restriction
- (narrow-to-page)
- ;; search for selection regexp
- (if (save-excursion (re-search-forward regexp nil t))
- (pages-copy-header-and-position count-lines-p)
- )))))
-
- (set-buffer standard-output)
- ;; Put positions in increasing order to go with buffer.
- (setq pages-pos-list (nreverse pages-pos-list))
- (if (interactive-p)
- (message "%d matching lines in: %s"
- (length pages-pos-list) (buffer-name buffer))))
- (pop-to-buffer pages-directory-buffer)
- (sit-for 0) ; otherwise forward-line fails if N > window height.
- (forward-line (if (= 0 pages-buffer-original-page)
- 1
- pages-buffer-original-page))))
-
-(defun pages-copy-header-and-position (count-lines-p)
- "Copy page header and its position to the Pages Directory.
-Only arg non-nil, count lines in page and insert before header.
-Used by `pages-directory' function."
-
- (let (position line-count)
-
- (if count-lines-p
- (save-excursion
- (save-restriction
- (narrow-to-page)
- (setq line-count (count-lines (point-min) (point-max))))))
-
- ;; Keep track of page for later cursor positioning
- (if (<= (point) pages-buffer-original-position)
- (setq pages-buffer-original-page
- (1+ pages-buffer-original-page)))
-
- (save-excursion
- ;; go to first non-blank char after the page-delimiter
- (skip-chars-forward " \t\n")
- ;; set the marker here; this the place to which the
- ;; `pages-directory-goto' command will go
- (setq position (make-marker))
- (set-marker position (point))
- (let ((start (point))
- (end (save-excursion (end-of-line) (point))))
- ;; change to directory buffer
- (set-buffer standard-output)
- ;; record page position
- (setq pages-pos-list (cons position pages-pos-list))
- ;; insert page header
- (insert-buffer-substring buffer start end))
-
- (if count-lines-p
- (save-excursion
- (beginning-of-line)
- (insert (format "%3d: " line-count))))
-
- (terpri))
- (forward-line 1)))
-
-(defun pages-directory-mode ()
- "Mode for handling the pages-directory buffer.
-
-Move point to one of the lines in this buffer, then use \\[pages-directory-goto] to go
-to the same line in the pages buffer."
-
- (kill-all-local-variables)
- (use-local-map pages-directory-map)
- (setq major-mode 'pages-directory-mode)
- (setq mode-name "Pages-Directory")
- (make-local-variable 'pages-buffer)
- (make-local-variable 'pages-pos-list)
- (make-local-variable 'pages-directory-buffer-narrowing-p))
-
-(defun pages-directory-goto ()
- "Go to the corresponding line in the pages buffer."
-
-;;; This function is mostly a copy of `occur-mode-goto-occurrence'
-
- (interactive)
- (if (or (not pages-buffer)
- (not (buffer-name pages-buffer)))
- (progn
- (setq pages-buffer nil
- pages-pos-list nil)
- (error "Buffer in which pages were found is deleted.")))
- (beginning-of-line)
- (let* ((pages-number (1- (count-lines (point-min) (point))))
- (pos (nth pages-number pages-pos-list))
- (end-of-directory-p (eobp))
- (narrowing-p pages-directory-buffer-narrowing-p))
- (pop-to-buffer pages-buffer)
- (widen)
- (if end-of-directory-p
- (goto-char (point-max))
- (goto-char (marker-position pos)))
- (if narrowing-p (narrow-to-page))))
-
-
-;;;; The `pages-directory-for-addresses' function and ancillary code
-
-(defvar pages-addresses-file-name "~/addresses"
- "*Standard name for file of addresses. Entries separated by `page-delimiter'.
-Used by `pages-directory-for-addresses' function.")
-
-(defvar pages-directory-for-addresses-narrowing-p t
- "*If non-nil, `pages-directory-goto' narrows addresses buffer to entry.")
-
-(defun pages-directory-for-addresses (&optional filename)
- "Find addresses file and display its directory.
-By default, create and display directory of `pages-addresses-file-name'.
-Optional argument is FILENAME. In interactive use, with prefix
-argument, prompt for file name and provide completion.
-
-Move point to one of the lines in the displayed directory,
-then use C-c C-c to go to the same line in the addresses buffer."
-
- (interactive
- (list (if current-prefix-arg
- (read-file-name "Filename: " pages-addresses-file-name))))
-
- (if (interactive-p)
- (message "Creating directory for: %s "
- (or filename pages-addresses-file-name)))
- (if (file-exists-p (or filename pages-addresses-file-name))
- (progn
- (set-buffer
- (find-file-noselect
- (expand-file-name
- (or filename pages-addresses-file-name))))
- (widen)
- (pages-directory t nil nil)
- (pages-directory-address-mode)
- (setq pages-directory-buffer-narrowing-p
- pages-directory-for-addresses-narrowing-p)
- (delete-other-windows)
- (save-excursion
- (goto-char (point-min))
- (delete-region (point) (save-excursion (end-of-line) (point)))
- (insert
- "=== Address List Directory: use `C-c C-c' to go to page under cursor. ===")
- (set-buffer-modified-p nil)
- ))
- (error "No addresses file found!")))
-
-(defun pages-directory-address-mode ()
- "Mode for handling the Addresses Directory buffer.
-
-Move point to one of the lines in this buffer, then use C-c C-c to go
-to the same line in the pages buffer."
-
- (use-local-map pages-directory-map)
- (setq major-mode 'pages-directory-address-mode)
- (setq mode-name "Addresses Directory")
- (make-local-variable 'pages-buffer)
- (make-local-variable 'pages-pos-list)
- (make-local-variable 'pages-directory-buffer-narrowing-p))
-
-;;;;;;;;;;;;;;;; end of page-ext.el ;;;;;;;;;;;;;;;;
diff --git a/lisp/textmodes/refbib.el b/lisp/textmodes/refbib.el
deleted file mode 100644
index 3b376cdd90b..00000000000
--- a/lisp/textmodes/refbib.el
+++ /dev/null
@@ -1,715 +0,0 @@
-;; Convert refer-style bibliographic entries to ones usable by latex bib
-;; Copyright (C) 1989 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;; Use: from a buffer containing the refer-style bibliography,
-;; M-x r2b-convert-buffer
-;; Program will prompt for an output buffer name, and will log
-;; warnings during the conversion process in the buffer *Log*.
-
-; HISTORY
-; 9/88, created
-; modified 1/19/89, allow books with editor but no author;
-; added %O ordering field;
-; appended illegal multiple fields, instead of
-; discarding;
-; added rule, a tech report whose %R number
-; contains "ISBN" is really a book
-; added rule, anything with an editor is a book
-; or a proceedings
-; added 'manual type, for items with institution
-; but no author or editor
-; fixed bug so trailing blanks are trimmed
-; added 'proceedings type
-; used "organization" field for proceedings
-; modified 2/16/89, updated help messages
-; modified 2/23/89, include capitalize stop words in r2b stop words,
-; fixed problems with contractions (e.g. it's),
-; caught multiple stop words in a row
-; modified 3/1/89, fixed capitialize-title for first words all caps
-; modified 3/15/89, allow use of " to delimit fields
-; modified 4/18/89, properly "quote" special characters on output
-(provide 'refer-to-bibtex)
-;**********************************************************
-; User Parameters
-
-(defvar r2b-trace-on nil "*trace conversion")
-
-(defvar r2b-journal-abbrevs
- '(
- )
- " Abbreviation list for journal names.
-If the car of an element matches a journal name exactly, it is replaced by
-the cadr when output. Braces must be included if replacement is a
-{string}, but not if replacement is a bibtex abbreviation. The cadr
-may be eliminated if is exactly the same as the car.
- Because titles are capitalized before matching, the abbreviation
-for the journal name should be listed as beginning with a capital
-letter, even if it really doesn't.
- For example, a value of '((\"Aij\" \"{Artificial Intelligence}\")
-(\"Ijcai81\" \"ijcai7\")) would expand Aij to the text string
-\"Artificial Intelligence\", but would replace Ijcai81 with the
-BibTeX macro \"ijcai7\".")
-
-(defvar r2b-booktitle-abbrevs
- '(
- )
- " Abbreviation list for book and proceedings names. If the car of
-an element matches a title or booktitle exactly, it is replaced by
-the cadr when output. Braces must be included if replacement is
-a {string}, but not if replacement is a bibtex abbreviation. The cadr
-may be eliminated if is exactly the same as the car.
- Because titles are capitalized before matching, the abbreviated title
-should be listed as beginning with a capital letter, even if it doesn't.
- For example, a value of '((\"Aij\" \"{Artificial Intelligence}\")
-(\"Ijcai81\" \"ijcai7\")) would expand Aij to the text string
-\"Artificial Intelligence\", but would replace Ijcai81 with the
-BibTeX macro \"ijcai7\".")
-
-(defvar r2b-proceedings-list
- '()
- " Assoc list of books or journals which are really conference proceedings,
-but whose name and whose abbrev expansion (as defined in r2b-journal-abbrevs
-and r2b-booktitle-abbrevs) does not contain the words 'conference' or
-'proceedings'. (Those cases are handled automatically.)
-The entry must match the given data exactly.
- Because titles are capitalized before matching, the items in this list
-should begin with a capital letter.
- For example, suppose the title \"Ijcai81\" is used for the proceedings of
-a conference, and it's expansion is the BibTeX macro \"ijcai7\". Then
-r2b-proceedings-list should be '((\"Ijcai81\") ...). If instead its
-expansion were \"Proceedings of the Seventh International Conference
-on Artificial Intelligence\", then you would NOT need to include Ijcai81
-in r2b-proceedings-list (although it wouldn't cause an error).")
-
-(defvar r2b-additional-stop-words
- "Some\\|What"
- "Words other than the capitialize-title-stop-words
-which are not to be used to build the citation key")
-
-
-(defvar r2b-delimit-with-quote
- t
- "*If true, then use \" to delimit fields, otherwise use braces")
-
-;**********************************************************
-; Utility Functions
-
-(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 capitialized in a title (unless they are 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)))
-
-;*********************************************************
-(defun r2b-reset ()
- "unbind defvars, for debugging"
- (interactive)
- (makunbound 'r2b-journal-abbrevs)
- (makunbound 'r2b-booktitle-abbrevs)
- (makunbound 'r2b-proceedings-list)
- (makunbound 'capitalize-title-stop-words)
- (makunbound 'capitalize-title-stop-regexp)
- (makunbound 'r2b-additional-stop-words)
- (makunbound 'r2b-stop-regexp)
- )
-
-(defvar r2b-stop-regexp
- (concat "\\`\\(\\("
- r2b-additional-stop-words "\\|" capitalize-title-stop-words
- "\\)\\('\\w*\\)?\\W+\\)*\\([A-Z0-9]+\\)"))
-
-
-(defun r2b-trace (&rest args)
- (if r2b-trace-on
- (progn
- (apply (function message) args)
- (sit-for 0)
- )))
-
-(defun r2b-match (exp)
- "returns string matched in current buffer"
- (buffer-substring (match-beginning exp) (match-end exp)))
-
-(defvar r2b-out-buf-name "*Out*" "*output from refer-to-bibtex" )
-(defvar r2b-log-name "*Log*" "*logs errors from refer-to-bibtex" )
-(defvar r2b-in-buf nil)
-(defvar r2b-out-buf nil)
-(defvar r2b-log nil)
-
-(defvar r2b-error-found nil)
-
-(setq r2b-variables '(
- r2b-error-found
- r2bv-author
- r2bv-primary-author
- r2bv-date
- r2bv-year
- r2bv-decade
- r2bv-month
- r2bv-title
- r2bv-title-first-word
- r2bv-editor
- r2bv-annote
- r2bv-tr
- r2bv-address
- r2bv-institution
- r2bv-keywords
- r2bv-booktitle
- r2bv-journal
- r2bv-volume
- r2bv-number
- r2bv-pages
- r2bv-booktitle
- r2bv-kn
- r2bv-publisher
- r2bv-organization
- r2bv-school
- r2bv-type
- r2bv-where
- r2bv-note
- r2bv-ordering
- ))
-
-(defun r2b-clear-variables ()
- "set all global vars used by r2b to nil"
- (let ((vars r2b-variables))
- (while vars
- (set (car vars) nil)
- (setq vars (cdr vars)))
- ))
-
-(defun r2b-warning (&rest args)
- (setq r2b-error-found t)
- (princ (apply (function format) args) r2b-log)
- (princ "\n" r2b-log)
- (princ "\n" r2b-out-buf)
- (princ "% " r2b-out-buf)
- (princ (apply (function format) args) r2b-out-buf)
- )
-
-(defun r2b-get-field (var field &optional unique required capitalize)
- "Set VAR to string value of FIELD, if any. If none, VAR is set to
-nil. If multiple fields appear, then separate values with the
-'\\nand\\t\\t', unless UNIQUE is non-nil, in which case log a warning
-and just concatenate the values. Trim off leading blanks and tabs on
-first line, and trailing blanks and tabs of every line. Log a warning
-and set VAR to the empty string if REQUIRED is true. Capitalize as a
-title if CAPITALIZE is true. Returns value of VAR."
- (let (item val (not-past-end t))
- (r2b-trace "snarfing %s" field)
- (goto-char (point-min))
- (while (and not-past-end
- (re-search-forward
- (concat "^" field "\\b[ \t]*\\(.*[^ \t\n]\\)[ \t]*") nil t))
- (setq item (r2b-match 1))
- (while (and (setq not-past-end (zerop (forward-line 1)))
- (not (looking-at "[ \t]*$\\|%")))
- (looking-at "\\(.*[^ \t\n]\\)[ \t]*$")
- (setq item (concat item "\n" (r2b-match 1)))
- )
- (if (null val)
- (setq val item)
- (if unique
- (progn
- (r2b-warning "*Illegal multiple field %s %s" field item)
- (setq val (concat val "\n" item))
- )
- (setq val (concat val "\n\t\tand " item))
- )
- )
- )
- (if (and val capitalize)
- (setq val (capitalize-title val)))
- (set var val)
- (if (and (null val) required)
- (r2b-require var))
- ))
-
-(defun r2b-set-match (var n regexp string )
- "set VAR to the Nth subpattern in REGEXP matched by STRING, or nil if none"
- (set var
- (if (and (stringp string) (string-match regexp string))
- (substring string (match-beginning n) (match-end n))
- nil)
- )
- )
-
-(defvar r2b-month-abbrevs
- '(("jan") ("feb") ("mar") ("apr") ("may") ("jun") ("jul") ("aug")
- ("sep") ("oct") ("nov") ("dec")))
-
-(defun r2b-convert-month ()
- "Try to convert r2bv-month to a standard 3 letter name"
- (if r2bv-month
- (let ((months r2b-month-abbrevs))
- (if (string-match "[^0-9]" r2bv-month)
- (progn
- (while (and months (not (string-match (car (car months))
- r2bv-month)))
- (setq months (cdr months)))
- (if months
- (setq r2bv-month (car (car months)))))
- (progn
- (setq months (car (read-from-string r2bv-month)))
- (if (and (numberp months)
- (> months 0)
- (< months 13))
- (setq r2bv-month (car (nth months r2b-month-abbrevs)))
- (progn
- (r2b-warning "* Ridiculous month")
- (setq r2bv-month nil))
- ))
- ))
- )
- )
-
-(defun r2b-snarf-input ()
- "parse buffer into global variables"
- (let ((case-fold-search t))
- (r2b-trace "snarfing...")
- (sit-for 0)
- (set-buffer r2b-in-buf)
- (goto-char (point-min))
- (princ " " r2b-log)
- (princ (buffer-substring (point) (progn (end-of-line) (point))) r2b-log)
- (terpri r2b-log)
-
- (r2b-get-field 'r2bv-author "%A")
- (r2b-get-field 'r2bv-editor "%E")
- (cond
- (r2bv-author
- (r2b-set-match 'r2bv-primary-author 1
- "\\b\\(\\w+\\)[ \t]*\\($\\|,\\)" r2bv-author)
- )
- (r2bv-editor
- (r2b-set-match 'r2bv-primary-author 1
- "\\b\\(\\w+\\)[ \t]*\\($\\|,\\)" r2bv-editor)
- )
- (t
- (setq r2bv-primary-author "")
- )
- )
-
- (r2b-get-field 'r2bv-date "%D" t t)
- (r2b-set-match 'r2bv-year 0 "[12][0-9][0-9][0-9]" r2bv-date)
- (and (null r2bv-year)
- (r2b-set-match 'r2bv-year 1 "[^0-9]\\([0-9][0-9]\\)$" r2bv-date)
- (setq r2bv-year (concat "19" r2bv-year)))
- (r2b-set-match 'r2bv-decade 1 "..\\(..\\)" r2bv-year)
- (r2b-set-match 'r2bv-month 0
- "[0-9]+/\\|[a-zA-Z]+" r2bv-date)
- (if (and (stringp r2bv-month) (string-match "\\(.*\\)/$" r2bv-month))
- (setq r2bv-month (substring r2bv-month 0 (match-end 1))))
- (r2b-convert-month)
-
- (r2b-get-field 'r2bv-title "%T" t t t)
- (r2b-set-match 'r2bv-title-first-word 4
- r2b-stop-regexp
- r2bv-title)
-
- (r2b-get-field 'r2bv-annote "%X" t )
- (r2b-get-field 'r2bv-tr "%R" t)
- (r2b-get-field 'r2bv-address "%C" t)
- (r2b-get-field 'r2bv-institution "%I" t)
- (r2b-get-field 'r2bv-keywords "%K")
- (r2b-get-field 'r2bv-booktitle "%B" t nil t)
- (r2b-get-field 'r2bv-journal "%J" t nil t)
- (r2b-get-field 'r2bv-volume "%V" t)
- (r2b-get-field 'r2bv-number "%N" t)
- (r2b-get-field 'r2bv-pages "%P" t)
- (r2b-get-field 'r2bv-where "%W" t)
- (r2b-get-field 'r2bv-ordering "%O" t)
- )
- )
-
-
-(defun r2b-put-field (field data &optional abbrevs)
- "print bibtex FIELD = {DATA} if DATA not null; precede
-with a comma and newline; if ABBREVS list is given, then
-try to replace the {DATA} with an abbreviation"
- (if data
- (let (match nodelim multi-line index)
- (cond
- ((and abbrevs (setq match (assoc data abbrevs)))
- (if (null (cdr match))
- (setq data (car match))
- (setq data (car (cdr match))))
- (setq nodelim t))
- ((and (not (equal data ""))
- (not (string-match "[^0-9]" data)))
- (setq nodelim t))
- (t
- (setq index 0)
- (while (string-match "[\\~^]" data index)
- (setq data (concat (substring data 0 (match-beginning 0))
- "\\verb+"
- (substring data (match-beginning 0) (match-end 0))
- "+"
- (substring data (match-end 0))))
- (setq index (+ (match-end 0) 7)))
- (setq index 0)
- (while (string-match "[$&%#_{}]" data index)
- (setq data (concat (substring data 0 (match-beginning 0))
- "\\"
- (substring data (match-beginning 0))))
- (setq index (+ (match-end 0) 1)))
- (setq index 0)
- (if r2b-delimit-with-quote
- (while (string-match "\"" data index)
- (setq data (concat (substring data 0 (match-beginning 0))
- "{\"}"
- (substring data (match-end 0))))
- (setq index (+ (match-end 0) 2))))
- ))
- (princ ", \n ")
- (princ field)
- (princ " =\t")
- (if (not nodelim)
- (if r2b-delimit-with-quote
- (princ "\"")
- (princ "{")))
- (string-match ".*" data)
- (if (> (match-end 0) 59)
- (princ "\n"))
- (princ data)
- (if (not nodelim)
- (if r2b-delimit-with-quote
- (princ "\"")
- (princ "}")))
- )
- ))
-
-
-(defun r2b-require (vars)
- "If any of VARS is null, set to empty string and log error"
- (cond
- ((null vars))
- ((listp vars) (r2b-require (car vars)) (r2b-require (cdr vars)))
- (t
- (if (null (symbol-value vars))
- (progn
- (r2b-warning "*Missing value for field %s" vars)
- (set vars "")
- )))
- )
- )
-
-
-(defmacro r2b-moveq (new old)
- "set NEW to OLD and set OLD to nil"
- (list 'progn (list 'setq new old) (list 'setq old 'nil)))
-
-(defun r2b-isa-proceedings (name)
- "return t if NAME is the name of proceedings"
- (and
- name
- (or
- (string-match "proceedings\\|conference" name)
- (assoc name r2b-proceedings-list)
- (let ((match (assoc name r2b-booktitle-abbrevs)))
- (and match
- (string-match "proceedings\\|conference" (car (cdr match)))))
- )))
-
-(defun r2b-isa-university (name)
- "return t if NAME is a university or similar organization,
-but not a publisher"
- (and
- name
- (string-match "university" name)
- (not (string-match "press" name))
-
- ))
-
-(defun r2b-barf-output ()
- "generate bibtex based on global variables"
- (let ((standard-output r2b-out-buf) (case-fold-search t) match)
-
- (r2b-trace "...barfing")
- (sit-for 0)
- (set-buffer r2b-out-buf)
-
- (setq r2bv-kn (concat r2bv-primary-author r2bv-decade
- r2bv-title-first-word))
-
- (setq r2bv-entry-kind
- (cond
- ((r2b-isa-proceedings r2bv-journal)
- (r2b-moveq r2bv-booktitle r2bv-journal)
- (if (r2b-isa-university r2bv-institution)
- (r2b-moveq r2bv-organization r2bv-institution)
- (r2b-moveq r2bv-publisher r2bv-institution))
- (r2b-moveq r2bv-note r2bv-tr)
- (r2b-require 'r2bv-author)
- 'inproceedings)
- ((r2b-isa-proceedings r2bv-booktitle)
- (if (r2b-isa-university r2bv-institution)
- (r2b-moveq r2bv-organization r2bv-institution)
- (r2b-moveq r2bv-publisher r2bv-institution))
- (r2b-moveq r2bv-note r2bv-tr)
- (r2b-require 'r2bv-author)
- 'inproceedings)
- ((and r2bv-tr (string-match "phd" r2bv-tr))
- (r2b-moveq r2bv-school r2bv-institution)
- (r2b-require 'r2bv-school )
- (r2b-require 'r2bv-author)
- 'phdthesis)
- ((and r2bv-tr (string-match "master" r2bv-tr))
- (r2b-moveq r2bv-school r2bv-institution)
- (r2b-require 'r2bv-school )
- (r2b-require 'r2bv-author)
- 'mastersthesis)
- ((and r2bv-tr (string-match "draft\\|unpublish" r2bv-tr))
- (r2b-moveq r2bv-note r2bv-institution)
- (r2b-require 'r2bv-author)
- 'unpublished)
- (r2bv-journal
- (r2b-require 'r2bv-author)
- 'article)
- (r2bv-booktitle
- (r2b-moveq r2bv-publisher r2bv-institution)
- (r2b-moveq r2bv-note r2bv-tr)
- (r2b-require 'r2bv-publisher)
- (r2b-require 'r2bv-author)
- 'incollection)
- ((and r2bv-author
- (null r2bv-editor)
- (string-match "\\`personal communication\\'" r2bv-title))
- 'misc)
- ((r2b-isa-proceedings r2bv-title)
- (if (r2b-isa-university r2bv-institution)
- (r2b-moveq r2bv-organization r2bv-institution)
- (r2b-moveq r2bv-publisher r2bv-institution))
- (r2b-moveq r2bv-note r2bv-tr)
- 'proceedings)
- ((or r2bv-editor
- (and r2bv-author
- (or
- (null r2bv-tr)
- (string-match "\\bisbn\\b" r2bv-tr))))
- (r2b-moveq r2bv-publisher r2bv-institution)
- (r2b-moveq r2bv-note r2bv-tr)
- (r2b-require 'r2bv-publisher)
- (if (null r2bv-editor)
- (r2b-require 'r2bv-author))
- 'book)
- (r2bv-tr
- (r2b-require 'r2bv-institution)
- (if (string-match
- "\\`\\(\\(.\\|\n\\)+\\)[ \t\n]+\\([^ \t\n]\\)+\\'"
- r2bv-tr)
- (progn
- (setq r2bv-type (substring r2bv-tr 0 (match-end 1)))
- (setq r2bv-number (substring r2bv-tr
- (match-beginning 3)))
- (setq r2bv-tr nil))
- (r2b-moveq r2bv-number r2bv-tr))
- (r2b-require 'r2bv-author)
- 'techreport)
- (r2bv-institution
- (r2b-moveq r2bv-organization r2bv-institution)
- 'manual)
- (t
- 'misc)
- ))
-
- (r2b-require '( r2bv-year))
-
- (if r2b-error-found
- (princ "\n% Warning -- Errors During Conversion Next Entry\n"))
-
- (princ "\n@")
- (princ r2bv-entry-kind)
- (princ "( ")
- (princ r2bv-kn)
-
- (r2b-put-field "author" r2bv-author )
- (r2b-put-field "title" r2bv-title r2b-booktitle-abbrevs)
- (r2b-put-field "year" r2bv-year )
-
- (r2b-put-field "month" r2bv-month r2b-month-abbrevs)
- (r2b-put-field "journal" r2bv-journal r2b-journal-abbrevs)
- (r2b-put-field "volume" r2bv-volume)
- (r2b-put-field "type" r2bv-type)
- (r2b-put-field "number" r2bv-number)
- (r2b-put-field "booktitle" r2bv-booktitle r2b-booktitle-abbrevs)
- (r2b-put-field "editor" r2bv-editor)
- (r2b-put-field "publisher" r2bv-publisher)
- (r2b-put-field "institution" r2bv-institution)
- (r2b-put-field "organization" r2bv-organization)
- (r2b-put-field "school" r2bv-school)
- (r2b-put-field "pages" r2bv-pages)
- (r2b-put-field "address" r2bv-address)
- (r2b-put-field "note" r2bv-note)
- (r2b-put-field "keywords" r2bv-keywords)
- (r2b-put-field "where" r2bv-where)
- (r2b-put-field "ordering" r2bv-ordering)
- (r2b-put-field "annote" r2bv-annote)
-
- (princ " )\n")
- )
- )
-
-
-(defun r2b-convert-record (output-name)
- "transform current bib entry and append to buffer OUTPUT;
-do M-x r2b-help for more info"
- (interactive
- (list (read-string "Output to buffer: " r2b-out-buf-name)))
- (let (rec-end rec-begin not-done)
- (setq r2b-out-buf-name output-name)
- (setq r2b-out-buf (get-buffer-create output-name))
- (setq r2b-in-buf (current-buffer))
- (set-buffer r2b-out-buf)
- (goto-char (point-max))
- (setq r2b-log (get-buffer-create r2b-log-name))
- (set-buffer r2b-log)
- (goto-char (point-max))
- (set-buffer r2b-in-buf)
- (setq not-done (re-search-forward "[^ \t\n]" nil t))
- (if not-done
- (progn
- (re-search-backward "^[ \t]*$" nil 2)
- (re-search-forward "^%")
- (beginning-of-line nil)
- (setq rec-begin (point))
- (re-search-forward "^[ \t]*$" nil 2)
- (setq rec-end (point))
- (narrow-to-region rec-begin rec-end)
- (r2b-clear-variables)
- (r2b-snarf-input)
- (r2b-barf-output)
- (set-buffer r2b-in-buf)
- (widen)
- (goto-char rec-end)
- t)
- nil
- )
- ))
-
-
-(defun r2b-convert-buffer (output-name)
- "transform current buffer and append to buffer OUTPUT;
-do M-x r2b-help for more info"
- (interactive
- (list (read-string "Output to buffer: " r2b-out-buf-name)))
- (save-excursion
- (setq r2b-log (get-buffer-create r2b-log-name))
- (set-buffer r2b-log)
- (erase-buffer))
- (widen)
- (goto-char (point-min))
- (message "Working, please be patient...")
- (sit-for 0)
- (while (r2b-convert-record output-name) t)
- (message "Done, results in %s, errors in %s"
- r2b-out-buf-name r2b-log-name)
- )
-
-(defvar r2b-load-quietly nil "*Don't print help message when loaded")
-
-(defvar r2b-help-message
-" Refer to Bibtex Bibliography Conversion
-
-A refer-style database is of the form:
-
-%A Joe Blow
-%T Great Thoughts I've Thought
-%D 1977
-etc.
-
-This utility converts these kind of databases to bibtex form, for
-users of TeX and LaTex. Instructions:
-1. Visit the file containing the refer-style database.
-2. The command
- M-x r2b-convert-buffer
- converts the entire buffer, appending it's output by default in a
- buffer named *Out*, and logging progress and errors in a buffer
- named *Log*. The original file is never modified.
- Note that results are appended to *Out*, so if that buffer
- buffer already exists and contains material you don't want to
- save, you should kill it first.
-3. Switch to the buffer *Out* and save it as a named file.
-4. To convert a single refer-style entry, simply position the cursor
- at the entry and enter
- M-x r2b-convert-record
- Again output is appended to *Out* and errors are logged in *Log*.
-
-This utility is very robust and pretty smart about determining the
-type of the entry. It includes facilities for expanding refer macros
-to text, or substituting bibtex macros. Do M-x describe-variable on
- r2b-journal-abbrevs
- r2b-booktitle-abbrevs
- r2b-proceedings-list
-for information on these features.
-
-If you don't want to see this help message when you load this utility,
-then include the following line in your .emacs file:
- (setq r2b-load-quietly t)
-To see this message again, perform
- M-x r2b-help")
-
-
-(defun r2b-help ()
- "print help message"
- (interactive)
- (with-output-to-temp-buffer "*Help*"
- (princ r2b-help-message)))
-
-(if (not r2b-load-quietly)
- (r2b-help))
-
-(message "r2b loaded")
-
diff --git a/lisp/textmodes/tex-mode.el b/lisp/textmodes/tex-mode.el
deleted file mode 100644
index 34daea299a3..00000000000
--- a/lisp/textmodes/tex-mode.el
+++ /dev/null
@@ -1,799 +0,0 @@
-;; TeX, LaTeX, and SliTeX mode commands.
-;; Copyright (C) 1985, 1986, 1989 Free Software Foundation, Inc.
-;; Rewritten following contributions by William F. Schelter
-;; and Dick King (king@kestrel).
-;; Supported since 1986 by Stephen Gildea <gildea@erl.mit.edu>
-;; and Michael Prange <prange@erl.mit.edu>.
-;; Various improvements and corrections in Fall, 1989 by
-;; Edward M. Reingold <reingold@cs.uiuc.edu>.
-
-;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;; Still to do:
-;; Make TAB indent correctly for TeX code. Then we can make Linefeed
-;; do something more useful.
-;;
-;; Have spell understand TeX instead of assuming the entire world
-;; uses nroff.
-;;
-;; The code for finding matching $ needs to be fixed.
-
-(require 'oshell)
-(provide 'tex-mode)
-
-(defvar tex-directory "./"
- "*Directory in which to run TeX subjob. Temporary files are created here.")
-
-(defvar tex-run-command "tex"
- "*Command used to run TeX subjob.
-The name of the file will be appended to this string, separated by a space.")
-
-(defvar latex-run-command "latex"
- "*Command used to run LaTeX subjob.
-The name of the file will be appended to this string, separated by a space.")
-
-(defvar slitex-run-command "slitex"
- "*Command used to run SliTeX subjob.
-The name of the file will be appended to this string, separated by a space.")
-
-(defvar tex-bibtex-command "bibtex"
- "*Command string used by `tex-bibtex-file' to gather bibliographic data.
-The name of the file will be appended to this string, separated by a space.")
-
-(defvar tex-dvi-print-command "lpr -d"
- "*Command string used by \\[tex-print] to print a .dvi file.")
-
-(defvar tex-dvi-view-command nil
- "*Command string used by \\[tex-view] to display a .dvi file.")
-
-(defvar tex-show-queue-command "lpq"
- "*Command string used by \\[tex-show-print-queue] to show the print queue.
-Should show the queue that \\[tex-print] puts jobs on.")
-
-(defvar tex-default-mode 'plain-tex-mode
- "*Mode to enter for a new file that might be either TeX or LaTeX.
-This variable is used when it can't be determined whether the file
-is plain TeX or LaTeX or what because the file contains no commands.
-Normally set to either 'plain-tex-mode or 'latex-mode.")
-
-(defvar tex-open-quote "``"
- "*String inserted by typing \\[tex-insert-quote] to open a quotation.")
-
-(defvar tex-close-quote "''"
- "*String inserted by typing \\[tex-insert-quote] to close a quotation.")
-
-(defvar tex-command nil
- "Command to run TeX.
-The name of the file will be appended to this string, separated by a space.")
-
-(defvar tex-trailer nil
- "String appended after the end of a region sent to TeX by \\[tex-region].")
-
-(defvar tex-start-of-header nil
- "String used by \\[tex-region] to delimit the start of the file's header.")
-
-(defvar tex-end-of-header nil
- "String used by \\[tex-region] to delimit the end of the file's header.")
-
-(defvar tex-shell-cd-command "cd"
- "Command to give to shell running TeX to change directory.
-The value of tex-directory will be appended to this, separated by a space.")
-
-(defvar tex-zap-file nil
- "Temporary file name used for text being sent as input to TeX.
-Should be a simple file name with no extension or directory specification.")
-
-(defvar tex-last-buffer-texed nil
- "Buffer which was last TeXed.")
-
-(defvar tex-print-file nil
- "File name that \\[tex-print] prints.
-Set by \\[tex-region], \\[tex-buffer], and \\[tex-file].")
-
-(defvar tex-mode-syntax-table nil
- "Syntax table used while in TeX mode.")
-
-(defun tex-define-common-keys (keymap)
- "Define the keys that we want defined both in TeX mode and in the tex-shell."
- (define-key keymap "\C-c\C-k" 'tex-kill-job)
- (define-key keymap "\C-c\C-l" 'tex-recenter-output-buffer)
- (define-key keymap "\C-c\C-q" 'tex-show-print-queue)
- (define-key keymap "\C-c\C-p" 'tex-print)
- (define-key keymap "\C-c\C-v" 'tex-view)
- )
-
-(defvar tex-mode-map nil "Keymap for TeX mode.")
-
-(if tex-mode-map
- nil
- (setq tex-mode-map (make-sparse-keymap))
- (tex-define-common-keys tex-mode-map)
- (define-key tex-mode-map "\"" 'tex-insert-quote)
- (define-key tex-mode-map "\n" 'tex-terminate-paragraph)
- (define-key tex-mode-map "\C-c}" 'up-list)
- (define-key tex-mode-map "\C-c{" 'tex-insert-braces)
- (define-key tex-mode-map "\C-c\C-r" 'tex-region)
- (define-key tex-mode-map "\C-c\C-b" 'tex-buffer)
- (define-key tex-mode-map "\C-c\C-f" 'tex-file)
- (define-key tex-mode-map "\C-c\C-i" 'tex-bibtex-file)
- (define-key tex-mode-map "\C-c\C-o" 'tex-latex-block)
- (define-key tex-mode-map "\C-c\C-e" 'tex-close-latex-block))
-
-(defvar tex-shell-map nil
- "Keymap for the tex-shell. A shell-mode-map with a few additions.")
-
-;(fset 'TeX-mode 'tex-mode) ;in loaddefs.
-
-;;; This would be a lot simpler if we just used a regexp search,
-;;; but then it would be too slow.
-(defun 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."
- (interactive)
- (let (mode slash comment)
- (save-excursion
- (goto-char (point-min))
- (while (and (setq slash (search-forward "\\" nil t))
- (setq comment (let ((search-end (point)))
- (save-excursion
- (beginning-of-line)
- (search-forward "%" search-end t))))))
- (if (and slash (not comment))
- (setq mode (if (looking-at "documentstyle")
- (if (looking-at "documentstyle{slides}")
- 'slitex-mode
- 'latex-mode)
- 'plain-tex-mode))))
- (if mode (funcall mode)
- (funcall tex-default-mode))))
-
-(fset 'plain-TeX-mode 'plain-tex-mode)
-(fset 'LaTeX-mode 'latex-mode)
-
-(defun plain-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-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."
- (interactive)
- (tex-common-initialization)
- (setq mode-name "TeX")
- (setq major-mode 'plain-tex-mode)
- (setq tex-command tex-run-command)
- (setq tex-start-of-header "%**start of header")
- (setq tex-end-of-header "%**end of header")
- (setq tex-trailer "\\bye\n")
- (run-hooks 'text-mode-hook 'tex-mode-hook 'plain-tex-mode-hook))
-
-(defun latex-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-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."
- (interactive)
- (tex-common-initialization)
- (setq mode-name "LaTeX")
- (setq major-mode 'latex-mode)
- (setq tex-command latex-run-command)
- (setq tex-start-of-header "\\documentstyle")
- (setq tex-end-of-header "\\begin{document}")
- (setq tex-trailer "\\end{document}\n")
- (run-hooks 'text-mode-hook 'tex-mode-hook 'latex-mode-hook))
-
-(defun slitex-mode ()
- "Major mode for editing files of input for SliTeX.
-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 SliTeX on the current region, plus the preamble
-copied from the top of the file (containing \\documentstyle, etc.),
-running SliTeX 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:
-slitex-run-command
- Command string used by \\[tex-region] or \\[tex-buffer].
-tex-directory
- Directory in which to create temporary files for SliTeX jobs
- run by \\[tex-region] or \\[tex-buffer].
-tex-dvi-print-command
- Command string used by \\[tex-print] 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 SliTex mode calls the value of text-mode-hook, then the value of
-tex-mode-hook, then the value of latex-mode-hook, and then the value of
-slitex-mode-hook. When the special subshell is initiated, the value of
-tex-shell-hook is called."
- (interactive)
- (tex-common-initialization)
- (setq mode-name "SliTeX")
- (setq major-mode 'slitex-mode)
- (setq tex-command slitex-run-command)
- (setq tex-start-of-header "\\documentstyle{slides}")
- (setq tex-end-of-header "\\begin{document}")
- (setq tex-trailer "\\end{document}\n")
- (run-hooks
- 'text-mode-hook 'tex-mode-hook 'latex-mode-hook 'slitex-mode-hook))
-
-(defun tex-common-initialization ()
- (kill-all-local-variables)
- (use-local-map tex-mode-map)
- (setq local-abbrev-table text-mode-abbrev-table)
- (if (null tex-mode-syntax-table)
- (let ((char 0))
- (setq tex-mode-syntax-table (make-syntax-table))
- (set-syntax-table tex-mode-syntax-table)
- (while (< char ? )
- (modify-syntax-entry char ".")
- (setq char (1+ char)))
- (modify-syntax-entry ?\C-@ "w")
- (modify-syntax-entry ?\t " ")
- (modify-syntax-entry ?\n ">")
- (modify-syntax-entry ?\f ">")
- (modify-syntax-entry ?$ "$$")
- (modify-syntax-entry ?% "<")
- (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 tex-mode-syntax-table))
- (make-local-variable 'paragraph-start)
- (setq paragraph-start "^[ \t]*$\\|^[\f\\\\%]")
- (make-local-variable 'paragraph-separate)
- (setq paragraph-separate paragraph-start)
- (make-local-variable 'comment-start)
- (setq comment-start "%")
- (make-local-variable 'comment-start-skip)
- (setq comment-start-skip "\\(\\(^\\|[^\\]\\)\\(\\\\\\\\\\)*\\)\\(%+ *\\)")
- (make-local-variable 'comment-indent-hook)
- (setq comment-indent-hook 'tex-comment-indent)
- (make-local-variable 'compare-windows-whitespace)
- (setq compare-windows-whitespace 'tex-categorize-whitespace)
- (make-local-variable 'tex-command)
- (make-local-variable 'tex-start-of-header)
- (make-local-variable 'tex-end-of-header)
- (make-local-variable 'tex-trailer))
-
-(defun tex-comment-indent ()
- (if (looking-at "%%%")
- (current-column)
- (skip-chars-backward " \t")
- (max (if (bolp) 0 (1+ (current-column)))
- comment-column)))
-
-(defun tex-categorize-whitespace (backward-limit)
- ;; compare-windows-whitespace is set to this.
- ;; This is basically a finite-state machine.
- ;; Returns a symbol telling how TeX would treat
- ;; the whitespace we are looking at: null, space, or par.
- (let ((category 'null)
- (not-finished t))
- (skip-chars-backward " \t\n\f" backward-limit)
- (while not-finished
- (cond ((looking-at "[ \t]+")
- (goto-char (match-end 0))
- (if (eql category 'null)
- (setq category 'space)))
- ((looking-at "\n")
- (cond ((eql category 'newline)
- (setq category 'par)
- (setq not-finished nil))
- (t
- (setq category 'newline) ;a strictly internal state
- (goto-char (match-end 0)))))
- ((looking-at "\f+")
- (setq category 'par)
- (setq not-finished nil))
- (t
- (setq not-finished nil))))
- (skip-chars-forward " \t\n\f")
- (if (eql category 'newline)
- 'space ;TeX doesn't distinguish
- category)))
-
-(defun tex-insert-quote (arg)
- "Insert the appropriate quote marks for TeX.
-Inserts the value of tex-open-quote (normally ``) or tex-close-quote
-(normally '') depending on the context. With prefix argument, always
-inserts \" characters."
- (interactive "P")
- (if arg
- (self-insert-command (prefix-numeric-value arg))
- (insert
- (cond ((or (bobp)
- (save-excursion
- (forward-char -1)
- (looking-at "\\s(\\|\\s \\|\\s>")))
- tex-open-quote)
- ((= (preceding-char) ?\\)
- ?\")
- (t
- tex-close-quote)))))
-
-(defun validate-tex-buffer ()
- "Check current buffer for paragraphs containing mismatched $'s.
-As each such paragraph is found, a mark is pushed at its beginning,
-and the location is displayed for a few seconds."
- (interactive)
- (let ((opoint (point)))
- (goto-char (point-max))
- ;; Does not use save-excursion
- ;; because we do not want to save the mark.
- (unwind-protect
- (while (and (not (input-pending-p)) (not (bobp)))
- (let ((end (point)))
- (search-backward "\n\n" nil 'move)
- (or (tex-validate-region (point) end)
- (progn
- (push-mark (point))
- (message "Mismatch found in pararaph starting here")
- (sit-for 4)))))
- (goto-char opoint))))
-
-(defun tex-validate-region (start end)
- "Check for mismatched braces or $'s in region.
-Returns t if no mismatches. Returns nil and moves point to suspect
-area if a mismatch is found."
- (interactive "r")
- (let ((failure-point nil) (max-possible-sexps (- end start)))
- (save-excursion
- (condition-case ()
- (save-restriction
- (narrow-to-region start end)
- (goto-char start)
- (while (< 0 (setq max-possible-sexps (1- max-possible-sexps)))
- (forward-sexp 1)))
- (error
- (setq failure-point (point)))))
- (if failure-point
- (progn
- (goto-char failure-point)
- nil)
- t)))
-
-(defun tex-terminate-paragraph (inhibit-validation)
- "Insert two newlines, breaking a paragraph for TeX.
-Check for mismatched braces/$'s in paragraph being terminated.
-A prefix arg inhibits the checking."
- (interactive "P")
- (or inhibit-validation
- (save-excursion
- (tex-validate-region
- (save-excursion
- (search-backward "\n\n" nil 'move)
- (point))
- (point)))
- (message "Paragraph being closed appears to contain a mismatch"))
- (insert "\n\n"))
-
-(defun tex-insert-braces ()
- "Make a pair of braces and be poised to type inside of them."
- (interactive)
- (insert ?\{)
- (save-excursion
- (insert ?})))
-
-;;; Like tex-insert-braces, but for LaTeX.
-(defun tex-latex-block (name)
- "Creates a matching pair of lines \\begin{NAME} and \\end{NAME} at point.
-Puts point on a blank line between them."
- (interactive "*sLaTeX block name: ")
- (let ((col (current-column)))
- (insert (format "\\begin{%s}\n" name))
- (indent-to col)
- (save-excursion
- (insert ?\n)
- (indent-to col)
- (insert-string (format "\\end{%s}" name))
- (if (eobp) (insert ?\n)))))
-
-(defun tex-last-unended-begin ()
- "Leave point at the beginning of the last \\begin{...} that is unended."
- (while (and (re-search-backward "\\(\\\\begin\\s *{\\)\\|\\(\\\\end\\s *{\\)")
- (looking-at "\\\\end{"))
- (tex-last-unended-begin)))
-
-(defun tex-close-latex-block ()
- "Creates an \\end{...} to match the last unclosed \\begin{...}."
- (interactive "*")
- (let ((new-line-needed (bolp))
- text indentation)
- (save-excursion
- (condition-case ERR
- (tex-last-unended-begin)
- (error (error "Couldn't find unended \\begin")))
- (setq indentation (current-column))
- (re-search-forward "\\\\begin\\(\\s *{[^}\n]*}\\)")
- (setq text (buffer-substring (match-beginning 1) (match-end 1))))
- (indent-to indentation)
- (insert "\\end" text)
- (if new-line-needed (insert ?\n))))
-
-;;; Invoking TeX in an inferior shell.
-
-;;; Why use a shell instead of running TeX directly? Because if TeX
-;;; gets stuck, the user can switch to the shell window and type at it.
-
-;;; The utility functions:
-
-(defun tex-start-shell ()
- (save-excursion
- (set-buffer (make-shell "tex-shell" nil nil "-v"))
- (setq tex-shell-map (copy-keymap shell-mode-map))
- (tex-define-common-keys tex-shell-map)
- (use-local-map tex-shell-map)
- (run-hooks 'tex-shell-hook)
- (if (zerop (buffer-size))
- (sleep-for 1))))
-
-(defun set-buffer-directory (buffer directory)
- "Set BUFFER's default directory to be DIRECTORY."
- (setq directory (file-name-as-directory (expand-file-name directory)))
- (if (not (file-directory-p directory))
- (error "%s is not a directory" directory)
- (save-excursion
- (set-buffer buffer)
- (setq default-directory directory))))
-
-;;; The commands:
-
-;;; It's a kludge that we have to create a special buffer just
-;;; to write out the tex-trailer. It would nice if there were a
-;;; function like write-region that would write literal strings.
-
-(defun tex-region (beg end)
- "Run TeX on the current region, via a temporary file.
-The file's name comes from the variable `tex-zap-file' and the
-variable `tex-directory' says where to put it.
-
-If the buffer has a header, the header is given to TeX before the
-region itself. The buffer's header is all lines between the strings
-defined by `tex-start-of-header' and `tex-end-of-header' inclusive.
-The header must start in the first 100 lines of the buffer.
-
-The value of `tex-trailer' is given to TeX as input after the region.
-
-The value of `tex-command' specifies the command to use to run TeX."
- (interactive "r")
- (if (tex-shell-running)
- (tex-kill-job)
- (tex-start-shell))
- (or tex-zap-file
- (setq tex-zap-file (tex-generate-zap-file-name)))
- (let ((tex-out-file (concat tex-zap-file ".tex"))
- (temp-buffer (get-buffer-create " TeX-Output-Buffer"))
- (file-dir (if (buffer-file-name)
- (file-name-directory (buffer-file-name))
- default-directory))
- (zap-directory
- (file-name-as-directory (expand-file-name tex-directory))))
- ;; Delete any junk files or memory files from this temp file,
- ;; since the contents were probably different last time anyway.
- ;; This may also delete the old temp file if any.
- (let ((list (file-name-all-completions (tex-append tex-out-file ".")
- zap-directory)))
- (while list
- (delete-file (expand-file-name (car list) zap-directory))
- (setq list (cdr list))))
- ;; Write the new temp file.
- (save-excursion
- (save-restriction
- (widen)
- (goto-char (point-min))
- (forward-line 100)
- (let ((search-end (point))
- (hbeg (point-min)) (hend (point-min))
- (default-directory zap-directory))
- (goto-char (point-min))
- ;; Initialize the temp file with either the header or nothing
- (if (search-forward tex-start-of-header search-end t)
- (progn
- (beginning-of-line)
- (setq hbeg (point)) ;mark beginning of header
- (if (search-forward tex-end-of-header nil t)
- (progn (forward-line 1)
- (setq hend (point))) ;mark end of header
- (setq hbeg (point-min))))) ;no header
- (write-region (min hbeg beg) hend tex-out-file nil nil)
- (write-region (max beg hend) end tex-out-file t nil))
- (let ((local-tex-trailer tex-trailer))
- (set-buffer temp-buffer)
- (erase-buffer)
- ;; make sure trailer isn't hidden by a comment
- (insert-string "\n")
- (if local-tex-trailer (insert-string local-tex-trailer))
- (set-buffer-directory temp-buffer zap-directory)
- (write-region (point-min) (point-max) tex-out-file t nil))))
- ;; Record in the shell buffer the file name to delete afterward.
- (save-excursion
- (set-buffer (get-buffer "*tex-shell*"))
- (make-local-variable 'tex-last-temp-file)
- (setq tex-last-temp-file tex-out-file))
- (set-process-filter "tex-shell" 'tex-filter)
- (set-buffer-directory "*tex-shell*" zap-directory)
- ;; Run TeX in source file's dir, in case TEXINPUTS uses current dir.
- (send-string "tex-shell" (concat tex-shell-cd-command " " file-dir "\n"))
- (send-string "tex-shell" (concat tex-command " \""
- zap-directory
- tex-out-file "\"\n")))
- (setq tex-last-buffer-texed (current-buffer))
- (setq tex-print-file
- (concat (file-name-as-directory (expand-file-name tex-directory))
- tex-zap-file))
- (tex-recenter-output-buffer 0))
-
-;; This filter is used in the TeX shell buffer
-;; while TeX is running for a tex-region command.
-(defun tex-filter (process string)
- (let ((old (current-buffer)))
- (set-buffer (process-buffer proc))
- (unwind-protect
- (progn (if (= (process-mark proc) (point-max))
- (insert string)
- (save-excursion
- (goto-char (process-mark proc))
- (insert string)))
- (set-marker (process-mark proc) (point))
- ;; Delete the temporary file
- ;; when TeX finishes.
- ;; And stop using this filter.
- (save-excursion
- (forward-line -1)
- (if (looking-at "^Output written on ")
- (progn
- (set-process-filter process nil)
- ;; Delete the temp file just processed
- ;; and any related junk files made by TeX.
- (let ((list (file-name-all-completions
- (tex-append tex-last-temp-file ".")
- zap-directory)))
- (while list
- (delete-file (expand-file-name
- (car list) zap-directory))
- (setq list (cdr list))))))))
- (or (eq old (current-buffer))
- (set-buffer old)))))
-
-(defun tex-buffer ()
- "Run TeX on current buffer. See \\[tex-region] for more information.
-Does not save the buffer, so it's useful for trying
-experimental versions. See \\[tex-file] for an alternative."
- (interactive)
- (tex-region (point-min) (point-max)))
-
-(defun tex-file ()
- "Prompt to save all buffers and run TeX (or LaTeX) on current buffer's file.
-This function is more useful than \\[tex-buffer] when you need the
-`.aux' file of LaTeX to have the correct name."
- (interactive)
- (let ((tex-out-file
- (if (buffer-file-name)
- (file-name-nondirectory (buffer-file-name))
- (error "Buffer does not seem to be associated with any file")))
- (file-dir (file-name-directory (buffer-file-name))))
- (save-some-buffers)
- (if (tex-shell-running)
- (tex-kill-job)
- (tex-start-shell))
- (set-buffer-directory "*tex-shell*" file-dir)
- (send-string "tex-shell" (concat tex-shell-cd-command " " file-dir "\n"))
- (send-string "tex-shell"
- (concat tex-command " \"" tex-out-file "\"\n")))
- (setq tex-last-buffer-texed (current-buffer))
- (setq tex-print-file (buffer-file-name))
- (tex-recenter-output-buffer 0))
-
-(defun tex-generate-zap-file-name ()
- "Generate a unique name suitable for use as a file name."
- ;; Include the shell process number and host name
- ;; in case there are multiple shells (for same or different user).
- (format "#tz%d%s"
- (process-id (get-buffer-process "*tex-shell*"))
- (tex-strip-dots (system-name))))
-
-(defun tex-strip-dots (s)
- (setq s (copy-sequence s))
- (while (string-match "\\." s)
- (aset s (match-beginning 0) ?-))
- s)
-
-;; This will perhaps be useful for modifying TEXINPUTS.
-;; Expand each file name, separated by colons, in the string S.
-(defun tex-expand-files (s)
- (let (elts (start 0))
- (while (string-match ":" s start)
- (setq elts (cons (substring s start (match-beginning 0)) elts))
- (setq start (match-end 0)))
- (or (= start 0)
- (setq elts (cons (substring s start) elts)))
- (mapconcat 'expand-file-name (nreverse elts) ":")))
-
-(defun tex-shell-running ()
- (and (get-process "tex-shell")
- (eq (process-status (get-process "tex-shell")) 'run)))
-
-(defun tex-kill-job ()
- "Kill the currently running TeX job."
- (interactive)
- (if (get-process "tex-shell")
- (quit-process "tex-shell" t)))
-
-(defun tex-recenter-output-buffer (linenum)
- "Redisplay buffer of TeX job output so that most recent output can be seen.
-The last line of the buffer is displayed on
-line LINE of the window, or centered if LINE is nil."
- (interactive "P")
- (let ((tex-shell (get-buffer "*tex-shell*"))
- (old-buffer (current-buffer)))
- (if (null tex-shell)
- (message "No TeX output buffer")
- (pop-to-buffer tex-shell)
- (bury-buffer tex-shell)
- (goto-char (point-max))
- (recenter (if linenum
- (prefix-numeric-value linenum)
- (/ (window-height) 2)))
- (pop-to-buffer old-buffer)
- )))
-
-(defun tex-print ()
- "Print the .dvi file made by \\[tex-region], \\[tex-buffer] or \\[tex-file].
-Runs the shell command defined by tex-dvi-print-command."
- (interactive)
- (let ((print-file-name-dvi (tex-append tex-print-file ".dvi"))
- test-name)
- (if (and (not (equal (current-buffer) tex-last-buffer-texed))
- (file-newer-than-file-p
- (setq test-name (tex-append (buffer-file-name) ".dvi"))
- (tex-append tex-print-file ".dvi")))
- (setq print-file-name-dvi test-name))
- (if (file-exists-p print-file-name-dvi)
- (shell-command
- (concat tex-dvi-print-command " \"" print-file-name-dvi "&\"\n"))
- (error "No appropriate `.dvi' file could be found"))))
-
-(defun tex-view ()
- "Preview the last `.dvi' file made by running TeX under Emacs.
-This means, made using \\[tex-region], \\[tex-buffer] or \\[tex-file].
-The variable `tex-dvi-view-command' specifies the shell command for preview."
- (interactive)
- (let ((tex-dvi-print-command tex-dvi-view-command))
- (tex-print)))
-
-(defun tex-append (file-name suffix)
- "Append to FILENAME the suffix SUFFIX, using same algorithm TeX uses.
-Scans for the first (not last) period.
-No period is retained immediately before SUFFIX,
-so normally SUFFIX starts with one."
- (if (stringp file-name)
- (let ((file (file-name-nondirectory file-name)))
- (concat (file-name-directory file-name)
- (substring file 0
- (string-match "\\." file))
- suffix))
- " "))
-
-(defun tex-show-print-queue ()
- "Show the print queue that \\[tex-print] put your job on.
-Runs the shell command defined by tex-show-queue-command."
- (interactive)
- (if (tex-shell-running)
- (tex-kill-job)
- (tex-start-shell))
- (send-string "tex-shell" (concat tex-show-queue-command "\n"))
- (tex-recenter-output-buffer nil))
-
-(defun tex-bibtex-file ()
- "Run BibTeX on the current buffer's file."
- (interactive)
- (if (tex-shell-running)
- (tex-kill-job)
- (tex-start-shell))
- (let ((tex-out-file
- (tex-append (file-name-nondirectory (buffer-file-name)) ""))
- (file-dir (file-name-directory (buffer-file-name))))
- (set-buffer-directory "*tex-shell*" file-dir)
- (send-string "tex-shell" (concat tex-shell-cd-command " " file-dir "\n"))
- (send-string "tex-shell"
- (concat tex-bibtex-command " \"" tex-out-file "\"\n")))
- (tex-recenter-output-buffer 0))
-
diff --git a/lisp/textmodes/texinfo.el b/lisp/textmodes/texinfo.el
deleted file mode 100644
index ebe0769a71c..00000000000
--- a/lisp/textmodes/texinfo.el
+++ /dev/null
@@ -1,414 +0,0 @@
-;;;; texinfo.el
-;;;; Major mode for editing Texinfo files.
-
-;;;; Version 2.00 14 Dec 1990
-
-;; Copyright (C) 1985, 1988, 1989, 1990 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-(require 'texnfo-upd)
-(require 'tex-mode)
-(provide 'texinfo)
-
-(defvar texinfo-mode-syntax-table nil)
-
-(if texinfo-mode-syntax-table
- nil
- (setq texinfo-mode-syntax-table (make-syntax-table))
- (modify-syntax-entry ?\" " " texinfo-mode-syntax-table)
- (modify-syntax-entry ?\\ " " texinfo-mode-syntax-table)
- (modify-syntax-entry ?@ "\\" texinfo-mode-syntax-table)
- (modify-syntax-entry ?\^q "\\" texinfo-mode-syntax-table)
- (modify-syntax-entry ?\[ "(]" texinfo-mode-syntax-table)
- (modify-syntax-entry ?\] ")[" texinfo-mode-syntax-table)
- (modify-syntax-entry ?{ "(}" texinfo-mode-syntax-table)
- (modify-syntax-entry ?} "){" texinfo-mode-syntax-table)
- (modify-syntax-entry ?\' "w" texinfo-mode-syntax-table))
-
-(defvar texinfo-mode-map nil)
-
-;; Mode documentation displays commands in reverse order
-;; from how they are listed in the texinfo-mode-map.
-(if texinfo-mode-map
- nil
- (setq texinfo-mode-map (make-sparse-keymap))
-
- (define-key texinfo-mode-map "\C-c\C-t\C-k" 'tex-kill-job)
- (define-key texinfo-mode-map "\C-c\C-t\C-l" 'tex-recenter-output-buffer)
- (define-key texinfo-mode-map "\C-c\C-t\C-q" 'tex-show-print-queue)
- (define-key texinfo-mode-map "\C-c\C-t\C-p" 'texinfo-tex-print)
- (define-key texinfo-mode-map "\C-c\C-t\C-i" 'texinfo-texindex)
- (define-key texinfo-mode-map "\C-c\C-t\C-t" 'texinfo-tex-buffer)
- (define-key texinfo-mode-map "\C-c\C-t\C-r" 'texinfo-tex-region)
-
- (define-key texinfo-mode-map "\C-c\C-i\C-r" 'texinfo-format-region)
- (define-key texinfo-mode-map "\C-c\C-i\C-b" 'texinfo-format-buffer)
-
- (define-key texinfo-mode-map "\C-c\C-u\C-m" 'texinfo-make-menu)
- (define-key texinfo-mode-map "\C-c\C-u\C-n" 'texinfo-update-node)
- (define-key texinfo-mode-map "\C-c\C-u\C-e" 'texinfo-every-node-update)
- (define-key texinfo-mode-map "\C-c\C-u\C-a" 'texinfo-all-menus-update)
-
- (define-key texinfo-mode-map "\C-c\C-s" 'texinfo-show-structure)
-
- (define-key texinfo-mode-map "\"" 'tex-insert-quote)
- (define-key texinfo-mode-map "\e}" 'up-list)
- (define-key texinfo-mode-map "\e{" 'texinfo-insert-braces)
-
- (define-key texinfo-mode-map "\C-c\C-cv" 'texinfo-insert-@var)
- (define-key texinfo-mode-map "\C-c\C-cs" 'texinfo-insert-@samp)
- (define-key texinfo-mode-map "\C-c\C-co" 'texinfo-insert-@noindent)
- (define-key texinfo-mode-map "\C-c\C-cn" 'texinfo-insert-@node)
- (define-key texinfo-mode-map "\C-c\C-ck" 'texinfo-insert-@kbd)
- (define-key texinfo-mode-map "\C-c\C-ci" 'texinfo-insert-@item)
- (define-key texinfo-mode-map "\C-c\C-cx" 'texinfo-insert-@example)
- (define-key texinfo-mode-map "\C-c\C-ce" 'texinfo-insert-@end-example)
- (define-key texinfo-mode-map "\C-c\C-cd" 'texinfo-insert-@dfn)
- (define-key texinfo-mode-map "\C-c\C-cc" 'texinfo-insert-@code))
-
-(defun texinfo-insert-@var ()
- "Insert the string @var in a texinfo buffer."
- (interactive)
- (insert "@var{}")
- (backward-char))
-
-(defun texinfo-insert-@samp ()
- "Insert the string @samp in a texinfo buffer."
- (interactive)
- (insert "@samp{}")
- (backward-char))
-
-(defun texinfo-insert-@noindent ()
- "Insert the string @noindent in a texinfo buffer."
- (interactive)
- (insert "@noindent\n"))
-
-(defun texinfo-insert-@node ()
- "Insert the string @node in a texinfo buffer,
-along with a comment indicating the arguments to @node."
- (interactive)
- (insert "@node \n@comment node-name, next, previous, up")
- (forward-line -1)
- (forward-char 6))
-
-(defun texinfo-insert-@kbd ()
- "Insert the string @kbd in a texinfo buffer."
- (interactive)
- (insert "@kbd{}")
- (backward-char))
-
-(defun texinfo-insert-@item ()
- "Insert the string @item in a texinfo buffer."
- (interactive)
- (insert "@item")
- (newline))
-
-(defun texinfo-insert-@example ()
- "Insert the string @example in a texinfo buffer."
- (interactive)
- (insert "@example\n"))
-
-(defun texinfo-insert-@end-example ()
- "Insert the string @end example in a texinfo buffer."
- (interactive)
- (insert "@end example\n"))
-
-(defun texinfo-insert-@dfn ()
- "Insert the string @dfn in a texinfo buffer."
- (interactive)
- (insert "@dfn{}")
- (backward-char))
-
-(defun texinfo-insert-@code ()
- "Insert the string @code in a texinfo buffer."
- (interactive)
- (insert "@code{}")
- (backward-char))
-
-(defun texinfo-insert-braces ()
- "Make a pair of braces and be poised to type inside of them.
-Use \\[up-list] to move forward out of the braces."
- (interactive)
- (insert "{}")
- (backward-char))
-
-(defun texinfo-mode ()
- "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 by \\[texinfo-format-buffer] or
-`makeinfo'. 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 \\[texinfo-format-region]. This command runs Info on the current region
-of the Texinfo file and formats it properly.
-
- 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."
- (interactive)
- (text-mode)
- (setq mode-name "texinfo")
- (setq major-mode 'texinfo-mode)
- (use-local-map texinfo-mode-map)
- (set-syntax-table texinfo-mode-syntax-table)
- (make-local-variable 'require-final-newline)
- (setq require-final-newline t)
- (make-local-variable 'paragraph-separate)
- (setq paragraph-separate (concat "^\b\\|^@[a-zA-Z]*[ \n]\\|" paragraph-separate))
- (make-local-variable 'paragraph-start)
- (setq paragraph-start (concat "^\b\\|^@[a-zA-Z]*[ \n]\\|" paragraph-start))
- (make-local-variable 'fill-column)
- (setq fill-column 72)
- (make-local-variable 'comment-start)
- (setq comment-start "@c ")
- (make-local-variable 'comment-start-skip)
- (setq comment-start-skip "@c +")
- (make-local-variable 'words-include-escapes)
- (setq words-include-escapes t)
- (make-local-variable 'tex-start-of-header)
- (setq tex-start-of-header "%**start of header")
- (make-local-variable 'tex-end-of-header)
- (setq tex-end-of-header "%**end of header")
- (make-local-variable 'tex-trailer)
- (setq tex-trailer "@bye\n")
- (run-hooks 'text-mode-hook 'texinfo-mode-hook))
-
-
-;;; Texinfo file structure
-
-; The following is defined in `texnfo-upd.el'
-; (defvar texinfo-section-types-regexp
-; "^@\\(chapter \\|sect\\|sub\\|unnum\\|major\\|heading \\|appendix\\)"
-; "Regexp matching chapter, section, other headings (but not the top node).")
-
-(defun texinfo-show-structure (&optional nodes-too)
- "Show the structure of a Texinfo file.
-List the lines in the file that begin with the @-sign commands for
-@chapter, @section, and the like.
-
-With optional argument (prefix if interactive), list both the lines
-with @-sign commands for @chapter, @section, and the like, and list
-@node lines.
-
-Lines with structuring commands beginning in them 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."
-
- (interactive "P")
- (save-excursion
- (goto-char (point-min))
- (if nodes-too
- (occur (concat "\\(^@node\\)\\|" texinfo-section-types-regexp))
- (occur texinfo-section-types-regexp)))
- (pop-to-buffer "*Occur*")
- (goto-char (point-min))
- (flush-lines "-----"))
-
-
-;;; texinfo mode tex and hardcopy printing commands.
-
-;; These commands are for running tex on a region of a texinfo file in
-;; GNU Emacs, or on the whole buffer, and for printing the resulting
-;; .dvi file. The three commands are:
-
-; texinfo-tex-region to run tex on the current region.
-; texinfo-tex-buffer to run tex on the current buffer.
-; texinfo-tex-print to print the .dvi file made by tex
-
-;;; Other useful functions
-
-; These functions are provided by `tex-mode.el' but are bound to keys
-; in texinfo mode.
-
-; tex-kill-job to kill the currently running tex job
-; tex-recenter-output-buffer to redisplay tex job output buffer
-; tex-show-print-queue to show the print queue
-
-; Various variables are provided by `tex-mode.el'
-
-; tex mode variable Default Value
-
-; tex-dvi-print-command "lpr -d"
-; tex-directory "/tmp/"
-; tex-show-queue-command "lpq"
-; tex-shell-cd-command "cd"
-; tex-zap-file nil (created as needed)
-
-
-;;; The tex and print function definitions:
-
-(defvar texinfo-tex-command "tex"
- "*Command used by texinfo-tex-region to run tex on a region.")
-
-(defvar texinfo-texindex-command "texindex"
- "*Command used by texinfo-texindex to sort unsorted index files.")
-
-(defun texinfo-tex-region (beg end)
- "Run tex on the current region. A temporary file (tex-zap-file) is
-written in directory tex-directory, and tex is run in that directory.
-The first line of the file is copied to the temporary file; and
-if the buffer has a header, it is written to the temporary file before
-the region itself. The buffer's header is all lines between the
-strings defined by tex-start-of-header and tex-end-of-header
-inclusive. The header must start in the first 100 lines. The value
-of tex-trailer is appended to the temporary file after the region."
- (interactive "r")
- (if (get-buffer "*tex-shell*")
- (tex-kill-job)
- (tex-start-shell))
- (or tex-zap-file (setq tex-zap-file (make-temp-name "#tz")))
- (let ((tex-out-file (concat tex-zap-file ".tex"))
- (temp-buffer (get-buffer-create " tex-Output-Buffer"))
- (zap-directory
- (file-name-as-directory (expand-file-name tex-directory))))
- (save-excursion
- (save-restriction
- (widen)
- (goto-char (point-min))
- (forward-line 100)
- (let ((search-end (point))
- (hbeg (point-min)) (hend (point-min))
- (default-directory zap-directory))
- (goto-char (point-min))
-
- ;; Copy first line, the `\input texinfo' line, to temp file
- (write-region (point)
- (save-excursion (end-of-line) (point))
- tex-out-file nil nil)
-
- ;; Don't copy first line twice if region includes it.
- (forward-line 1)
- (if (< beg (point)) (setq beg (point)))
-
- ;; Initialize the temp file with either the header or nothing
- (if (search-forward tex-start-of-header search-end t)
- (progn
- (beginning-of-line)
- (setq hbeg (point)) ; Mark beginning of header.
- (if (search-forward tex-end-of-header nil t)
- (progn (beginning-of-line)
- (setq hend (point))) ; Mark end of header.
- (setq hbeg (point-min))))) ; Else no header.
-
- ;; Copy header to temp file.
- (write-region (min hbeg beg) hend tex-out-file t nil)
-
- ;; Copy region to temp file.
- (write-region (max beg hend) end tex-out-file t nil))
-
- ;; This is a kludge to insert the tex-trailer into the tex-out-file.
- ;; We have to create a special buffer in which to insert
- ;; the tex-trailer first because there is no function with
- ;; which to append a literal string directly to a file.
- (let ((local-tex-trailer tex-trailer))
- (set-buffer temp-buffer)
- (erase-buffer)
- ;; make sure trailer isn't hidden by a comment
- (insert-string "\n")
- (if local-tex-trailer (insert-string local-tex-trailer))
- (set-buffer-directory temp-buffer zap-directory)
- (write-region (point-min) (point-max) tex-out-file t nil))))
-
- (set-buffer-directory "*tex-shell*" zap-directory)
- (send-string "tex-shell" (concat tex-shell-cd-command " "
- zap-directory "\n"))
- (send-string "tex-shell" (concat texinfo-tex-command " "
- tex-out-file "\n")))
- (tex-recenter-output-buffer 0))
-
-(defun texinfo-tex-buffer ()
- "Run tex on current buffer.
-See \\[texinfo-tex-region] for more information."
- (interactive)
- (texinfo-tex-region (point-min) (point-max)))
-
-(defun texinfo-texindex ()
- "Run texindex on unsorted index files.
-The index files are made by \\[texinfo-tex-region] or \\[texinfo-tex-buffer].
-Runs the shell command defined by texinfo-texindex-command."
- (interactive)
- (send-string "tex-shell"
- (concat texinfo-texindex-command
- " " tex-zap-file ".??" "\n"))
- (tex-recenter-output-buffer nil))
-
-(defun texinfo-tex-print ()
- "Print .dvi file made by \\[texinfo-tex-region] or \\[texinfo-tex-buffer].
-Runs the shell command defined by tex-dvi-print-command."
- (interactive)
- (send-string "tex-shell"
- (concat tex-dvi-print-command
- " " tex-zap-file ".dvi" "\n"))
- (tex-recenter-output-buffer nil))
-
diff --git a/lisp/textmodes/texnfo-upd.el b/lisp/textmodes/texnfo-upd.el
deleted file mode 100644
index c236d791846..00000000000
--- a/lisp/textmodes/texnfo-upd.el
+++ /dev/null
@@ -1,1726 +0,0 @@
-;;;; texnfo-upd.el
-;;;; A utility for updating nodes and menus in Texinfo files.
-
-;;;; Version 2.00 14 Dec 1990
-
-;;;; Copyright 1989, 1990 Free Software Foundation
-
-;; 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-(provide 'texnfo-upd)
-
-
-;;;; Summary
-
-; (Much of the following commentary ought eventually be incorporated
-; into the Texinfo Manual.)
-
-; The node and menu updating functions automatically
-
-; * insert missing `@node' lines,
-; * insert the `Next', `Previous' and `Up' pointers of a node,
-; * insert or update the menu for a section,
-; * create a master menu for a Texinfo source file.
-
-; Passed an argument, the `texinfo-update-node' and
-; `texinfo-make-menu' functions do their jobs in the region.
-
-; These functions replace doing these jobs by hand.
-; You may find them helpful.
-
-; In brief, the functions for creating or updating nodes and menus, are:
-;
-; texinfo-update-node (&optional region-p)
-; texinfo-every-node-update ()
-; texinfo-sequential-node-update (&optional region-p)
-;
-; texinfo-make-menu (&optional region-p)
-; texinfo-all-menus-update ()
-; texinfo-master-menu ()
-;
-; texinfo-insert-node-lines (&optional title-p)
-;
-; texinfo-indent-menu-description (column &optional region-p)
-
-; The `texinfo-column-for-description' variable specifies the column to
-; which menu descriptions are indented.
-
-; Texinfo file structure
-; ----------------------
-
-; To use the updating commands, you must structure your Texinfo file
-; hierarchically. Each `@node' line, with the exception of the top
-; node, must be accompanied by some kind of section line, such as an
-; `@chapter' or `@section' line. Each node-line/section-line
-; combination must look like this:
-
-; @node Lists and Tables, Cross References, Structuring, Top
-; @comment node-name, next, previous, up
-; @chapter Making Lists and Tables
-
-; or like this (without the `@comment' line):
-
-; @node Lists and Tables, Cross References, Structuring, Top
-; @chapter Making Lists and Tables
-
-; If the file has a `top' node, it must be called `top' or `Top' and
-; be the first node in the file.
-
-
-;;;; The updating functions in detail
-; --------------------------------
-
-; The `texinfo-update-node' function without an argument inserts
-; the correct next, previous and up pointers for the node in which
-; point is located (i.e., for the node preceding point).
-
-; With an argument, the `texinfo-update-node' function inserts the
-; correct next, previous and up pointers for the nodes inside the
-; region.
-
-; It does not matter whether the `@node' line has pre-existing
-; `Next', `Previous', or `Up' pointers in it. They are removed.
-
-; The `texinfo-every-node-update' function runs `texinfo-update-node'
-; on the whole buffer.
-
-; The `texinfo-update-node' function inserts the immediately following
-; and preceding node into the `Next' or `Previous' pointers regardless
-; of their hierarchical level. This is only useful for certain kinds
-; of text, like a novel, which you go through sequentially.
-
-; The `texinfo-make-menu' function without an argument creates or
-; updates a menu for the section encompassing the node that follows
-; point. With an argument, it makes or updates menus for the nodes
-; within or part of the marked region.
-
-; Whenever an existing menu is updated, the descriptions from
-; that menu are incorporated into the new menu. This is done by copying
-; descriptions from the existing menu to the entries in the new menu
-; that have the same node names. If the node names are different, the
-; descriptions are not copied to the new menu.
-
-; Menu entries that refer to other Info files are removed since they
-; are not a node within current buffer. This is a deficiency.
-
-; The `texinfo-all-menus-update' function runs `texinfo-make-menu'
-; on the whole buffer.
-
-; The `texinfo-master-menu' function creates an extended menu located
-; after the top node. (The file must have a top node.) The function
-; first updates all the regular menus in the buffer (incorporating the
-; descriptions from pre-existing menus), and then constructs a master
-; menu that includes every entry from every other menu. (However, the
-; function cannot update an already existing master menu; if one
-; exists, it must be removed before calling the function.)
-
-; The `texinfo-indent-menu-description' function indents every
-; description in the menu following point, to the specified column.
-; Non-nil argument (prefix, if interactive) means indent every
-; description in every menu in the region. This function does not
-; indent second and subsequent lines of a multi-line description.
-
-; The `texinfo-insert-node-lines' function inserts `@node' before the
-; `@chapter', `@section', and such like lines of a region in a Texinfo
-; file where the `@node' lines are missing.
-;
-; With a non-nil argument (prefix, if interactive), the function not
-; only inserts `@node' lines but also inserts the chapter or section
-; titles as the names of the corresponding nodes; and inserts titles
-; as node names in pre-existing `@node' lines that lack names.
-;
-; Since node names should be more concise than section or chapter
-; titles, node names so inserted will need to be edited manually.
-
-
-;;;; Menu Making Functions
-
-(defun texinfo-make-menu (&optional region-p)
- "Without any prefix argument, make or update a menu.
-Make the menu for the section enclosing the node found following point.
-
-Non-nil argument (prefix, if interactive) means make or update menus
-for nodes within or part of the marked region.
-
-Whenever a menu exists, and is being updated, the descriptions that
-are associated with node names in the pre-existing menu are
-incorporated into the new menu. Otherwise, the nodes' section titles
-are inserted as descriptions."
-
- (interactive "P")
- (if (not region-p)
- (let ((level (texinfo-hierarchic-level)))
- (texinfo-make-one-menu level)
- (message "Done...updated the menu. You may save the buffer."))
- ;; else
- (message "Making or updating menus... ")
- (let ((beginning (region-beginning))
- (region-end (region-end))
- (level (progn ; find section type following point
- (goto-char (region-beginning))
- (texinfo-hierarchic-level))))
- (if (= region-end beginning)
- (error "Please mark a region!"))
- (save-excursion
- (save-restriction
- (widen)
-
- (while (texinfo-find-lower-level-node level region-end)
- (setq level (texinfo-hierarchic-level)) ; new, lower level
- (texinfo-make-one-menu level))
-
- (while (and (< (point) region-end)
- (texinfo-find-higher-level-node level region-end))
- (setq level (texinfo-hierarchic-level))
- (while (texinfo-find-lower-level-node level region-end)
- (setq level (texinfo-hierarchic-level)) ; new, lower level
- (texinfo-make-one-menu level))))))
- (message "Done...updated menus. You may save the buffer.")))
-
-(defun texinfo-make-one-menu (level)
- "Make a menu of all the appropriate nodes in this section.
-`Appropriate nodes' are those associated with sections that are
-at the level specified by LEVEL. Point is left at the end of menu."
- (let*
- ((case-fold-search t)
- (beginning
- (save-excursion
- (goto-char (texinfo-update-menu-region-beginning level))
- (end-of-line)
- (point)))
- (end (texinfo-update-menu-region-end level))
- (first (texinfo-menu-first-node beginning end))
- (node-name (progn
- (goto-char beginning)
- (texinfo-copy-node-name)))
- (new-menu-list (texinfo-make-menu-list beginning end level)))
- (if (texinfo-old-menu-p beginning first)
- (progn
- (texinfo-incorporate-descriptions new-menu-list)
- (texinfo-delete-old-menu beginning first)))
- (texinfo-insert-menu new-menu-list node-name)))
-
-(defun texinfo-all-menus-update (&optional update-all-nodes-p)
- "Update every regular menu in a Texinfo file.
-You must remove the detailed part of a pre-existing master menu before
-running this command, lest it be partly duplicated.
-
-If called with a non-nil argument, this function first updates all the
-nodes in the buffer before updating the menus."
- (interactive "P")
- (save-excursion
- (mark-whole-buffer)
- (message "Checking for a master menu... ")
- (save-excursion
- (if (re-search-forward texinfo-master-menu-header nil t)
- (error
- "Please remove existing master menu, lest it be partly duplicated!")))
-
- (if update-all-nodes-p
- (progn
- (message "First updating all nodes... ")
- (sleep-for 2)
- (mark-whole-buffer)
- (texinfo-update-node t)))
-
- (message "Updating all menus... ")
- (sleep-for 2)
- (texinfo-make-menu t)
- (message "Done...updated all the menus. You may save the buffer.")))
-
-(defun texinfo-find-lower-level-node (level region-end)
- "Search forward from point for node at any level lower than LEVEL.
-Search is limited to the end of the marked region, REGION-END,
-and to the end of the menu region for the level.
-
-Return t if the node is found, else nil. Leave point at the beginning
-of the node if one is found; else do not move point."
-
- (if (and (< (point) region-end)
- (re-search-forward
- (concat
- "\\(^@node\\).*\n" ; match node line
- "\\(\\(\\(^@c\\).*\n\\)" ; match comment line, if any
- "\\|" ; or
- "\\(^@ifinfo[ ]*\n\\)\\)?" ; ifinfo line, if any
- (eval (cdr (assoc level texinfo-update-menu-lower-regexps))))
- ;; the next higher level node marks the end of this
- ;; section, and no lower level node will be found beyond
- ;; this position even if region-end is farther off
- (texinfo-update-menu-region-end level)
- t))
- (goto-char (match-beginning 1))))
-
-(defun texinfo-find-higher-level-node (level region-end)
- "Search forward from point for node at any higher level than argument LEVEL.
-Search is limited to the end of the marked region, REGION-END.
-
-Return t if the node is found, else nil. Leave point at the beginning
-of the node if one is found; else do not move point."
-
- (if (and (< (point) region-end)
- (re-search-forward
- (concat
- "\\(^@node\\).*\n" ; match node line
- "\\(\\(\\(^@c\\).*\n\\)" ; match comment line, if any
- "\\|" ; or
- "\\(^@ifinfo[ ]*\n\\)\\)?" ; ifinfo line, if any
- (eval ; (won't ever find a `top' node)
- (cdr (assoc level texinfo-update-menu-higher-regexps))))
- nil
- t))
- (goto-char (match-beginning 1))))
-
-
-;;;; Making the list of new menu entries
-
-(defun texinfo-make-menu-list (beginning end level)
- "Make a list of node names and their descriptions.
-Point is left at the end of the menu region, but the menu is not inserted.
-
-First argument is position from which to start making menu list;
-second argument is end of region in which to try to locate entries;
-third argument is the level of the nodes that are the entries.
-
-Node names and descriptions are dotted pairs of strings. Each pair is
-an element of the list. If the description does not exist, the
-element consists only of the node name."
- (goto-char beginning)
- (let (new-menu-list)
- (while (texinfo-menu-locate-entry-p level end)
- (setq new-menu-list
- (cons (cons
- (texinfo-copy-node-name)
- (texinfo-copy-section-title))
- new-menu-list)))
- (reverse new-menu-list)))
-
-(defun texinfo-menu-locate-entry-p (level search-end)
- "Find a node that will be part of menu for this section.
-First argument is a string such as \"section\" specifying the general
-hierarchical level of the menu; second argument is a postion
-specifying the end of the search.
-
-The function returns t if the node is found, else nil. It searches
-forward from point, and leaves point at the beginning of the node.
-
-The function finds entries of the same type. Thus `subsections' and
-`unnumberedsubsecs' will appear in the same menu."
- (if (re-search-forward
- (concat
- "\\(^@node\\).*\n" ; match node line
- "\\(\\(\\(^@c\\).*\n\\)" ; match comment line, if any
- "\\|" ; or
- "\\(^@ifinfo[ ]*\n\\)\\)?" ; ifinfo line, if any
- (eval
- (cdr (assoc level texinfo-update-menu-same-level-regexps))))
- search-end
- t)
- (goto-char (match-beginning 1))))
-
-(defun texinfo-copy-node-name ()
- "Return the node name as a string.
-
-Start with point at the beginning of the node line; copy the text
-after the node command up to the first comma on the line, if any, and
-return the text as a string. Leaves point at the beginning of the
-line. If there is no node name, returns an empty string."
-
- (save-excursion
- (buffer-substring
- (progn (forward-word 1) ; skip over node command
- (skip-chars-forward " \t") ; and over spaces
- (point))
- (if (search-forward
- ","
- (save-excursion (end-of-line) (point)) t) ; bound search
- (1- (point))
- (end-of-line) (point)))))
-
-(defun texinfo-copy-section-title ()
- "Return the title of the section as a string.
-The title is used as a description line in the menu when one does not
-already exist.
-
-Move point to the beginning of the appropriate section line by going
-to the start of the text matched by last regexp searched for, which
-must have been done by `texinfo-menu-locate-entry-p'."
-
- ;; could use the same re-search as in `texinfo-menu-locate-entry-p'
- ;; instead of using `match-beginning'; such a variation would be
- ;; more general, but would waste information already collected
-
- (goto-char (match-beginning 7)) ; match section name
-
- (buffer-substring
- (progn (forward-word 1) ; skip over section type
- (skip-chars-forward " \t") ; and over spaces
- (point))
- (progn (end-of-line) (point))))
-
-
-;;;; Handling the old menu
-
-(defun texinfo-old-menu-p (beginning first)
- "Move point to the beginning of the menu for this section, if any.
-Otherwise move point to the end of the first node of this section.
-Return t if a menu is found, nil otherwise.
-
-First argument is the position of the beginning of the section in which
-the menu will be located; second argument is the position of the first
-node within the section.
-
-If no menu is found, the function inserts two newlines just before the
-end of the section, and leaves point there where a menu ought to be."
- (goto-char beginning)
- (if (not (re-search-forward "^@menu" first 'goto-end))
- (progn (insert "\n\n") (forward-line -2) nil)
- t))
-
-(defun texinfo-incorporate-descriptions (new-menu-list)
- "Copy the old menu line descriptions that exist to the new menu.
-
-Point must be at beginning of old menu.
-
-If the node-name of the new menu entry cannot be found in the old
-menu, use the new section title for the description, but if the
-node-name of the new menu is found in the old menu, replace the
-section title with the old description, whatever it may be.
-
-For this function, the new menu is a list made up of lists of dotted
-pairs in which the first element of the pair is the node name and the
-second element the description. The new menu is changed destructively.
-The old menu is the menu as it appears in the texinfo file."
-
- (let ((new-menu-list-pointer new-menu-list)
- (end-of-menu (texinfo-menu-end)))
- (while new-menu-list
- (save-excursion ; keep point at beginning of menu
- (if (search-forward
- (concat "\* " ; so only menu entries are found
- (car (car new-menu-list))
- ":") ; so only complete entries are found
- end-of-menu
- t)
- (setcdr (car new-menu-list)
- (texinfo-menu-copy-old-description end-of-menu))))
- (setq new-menu-list (cdr new-menu-list)))
- (setq new-menu-list new-menu-list-pointer)))
-
-(defun texinfo-menu-copy-old-description (end-of-menu)
- "Return description field of old menu line as string.
-Point must be located just after the node name. Point left before description.
-Single argument, END-OF-MENU, is position limiting search."
- (skip-chars-forward "[:.,\t\n ]+")
- ;; don't copy a carriage return at line beginning with asterisk!
- ;; do copy a description that begins with an `@'!
- (if (and (looking-at "\\(\\w+\\|@\\)")
- (not (looking-at "\\(^\\* \\|^@end menu\\)")))
- (buffer-substring
- (point)
- (save-excursion
- (re-search-forward "\\(^\\* \\|^@end menu\\)" end-of-menu t)
- (forward-line -1)
- (end-of-line) ; go to end of last description line
- (point)))
- ""))
-
-(defun texinfo-menu-end ()
- "Return position of end of menu. Does not change location of point.
-Signal an error if not end of menu."
- (save-excursion
- (if (re-search-forward "^@end menu" nil t)
- (point)
- (error "Menu does not have an end."))))
-
-(defun texinfo-delete-old-menu (beginning first)
- "Delete the old menu. Point must be in or after menu.
-First argument is position of the beginning of the section in which
-the menu will be located; second argument is the position of the first
-node within the section."
- ;; No third arg to search, so error if search fails.
- (re-search-backward "^@menu" beginning)
- (delete-region (point)
- (save-excursion
- (re-search-forward "^@end menu" first)
- (point))))
-
-
-;;;; Inserting new menu
-
-;; try 32, but perhaps 24 is better
-(defvar texinfo-column-for-description 32
- "*Column at which descriptions start in a Texinfo menu.")
-
-(defun texinfo-insert-menu (menu-list node-name)
- "Insert formatted menu at point.
-Indents the first line of the description, if any, to the value of
-texinfo-column-for-description.
-
-MENU-LIST has form:
-
- \(\(\"node-name1\" . \"description\"\)
- \(\"node-name\" . \"description\"\) ... \)
-
-However, there does not need to be a description field."
-
- (insert "@menu\n")
- (while menu-list
- (if (cdr (car menu-list)) ; menu-list has description entry
- (progn
- (insert
- (format "* %s::" (car (car menu-list)))) ; node-name entry
- (indent-to texinfo-column-for-description 2)
- (insert
- (format "%s\n" (cdr (car menu-list))))) ; description entry
- ;; else menu-list lacks description entry
- (insert
- (format "* %s::\n" (car (car menu-list))))) ; node-name entry
- (setq menu-list (cdr menu-list)))
- (insert "@end menu")
- (message
- "Updated \"%s\" level menu following node: %s ... "
- level node-name))
-
-
-;;;; Handling description indentation
-
-; Since the make-menu functions indent descriptions, these functions
-; are useful primarily for indenting a single menu specially.
-
-(defun texinfo-indent-menu-description (column &optional region-p)
- "Indent every description in menu following point to COLUMN.
-Non-nil argument (prefix, if interactive) means indent every
-description in every menu in the region. Does not indent second and
-subsequent lines of a multi-line description."
-
- (interactive
- "nIndent menu descriptions to (column number): \nP")
- (save-excursion
- (save-restriction
- (widen)
- (if (not region-p)
- (progn
- (re-search-forward "^@menu")
- (texinfo-menu-indent-description column)
- (message
- "Indented descriptions in menu. You may save the buffer."))
- ;;else
- (message "Indenting every menu description in region... ")
- (goto-char (region-beginning))
- (while (and (< (point) (region-end))
- (texinfo-locate-menu-p))
- (forward-line 1)
- (texinfo-menu-indent-description column))
- (message "Indenting done. You may save the buffer.")))))
-
-(defun texinfo-menu-indent-description (to-column-number)
- "Indent the Texinfo file menu description to TO-COLUMN-NUMBER.
-Start with point just after the word `menu' in the `@menu' line and
-leave point on the line before the `@end menu' line. Does not indent
-second and subsequent lines of a multi-line description."
- (let* ((beginning-of-next-line (point)))
- (while (< beginning-of-next-line
- (save-excursion ; beginning of end menu line
- (goto-char (texinfo-menu-end))
- (beginning-of-line)
- (point)))
- (if (search-forward "::" (texinfo-menu-end) t)
- (progn
- (let ((beginning-white-space (point)))
- (skip-chars-forward " \t") ; skip over spaces
- (if (looking-at "\\(@\\|\\w\\)+") ; if there is text
- (progn
- ;; remove pre-existing indentation
- (delete-region beginning-white-space (point))
- (indent-to-column to-column-number))))))
- ;; position point at beginning of next line
- (forward-line 1)
- (setq beginning-of-next-line (point)))))
-
-
-;;;; Making the master menu
-
-(defun texinfo-master-menu (update-all-nodes-menus-p)
- "Make a master menu for a whole Texinfo file.
-Non-nil argument (prefix, if interactive) means first update all
-existing nodes and menus. Remove pre-existing master menu, if there is one.
-
-This function creates a master menu that follows the top node. The
-master menu includes every entry from all the other menus. It
-replaces any existing ordinary menu that follows the top node.
-
-If called with a non-nil argument, this function first updates all the
-menus in the buffer (incorporating descriptions from pre-existing
-menus) before it constructs the master menu.
-
-The function removes the detailed part of an already existing master
-menu. This action depends on the pre-exisitng master menu using the
-standard `texinfo-master-menu-header'.
-
-The master menu has the following format, which is adapted from the
-recommendation in the Texinfo Manual:
-
- * The first part contains the major nodes in the Texinfo file: the
- nodes for the chapters, chapter-like sections, and the major
- appendices. This includes the indices, so long as they are in
- chapter-like sections, such as unnumbered sections.
-
- * The second and subsequent parts contain a listing of the other,
- lower level menus, in order. This way, an inquirer can go
- directly to a particular node if he or she is searching for
- specific information.
-
-Each of the menus in the detailed node listing is introduced by the
-title of the section containing the menu."
-
- (interactive "P")
- (widen)
- (goto-char (point-min))
-
- ;; Move point to location after `top'.
- (if (not (re-search-forward "^@node [ \t]*top[ \t]*\\(,\\|$\\)" nil t))
- (error "This buffer needs a Top node!"))
-
- (let ((first-chapter
- (save-excursion (re-search-forward "^@node") (point))))
- (if (re-search-forward texinfo-master-menu-header first-chapter t)
- ;; Remove detailed master menu listing
- (progn
- (goto-char (match-beginning 0))
- (let ((end-of-detailed-menu-descriptions
- (save-excursion ; beginning of end menu line
- (goto-char (texinfo-menu-end))
- (beginning-of-line) (forward-char -1)
- (point))))
- (delete-region (point) end-of-detailed-menu-descriptions)))))
-
- (if update-all-nodes-menus-p
- (progn
- (message "Making a master menu...first updating all nodes... ")
- (sleep-for 2)
- (mark-whole-buffer)
- (texinfo-update-node t)
-
- (message "Updating all menus... ")
- (sleep-for 2)
- (mark-whole-buffer)
- (texinfo-make-menu t)))
-
- (message "Now making the master menu... ")
- (sleep-for 2)
- (goto-char (point-min))
- (texinfo-insert-master-menu-list
- (texinfo-master-menu-list))
-
- ;; Remove extra newlines that texinfo-insert-master-menu-list
- ;; may have inserted.
-
- (save-excursion
- (goto-char (point-min))
-
- (re-search-forward texinfo-master-menu-header)
- (goto-char (match-beginning 0))
- (insert "\n")
- (delete-blank-lines)
-
- (re-search-backward "^@menu")
- (forward-line -1)
- (delete-blank-lines)
-
- (re-search-forward "^@end menu")
- (forward-line 1)
- (delete-blank-lines))
-
- (message "Done...completed making master menu. You may save the buffer."))
-
-(defun texinfo-master-menu-list ()
- "Return a list of menu entries and header lines for the master menu.
-
-Start with the menu for chapters and indices and then find each
-following menu and the title of the node preceding that menu.
-
-The master menu list has this form:
-
- \(\(\(... \"entry-1-2\" \"entry-1\"\) \"title-1\"\)
- \(\(... \"entry-2-2\" \"entry-2-1\"\) \"title-2\"\)
- ...\)
-
-However, there does not need to be a title field."
-
- (let (master-menu-list)
- (while (texinfo-locate-menu-p)
- (setq master-menu-list
- (cons (list
- (texinfo-copy-menu)
- (texinfo-copy-menu-title))
- master-menu-list)))
- (reverse master-menu-list)))
-
-(defun texinfo-insert-master-menu-list (master-menu-list)
- "Format and insert the master menu in the current buffer."
- (goto-char (point-min))
- (re-search-forward "^@menu")
- (beginning-of-line)
- (delete-region (point) ; buffer must have ordinary top menu
- (save-excursion
- (re-search-forward "^@end menu")
- (point)))
-
- (save-excursion ; leave point at beginning of menu
- ;; Handle top of menu
- (insert "\n@menu\n")
- ;; Insert chapter menu entries
- (setq this-very-menu-list (reverse (car (car master-menu-list))))
- ;;; Tell user what is going on.
- (message "Inserting chapter menu entry: %s ... " this-very-menu-list)
- (while this-very-menu-list
- (insert "* " (car this-very-menu-list) "\n")
- (setq this-very-menu-list (cdr this-very-menu-list)))
-
- (setq master-menu-list (cdr master-menu-list))
-
- (insert texinfo-master-menu-header)
-
- ;; Now, insert all the other menus
-
- ;; The menu master-menu-list has a form like this:
- ;; ((("beta" "alpha") "title-A")
- ;; (("delta" "gamma") "title-B"))
-
- (while master-menu-list
-
- (message
- "Inserting menu for %s .... " (car (cdr (car master-menu-list))))
- ;; insert title of menu section
- (insert "\n" (car (cdr (car master-menu-list))) "\n\n")
-
- ;; insert each menu entry
- (setq this-very-menu-list (reverse (car (car master-menu-list))))
- (while this-very-menu-list
- (insert "* " (car this-very-menu-list) "\n")
- (setq this-very-menu-list (cdr this-very-menu-list)))
-
- (setq master-menu-list (cdr master-menu-list)))
-
- ;; Finish menu
- (insert "@end menu\n\n")))
-
-(defvar texinfo-master-menu-header
- "\n --- The Detailed Node Listing ---\n"
- "String inserted before lower level entries in Texinfo master menu.
-It comes after the chapter-level menu entries.")
-
-(defun texinfo-locate-menu-p ()
- "Find the next menu in the texinfo file.
-If found, leave point after word `menu' on the `@menu' line, and return t.
-If a menu is not found, do not move point and return nil."
- (re-search-forward "\\(^@menu\\)" nil t))
-
-(defun texinfo-copy-menu-title ()
- "Return the title of the section preceding the menu as a string.
-If such a title cannot be found, return an empty string. Do not move
-point."
- (save-excursion
- (if (re-search-backward
- (concat
- "\\(^@node\\).*\n" ; match node line
- "\\(\\(\\(^@c\\).*\n\\)" ; match comment line, if any
- "\\|" ; or
- "\\(^@ifinfo[ ]*\n\\)\\)?" ; ifinfo line, if any
- (eval
- (cdr
- (assoc (texinfo-hierarchic-level)
- texinfo-update-menu-higher-regexps))))
- nil
- t)
- (texinfo-copy-section-title)
- " ")))
-
-(defun texinfo-copy-menu ()
- "Return the entries of an existing menu as a list.
-Start with point just after the word `menu' in the `@menu' line
-and leave point on the line before the `@end menu' line."
- (let* (this-menu-list
- (end-of-menu (texinfo-menu-end)) ; position of end of `@end menu'
- (last-entry (save-excursion ; position of beginning of
- ; last `* ' entry
- (goto-char end-of-menu)
- (re-search-backward "^\* ") ; handle multi-line desc.
- (point))))
- (while (< (point) last-entry)
- (if (re-search-forward "^\* " end-of-menu t)
- (progn
- (setq this-menu-list
- (cons
- (buffer-substring
- (point)
- ;; copy multi-line descriptions
- (save-excursion
- (re-search-forward "\\(^\* \\|^@e\\)" nil t)
- (- (point) 3)))
- this-menu-list)))))
- this-menu-list))
-
-
-;;;; Determining the hierarchical level in the texinfo file
-
-(defun texinfo-specific-section-type ()
- "Return the specific type of next section, as a string.
-For example, \"unnumberedsubsec\". Return \"top\" for top node.
-
-Searches forward for a section. Hence, point must be before the
-section whose type will be found. Does not move point. Signal an
-error if the node is not the top node and a section is not found."
- (save-excursion
- (cond
- ((re-search-forward "^@node [ \t]*top[ \t]*\\(,\\|$\\)"
- (save-excursion
- (end-of-line)
- (point))
- t)
- "top")
- ((re-search-forward texinfo-section-types-regexp nil t)
- (buffer-substring (progn (beginning-of-line) ; copy its name
- (1+ (point)))
- (progn (forward-word 1)
- (point))))
- (t
- (error
- "texinfo-specific-section-type: Chapter or section not found.")))))
-
-(defun texinfo-hierarchic-level ()
- "Return the general hierarchal level of the next node in a texinfo file.
-Thus, a subheading or appendixsubsec is of type subsection."
- (cdr (assoc
- (texinfo-specific-section-type)
- texinfo-section-to-generic-alist)))
-
-
-;;;; Locating the major positions
-
-(defun texinfo-update-menu-region-beginning (level)
- "Locate beginning of higher level section this section is within.
-Return position of the beginning of the node line; do not move point.
-Thus, if this level is subsection, searches backwards for section node.
-Only argument is a string of the general type of section."
-
- (cond
- ((or (string-equal "top" level)
- (string-equal "chapter" level))
- (save-excursion
- (goto-char (point-min))
- (re-search-forward "^@node [ \t]*top[ \t]*\\(,\\|$\\)" nil t)
- (beginning-of-line)
- (point)))
- (t
- (save-excursion
- (re-search-backward
- (concat
- "\\(^@node\\).*\n" ; match node line
- "\\(\\(\\(^@c\\).*\n\\)" ; match comment line, if any
- "\\|" ; or
- "\\(^@ifinfo[ ]*\n\\)\\)?" ; ifinfo line, if any
- (eval
- (cdr (assoc level texinfo-update-menu-higher-regexps))))
- nil
- 'goto-beginning)
- (point)))))
-
-(defun texinfo-update-menu-region-end (level)
- "Locate end of higher level section this section is within.
-Return position; do not move point. Thus, if this level is a
-subsection, find the node for the section this subsection is within.
-If level is top or chapter, returns end of file. Only argument is a
-string of the general type of section."
-
- (save-excursion
- (if (re-search-forward
- (concat
- "\\(^@node\\).*\n" ; match node line
- "\\(\\(\\(^@c\\).*\n\\)" ; match comment line, if any
- "\\|" ; or
- "\\(^@ifinfo[ ]*\n\\)\\)?" ; ifinfo line, if any
- (eval
- (cdr (assoc level texinfo-update-menu-higher-regexps))))
- nil
- 'goto-end)
- (match-beginning 1)
- (point-max))))
-
-(defun texinfo-menu-first-node (beginning end)
- "Locate first node of the section the menu will be placed in.
-Return position; do not move point.
-The menu will be located just before this position.
-
-First argument is the position of the beginning of the section in
-which the menu will be located; second argument is the position of the
-end of that region; it limits the search."
-
- (save-excursion
- (goto-char beginning)
- (forward-line 1)
- (re-search-forward "^@node" end t)
- (beginning-of-line)
- (point)))
-
-
-;;;; Alists and regular expressions for defining hierarchical levels
-
-(defvar texinfo-section-to-generic-alist
- '(("top" . "top")
-
- ("chapter" . "chapter")
- ("unnumbered" . "chapter")
- ("majorheading" . "chapter")
- ("chapheading" . "chapter")
- ("appendix" . "chapter")
-
- ("section" . "section")
- ("unnumberedsec" . "section")
- ("heading" . "section")
- ("appendixsec" . "section")
-
- ("subsection" . "subsection")
- ("unnumberedsubsec" . "subsection")
- ("subheading" . "subsection")
- ("appendixsubsec" . "subsection")
-
- ("subsubsection" . "subsubsection")
- ("unnumberedsubsubsec" . "subsubsection")
- ("subsubheading" . "subsubsection")
- ("appendixsubsubsec" . "subsubsection"))
- "*An alist of specific and corresponding generic Texinfo section types.
-The keys are strings specifying specific types of section; the values
-are strings of their corresponding general types.")
-
-(defvar texinfo-section-types-regexp
- "^@\\(chapter \\|sect\\|sub\\|unnum\\|major\\|chapheading \\|heading \\|appendix\\)"
- "Regexp matching chapter, section, other headings (but not the top node).")
-
-(defvar texinfo-chapter-level-regexp
- "chapter\\|unnumbered \\|appendix \\|majorheading\\|chapheading"
- "Regular expression matching just the Texinfo chapter level headings.")
-
-(defvar texinfo-section-level-regexp
- "section\\|unnumberedsec\\|heading \\|appendixsec"
- "Regular expression matching just the Texinfo section level headings.")
-
-(defvar texinfo-subsection-level-regexp
- "subsection\\|unnumberedsubsec\\|subheading\\|appendixsubsec"
- "Regular expression matching just the Texinfo subsection level headings.")
-
-(defvar texinfo-subsubsection-level-regexp
- "subsubsection\\|unnumberedsubsubsec\\|subsubheading\\|appendixsubsubsec"
- "Regular expression matching just the Texinfo subsubsection level headings.")
-
-(defvar texinfo-update-menu-same-level-regexps
- '(("top" . "top[ \t]+")
- ("chapter" .
- (concat "\\(^@\\)\\(" texinfo-chapter-level-regexp "\\)[ \t]*"))
- ("section" .
- (concat "\\(^@\\)\\(" texinfo-section-level-regexp "\\)[ \t]*"))
- ("subsection" .
- (concat "\\(^@\\)\\(" texinfo-subsection-level-regexp "\\)[ \t]+"))
- ("subsubsection" .
- (concat "\\(^@\\)\\(" texinfo-subsubsection-level-regexp "\\)[ \t]+")))
- "*Regexps for searching for same level sections in a Texinfo file.
-The keys are strings specifying the general hierarchical level in the
-document; the values are regular expressions.")
-
-(defvar texinfo-update-menu-higher-regexps
- '(("top" . "^@node [ \t]*DIR")
- ("chapter" . "^@node [ \t]*top[ \t]*\\(,\\|$\\)")
- ("section" .
- (concat
- "\\(^@\\("
- texinfo-chapter-level-regexp
- "\\)[ \t]*\\)"))
- ("subsection" .
- (concat
- "\\(^@\\("
- texinfo-section-level-regexp
- "\\|"
- texinfo-chapter-level-regexp
- "\\)[ \t]*\\)"))
- ("subsubsection" .
- (concat
- "\\(^@\\("
- texinfo-subsection-level-regexp
- "\\|"
- texinfo-section-level-regexp
- "\\|"
- texinfo-chapter-level-regexp
- "\\)[ \t]*\\)")))
- "*Regexps for searching for higher level sections in a Texinfo file.
-The keys are strings specifying the general hierarchical level in the
-document; the values are regular expressions.")
-
-(defvar texinfo-update-menu-lower-regexps
- '(("top" .
- (concat
- "\\(^@\\("
- texinfo-chapter-level-regexp
- "\\|"
- texinfo-section-level-regexp
- "\\|"
- texinfo-subsection-level-regexp
- "\\|"
- texinfo-subsubsection-level-regexp
- "\\)[ \t]*\\)"))
- ("chapter" .
- (concat
- "\\(^@\\("
- texinfo-section-level-regexp
- "\\|"
- texinfo-subsection-level-regexp
- "\\|"
- texinfo-subsubsection-level-regexp
- "\\)[ \t]*\\)"))
- ("section" .
- (concat
- "\\(^@\\("
- texinfo-subsection-level-regexp
- "\\|"
- texinfo-subsubsection-level-regexp
- "\\)[ \t]+\\)"))
- ("subsection" .
- (concat
- "\\(^@\\("
- texinfo-subsubsection-level-regexp
- "\\)[ \t]+\\)"))
- ("subsubsection" . "nothing lower"))
- "*Regexps for searching for lower level sections in a Texinfo file.
-The keys are strings specifying the general hierarchical level in the
-document; the values are regular expressions.")
-
-
-;;;; Updating a Node
-
-(defun texinfo-update-node (&optional region-p)
- "Without any prefix argument, update the node in which point is located.
-Non-nil argument (prefix, if interactive) means update the nodes in the
-marked region.
-
-The functions for creating or updating nodes and menus, and their
-keybindings, are:
-
- texinfo-update-node (&optional region-p) \\[texinfo-update-node]
- texinfo-every-node-update () \\[texinfo-every-node-update]
- texinfo-sequential-node-update (&optional region-p)
-
- texinfo-make-menu (&optional region-p) \\[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. Its default value is 24."
-
- (interactive "P")
- (if (not region-p)
- (let ((auto-fill-hook nil)) ; update a single node
- (if (not (re-search-backward "^@node" (point-min) t))
- (error "Node line not found before this position."))
- (texinfo-update-the-node)
- (message "Done...updated the node. You may save the buffer."))
- ;; else
- (let ((auto-fill-hook nil)
- (beginning (region-beginning))
- (end (region-end)))
- (if (= end beginning)
- (error "Please mark a region!"))
- (save-restriction
- (narrow-to-region beginning end)
- (goto-char beginning)
- (push-mark)
- (while (re-search-forward "^@node" (point-max) t)
- (beginning-of-line)
- (texinfo-update-the-node))
- (message "Done...updated nodes in region. You may save the buffer.")))))
-
-(defun texinfo-every-node-update ()
- "Update every node in a Texinfo file."
- (interactive)
- (save-excursion
- (mark-whole-buffer)
- (texinfo-update-node t)
- (message "Done...updated every node. You may save the buffer.")))
-
-(defun texinfo-update-the-node ()
- "Update one node. Point must be at the beginning of node line.
-Leave point at the end of the node line."
- (texinfo-check-for-node-name)
- (texinfo-delete-existing-pointers)
- (message "Updating node: %s ... " (texinfo-copy-node-name))
- (save-restriction
- (widen)
- (let*
- ((case-fold-search t)
- (level (texinfo-hierarchic-level))
- (beginning (texinfo-update-menu-region-beginning level))
- (end (texinfo-update-menu-region-end level)))
- (if (string-equal level "top")
- (texinfo-top-pointer-case)
- ;; else
- (texinfo-insert-pointer beginning end level 'next)
- (texinfo-insert-pointer beginning end level 'previous)
- (texinfo-insert-pointer beginning end level 'up)
- (texinfo-clean-up-node-line)))))
-
-(defun texinfo-top-pointer-case ()
- "Insert pointers in the Top node. This is a special case.
-
-The `Next' pointer is a pointer to a chapter or section at a lower
-hierarchical level in the file. The `Previous' and `Up' pointers are
-to `(dir)'. Point must be at the beginning of the node line, and is
-left at the end of the node line."
-
- (texinfo-clean-up-node-line)
- (insert ", "
- (save-excursion
- ;; There may be an @chapter or other such command between
- ;; the top node line and the next node line, as a title
- ;; for an `ifinfo' section. This @chapter command must
- ;; must be skipped. So the procedure is to search for
- ;; the next `@node' line, and then copy its name.
- (if (re-search-forward "^@node" nil t)
- (progn
- (beginning-of-line)
- (texinfo-copy-node-name))
- " "))
- ", (dir), (dir)"))
-
-(defun texinfo-check-for-node-name ()
- "Determine whether the node has a node name. Prompt for one if not.
-Point must be at beginning of node line. Does not move point."
- (save-excursion
- (forward-word 1) ; skip over node command
- (skip-chars-forward " \t") ; and over spaces
- (if (not (looking-at "[^,\t\n ]+")) ; regexp based on what info looks for
- ; alternatively, use "[a-zA-Z]+"
- (let ((node-name (read-from-minibuffer "Node name: ")))
- (insert " " node-name)))))
-
-(defun texinfo-delete-existing-pointers ()
- "Delete `Next', `Previous', and `Up' pointers.
-Starts from the current position of the cursor, and searches forward
-on the line for a comma and if one is found, deletes the rest of the
-line, including the comma. Leaves point at beginning of line."
- (if (search-forward "," (save-excursion (end-of-line) (point)) t)
- (progn
- (goto-char (1- (point)))
- (kill-line nil)))
- (beginning-of-line))
-
-(defun texinfo-find-pointer (beginning end level direction)
- "Move point to section associated with next, previous, or up pointer.
-Return type of pointer (either 'normal or 'no-pointer).
-
-The first and second arguments bound the search for a pointer to the
-beginning and end, respectively, of the enclosing higher level
-section. The third argument is a string specifying the general kind
-of section such as \"chapter\ or \"section\". When looking for the
-`Next' pointer, the section found will be at the same hierarchical
-level in the Texinfo file; when looking for the `Previous' pointer,
-the section found will be at the same or higher hierarchical level in
-the Texinfo file; when looking for the `Up' pointer, the section found
-will be at some level higher in the Texinfo file. The fourth argument
-\(one of 'next, 'previous, or 'up\) specifies whether to find the
-`Next', `Previous', or `Up' pointer."
-
- (cond ((eq direction 'next)
- (forward-line 3) ; skip over current node
- (if (re-search-forward
- (eval
- (cdr (assoc level texinfo-update-menu-same-level-regexps)))
- end
- t)
- 'normal
- 'no-pointer))
- ((eq direction 'previous)
- (if (re-search-backward
- (concat
- "\\("
- (eval
- (cdr (assoc level texinfo-update-menu-same-level-regexps)))
- "\\|"
- (eval
- (cdr (assoc level texinfo-update-menu-higher-regexps)))
- "\\)")
- beginning
- t)
- 'normal
- 'no-pointer))
- ((eq direction 'up)
- (if (re-search-backward
- (eval (cdr (assoc level texinfo-update-menu-higher-regexps)))
- (save-excursion
- (goto-char beginning)
- (beginning-of-line)
- (point))
- t)
- 'normal
- 'no-pointer))
- (t
- (error "texinfo-find-pointer: lack proper arguments"))))
-
-(defun texinfo-pointer-name (kind)
- "Return the node name preceding the section command.
-The argument is the kind of section, either normal or no-pointer."
- (let (name)
- (cond ((eq kind 'normal)
- (end-of-line) ; this handles prev node top case
- (re-search-backward ; when point is already
- "^@node" ; at the beginning of @node line
- (save-excursion (forward-line -3))
- t)
- (setq name (texinfo-copy-node-name)))
- ((eq kind 'no-pointer)
- (setq name " "))) ; put a blank in the pointer slot
- name))
-
-(defun texinfo-insert-pointer (beginning end level direction)
- "Insert the `Next', `Previous' or `Up' node name at point.
-Move point forward.
-
-The first and second arguments bound the search for a pointer to the
-beginning and end, respectively, of the enclosing higher level
-section. The third argument is the hierarchical level of the Texinfo
-file, a string such as \"section\". The fourth argument is direction
-towards which the pointer is directed, one of `next, `previous, or
-'up."
-
- (end-of-line)
- (insert
- ", "
- (save-excursion
- (texinfo-pointer-name
- (texinfo-find-pointer beginning end level direction)))))
-
-(defun texinfo-clean-up-node-line ()
- "Remove extra commas, if any, at end of node line."
- (end-of-line)
- (skip-chars-backward ", ")
- (delete-region (point) (save-excursion (end-of-line) (point))))
-
-
-;;;; Updating nodes sequentially
-; These sequential update functions insert `Next' or `Previous'
-; pointers that point to the following or preceding nodes even if they
-; are at higher or lower hierarchical levels. This means that if a
-; section contains one or more subsections, the section's `Next'
-; pointer will point to the subsection and not the following section.
-; (The subsection to which `Next' points will most likely be the first
-; item on the section's menu.)
-
-(defun texinfo-sequential-node-update (&optional region-p)
- "Update one node (or many) in a Texinfo file with sequential pointers.
-
-This function causes the `Next' or `Previous' pointer to point to the
-immediately preceding or following node, even if it is at a higher or
-lower hierarchical level in the document. Continually pressing `n' or
-`p' takes you straight through the file.
-
-Without any prefix argument, update the node in which point is located.
-Non-nil argument (prefix, if interactive) means update the nodes in the
-marked region.
-
-This command makes it awkward to navigate among sections and
-subsections; it should be used only for those documents that are meant
-to be read like a novel rather than a reference, and for which the
-Info `g*' command is inadequate."
-
- (interactive "P")
- (if (not region-p)
- (let ((auto-fill-hook nil)) ; update a single node
- (if (not (re-search-backward "^@node" (point-min) t))
- (error "Node line not found before this position."))
- (texinfo-sequentially-update-the-node)
- (message
- "Done...sequentially updated the node . You may save the buffer."))
- ;; else
- (let ((auto-fill-hook nil)
- (beginning (region-beginning))
- (end (region-end)))
- (if (= end beginning)
- (error "Please mark a region!"))
- (save-restriction
- (narrow-to-region beginning end)
- (goto-char beginning)
- (push-mark)
- (while (re-search-forward "^@node" (point-max) t)
- (beginning-of-line)
- (texinfo-sequentially-update-the-node))
- (message
- "Done...updated the nodes in sequence. You may save the buffer.")))))
-
-(defun texinfo-sequentially-update-the-node ()
- "Update one node such that the pointers are sequential.
-A `Next' or `Previous' pointer points to any preceding or following node,
-regardless of its hierarchical level."
-
- (texinfo-check-for-node-name)
- (texinfo-delete-existing-pointers)
- (message
- "Sequentially updating node: %s ... " (texinfo-copy-node-name))
- (save-restriction
- (widen)
- (let*
- ((case-fold-search t)
- (level (texinfo-hierarchic-level)))
- (if (string-equal level "top")
- (texinfo-top-pointer-case)
- ;; else
- (texinfo-sequentially-insert-pointer level 'next)
- (texinfo-sequentially-insert-pointer level 'previous)
- (texinfo-sequentially-insert-pointer level 'up)
- (texinfo-clean-up-node-line)))))
-
-(defun texinfo-sequentially-find-pointer (level direction)
- "Find next or previous pointer sequentially in Texinfo file, or up pointer.
-Move point to section associated with the pointer. Find point even if
-it is in a different section.
-
-Return type of pointer (either 'normal or 'no-pointer).
-
-The first argument is a string specifying the general kind of section
-such as \"chapter\ or \"section\". The section found will be at the
-same hierarchical level in the Texinfo file, or, in the case of the up
-pointer, some level higher. The second argument (one of 'next,
-'previous, or 'up) specifies whether to find the `Next', `Previous',
-or `Up' pointer."
-
- (cond ((eq direction 'next)
- (forward-line 3) ; skip over current node
- (if (re-search-forward
- texinfo-section-types-regexp
- (point-max)
- t)
- 'normal
- 'no-pointer))
- ((eq direction 'previous)
- (if (re-search-backward
- texinfo-section-types-regexp
- (point-min)
- t)
- 'normal
- 'no-pointer))
- ((eq direction 'up)
- (if (re-search-backward
- (eval (cdr (assoc level texinfo-update-menu-higher-regexps)))
- beginning
- t)
- 'normal
- 'no-pointer))
- (t
- (error "texinfo-sequential-find-pointer: lack proper arguments"))))
-
-(defun texinfo-sequentially-insert-pointer (level direction)
- "Insert the `Next', `Previous' or `Up' node name at point.
-Move point forward.
-
-The first argument is the hierarchical level of the Texinfo file, a
-string such as \"section\". The second argument is direction, one of
-`next, `previous, or 'up."
-
- (end-of-line)
- (insert
- ", "
- (save-excursion
- (texinfo-pointer-name
- (texinfo-sequentially-find-pointer level direction)))))
-
-
-;;;; Inserting `@node' lines
-; The `texinfo-insert-node-lines' function inserts `@node' lines as needed
-; before the `@chapter', `@section', and such like lines of a region
-; in a Texinfo file.
-
-(defun texinfo-insert-node-lines (&optional title-p)
- "Insert missing `@node' lines in region of Texinfo file.
-Non-nil argument (prefix, if interactive) means also to insert the
-section titles as node names; and also to insert the section titles as
-node names in pre-existing @node lines that lack names."
- (interactive "P")
- (save-excursion
- (let ((begin-region (region-beginning))
- (end-region (region-end)))
- (goto-char begin-region)
- (while (< (point) end-region)
- (re-search-forward texinfo-section-types-regexp nil 'end)
- ;; copy title, since most often, we will need it
- (let ((title
- (progn
- (beginning-of-line)
- (forward-word 1)
- (skip-chars-forward " \t")
- (buffer-substring
- (point)
- (save-excursion (end-of-line) (point))))))
- ;; insert a node if necessary
- (if (re-search-backward
- "^@node"
- (save-excursion
- (forward-line -3)
- (point))
- t)
- ;; @node present, and point at beginning of that line
- (forward-word 1)
- ;; else @node missing, insert one
- (progn
- (beginning-of-line) ; beginning of `@section' line
- (insert "@node\n")
- (backward-char 1))) ; leave point just after `@node'
- ;; insert a title if warranted
- (if title-p
- (progn
- (skip-chars-forward " \t")
- ;; use regexp based on what info looks for
- ;; (alternatively, use "[a-zA-Z]+")
- (if (not (looking-at "[^,\t\n ]+"))
- (progn
- (beginning-of-line)
- (forward-word 1)
- (insert " " title)
- (message "Inserted title %s ... " title)))))
- ;; in any case, go forward beyond current section title
- (forward-line 3)))))
- (if title-p
- (message
- "Done inserting node lines and titles. You may save the buffer.")
- (message "Done inserting node lines. You may save the buffer.")))
-
-
-;;;; Update and create menus for multi-file Texinfo sources
-
-;; 1. M-x texinfo-multiple-files-update
-;;
-;; Read the include file list of an outer Texinfo file and
-;; update all highest level nodes in the files listed and insert a
-;; main menu in the outer file after its top node.
-
-;; 2. C-u M-x texinfo-multiple-files-update
-;;
-;; Same as 1, but insert a master menu. (Saves reupdating lower
-;; level menus and nodes.) This command simply reads every menu,
-;; so if the menus are wrong, the master menu will be wrong.
-;; Similarly, if the lower level node pointers are wrong, they
-;; will stay wrong.
-
-;; 3. C-u 2 M-x texinfo-multiple-files-update
-;;
-;; Read the include file list of an outer Texinfo file and
-;; update all nodes and menus in the files listed and insert a
-;; master menu in the outer file after its top node.
-
-;;; Note: these functions:
-;;;
-;;; * Do not save or delete any buffers. You may fill up your memory.
-;;; * Do not handle any pre-existing nodes in outer file.
-;;; Hence, you may need a file for indices.
-
-
-;;;; Auxiliary functions for multiple file updating
-
-(defun texinfo-multi-file-included-list (outer-file)
- "Return a list of the included files in OUTER-FILE."
- (let ((included-file-list (list outer-file))
- start)
- (save-excursion
- (switch-to-buffer (find-file-noselect outer-file))
- (widen)
- (goto-char (point-min))
- (while (re-search-forward "^@include" nil t)
- (skip-chars-forward " \t")
- (setq start (point))
- (end-of-line)
- (skip-chars-backward " \t")
- (setq included-file-list
- (cons (buffer-substring start (point))
- included-file-list)))
- (nreverse included-file-list))))
-
-(defun texinfo-copy-next-section-title ()
- "Return the name of the immediately following section as a string.
-
-Start with point at the beginning of the node line. Leave point at the
-same place. If there is no title, returns an empty string."
-
- (save-excursion
- (end-of-line)
- (let ((section-end (or
- (save-excursion
- (re-search-forward "\\(^@node\\)" nil t)
- (match-beginning 0))
- (point-max))))
- (if (re-search-forward texinfo-section-types-regexp section-end t)
- ;; copy title
- (let ((title
- (buffer-substring
- (progn (forward-word 1) ; skip over section type
- (skip-chars-forward " \t") ; and over spaces
- (point))
- (progn (end-of-line) (point)))))
- title)
- ""))))
-
-(defun texinfo-multi-file-update (files &optional update-everything)
- "Update first node pointers in each file in FILES.
-Return a list of the node names and the title immediate following them.
-
-The first file in the list is an outer file; the remaining are
-files included in the outer file with `@include' commands.
-
-If optional arg UPDATE-EVERYTHING non-nil, update every menu and
-pointer in each of the included files.
-
-Also update the `Top' level node pointers of the outer file.
-
-Requirements:
-
- * the first file in the FILES list must be the outer file,
- * each of the included files must contain exactly one highest
- hierarchical level node,
- * this node must be the first node in the included file,
- * each highest hierarchical level node must be of the same type.
-
-Thus, normally, each included file contains one, and only one,
-chapter.
-
-The menu-list has the form:
-
- \(\(\"node-name1\" . \"title1\"\)
- \(\"node-name2\" . \"title2\"\) ... \)
-
-However, there does not need to be a title field."
-
- (let (menu-list)
-
- ;; Find the name of the first node of the first included file.
- (switch-to-buffer (find-file-noselect (car (cdr files))))
- (widen)
- (goto-char (point-min))
- (if (not (re-search-forward "^@node" nil t))
- (error "No `@node' line found in %s !" (buffer-name)))
- (beginning-of-line)
- (texinfo-check-for-node-name)
- (setq next-node-name (texinfo-copy-node-name))
-
- (setq menu-list
- (cons (cons
- next-node-name
- (texinfo-copy-next-section-title))
- menu-list))
-
- ;; Go to outer file
- (switch-to-buffer (find-file-noselect (car files)))
- (goto-char (point-min))
- (if (not (re-search-forward "^@node [ \t]*top[ \t]*\\(,\\|$\\)" nil t))
- (error "This buffer needs a Top node!"))
- (beginning-of-line)
- (texinfo-delete-existing-pointers)
- (end-of-line)
- (insert ", " next-node-name ", (dir), (dir)")
- (beginning-of-line)
- (setq previous-node-name "Top")
- (setq files (cdr files))
-
- (while files
-
- (if (not (cdr files))
- ;; No next file
- (setq next-node-name "")
- ;; Else,
- ;; find the name of the first node in the next file.
- (switch-to-buffer (find-file-noselect (car (cdr files))))
- (widen)
- (goto-char (point-min))
- (if (not (re-search-forward "^@node" nil t))
- (error "No `@node' line found in %s !" (buffer-name)))
- (beginning-of-line)
- (texinfo-check-for-node-name)
- (setq next-node-name (texinfo-copy-node-name))
- (setq menu-list
- (cons (cons
- next-node-name
- (texinfo-copy-next-section-title))
- menu-list)))
-
- ;; Go to node to be updated.
- (switch-to-buffer (find-file-noselect (car files)))
- (goto-char (point-min))
- (if (not (re-search-forward "^@node" nil t))
- (error "No `@node' line found in %s !" (buffer-name)))
- (beginning-of-line)
- (texinfo-delete-existing-pointers)
- (end-of-line)
- (insert ", " next-node-name ", " previous-node-name ", " up-node-name)
-
- (beginning-of-line)
- (setq previous-node-name (texinfo-copy-node-name))
-
- ;; Update other menus and nodes if requested.
- (if update-everything (texinfo-all-menus-update t))
-
- (setq files (cdr files)))
- (nreverse menu-list)))
-
-(defun texinfo-multi-files-insert-main-menu (menu-list)
- "Insert formatted main menu at point.
-Indents the first line of the description, if any, to the value of
-texinfo-column-for-description."
-
- (insert "@menu\n")
- (while menu-list
- (if (cdr (car menu-list)) ; menu-list has description entry
- (progn
- (insert
- (format "* %s::" (car (car menu-list)))) ; node-name entry
- (indent-to texinfo-column-for-description 2)
- (insert
- (format "%s\n" (cdr (car menu-list))))) ; description entry
- ;; else menu-list lacks description entry
- (insert
- (format "* %s::\n" (car (car menu-list))))) ; node-name entry
- (setq menu-list (cdr menu-list)))
- (insert "@end menu"))
-
-
-(defun texinfo-multi-file-master-menu-list (files-list)
- "Return master menu list from files in FILES-LIST.
-Menu entries in each file collected using `texinfo-master-menu-list'.
-
-The first file in FILES-LIST must be the outer file; the others must
-be the files included within it. A main menu must already exist."
- (save-excursion
- (let (master-menu-list)
- (while files-list
- (switch-to-buffer (find-file-noselect (car files-list)))
- (message "Working on: %s " (current-buffer))
- (goto-char (point-min))
- (setq master-menu-list
- (append master-menu-list (texinfo-master-menu-list)))
- (setq files-list (cdr files-list)))
- master-menu-list)))
-
-
-;;;; The multiple-file update function
-
-(defun texinfo-multiple-files-update
- (outer-file &optional update-everything make-master-menu)
- "Update first node pointers in each file included in OUTER-FILE;
-create or update main menu in the outer file that refers to such nodes.
-This does not create or update menus or pointers within the included files.
-
-With optional MAKE-MASTER-MENU argument (prefix arg, if interactive),
-insert a master menu in OUTER-FILE. This does not create or update
-menus or pointers within the included files.
-
-With optional UPDATE-EVERYTHING argument (numeric prefix arg, if
-interactive), update all the menus and all the `Next', `Previous', and
-`Up' pointers of all the files included in OUTER-FILE before inserting
-a master menu in OUTER-FILE.
-
-The command also updates the `Top' level node pointers of OUTER-FILE.
-
-Notes:
-
- * this command does NOT save any files--you must save the
- outer file and any modified, included files.
-
- * except for the `Top' node, this command does NOT handle any
- pre-existing nodes in the outer file; hence, indices must be
- enclosed in an included file.
-
-Requirements:
-
- * each of the included files must contain exactly one highest
- hierarchical level node,
- * this highest node must be the first node in the included file,
- * each highest hierarchical level node must be of the same type.
-
-Thus, normally, each included file contains one, and only one,
-chapter."
-
- (interactive "fName of outer `include' file: ")
-
- (cond (current-prefix-arg
- (setq make-master-menu (listp current-prefix-arg))
- (setq update-everything (numberp current-prefix-arg))))
-
- (let* ((included-file-list (texinfo-multi-file-included-list outer-file))
- (files included-file-list)
- main-menu-list
- next-node-name
- previous-node-name
- (up-node-name "Top"))
-
-;;; Update the pointers
-;;; and collect the names of the nodes and titles
- (setq main-menu-list (texinfo-multi-file-update files update-everything))
-
-;;; Insert main menu
-
- ;; Go to outer file
- (switch-to-buffer (find-file-noselect (car included-file-list)))
- (if (texinfo-old-menu-p
- (point-min)
- (save-excursion
- (re-search-forward "^@include")
- (beginning-of-line)
- (point)))
-
- ;; If found, leave point after word `menu' on the `@menu' line.
- (progn
- (texinfo-incorporate-descriptions main-menu-list)
- ;; Delete existing menu.
- (beginning-of-line)
- (delete-region
- (point)
- (save-excursion (re-search-forward "^@end menu") (point)))
- ;; Insert main menu
- (texinfo-multi-files-insert-main-menu main-menu-list))
-
- ;; Else no current menu; insert it before `@include'
- (texinfo-multi-files-insert-main-menu main-menu-list))
-
-;;; Insert master menu
-
- (if make-master-menu
- (progn
- ;; First, removing detailed part of any pre-existing master menu
- (goto-char (point-min))
- (if (re-search-forward texinfo-master-menu-header nil t)
- ;; Remove detailed master menu listing
- (progn
- (goto-char (match-beginning 0))
- (let ((end-of-detailed-menu-descriptions
- (save-excursion ; beginning of end menu line
- (goto-char (texinfo-menu-end))
- (beginning-of-line) (forward-char -1)
- (point))))
- (delete-region (point) end-of-detailed-menu-descriptions))))
-
- ;; Create a master menu and insert it
- (texinfo-insert-master-menu-list
- (texinfo-multi-file-master-menu-list
- included-file-list)))))
- (message "Multiple files updated."))
-
-;;;;;;;;;;;;;;;; end texnfo-upd.el ;;;;;;;;;;;;;;;;
diff --git a/lisp/time.el b/lisp/time.el
index 8a1f37f8e18..df5c7d5fe64 100644
--- a/lisp/time.el
+++ b/lisp/time.el
@@ -1,5 +1,5 @@
;; Display time and load in mode line of Emacs.
-;; Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1986, 1987, 1990 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
@@ -29,15 +29,11 @@ Default is system-dependent, and is the same as used by Rmail.")
(defvar display-time-string nil)
-(defvar display-time-hook nil
- "* List of functions to be called when the time is updated on the mode line.")
-
(defun display-time ()
"Display current time and load level in mode line of each buffer.
Updates automatically every minute.
-If `display-time-day-and-date' is non-nil, the current day and date
-are displayed as well.
-After each update, `display-time-hook' is run with `run-hooks'."
+If display-time-day-and-date is non-nil, the current day and date
+are displayed as well."
(interactive)
(let ((live (and display-time-process
(eq (process-status display-time-process) 'run))))
@@ -50,10 +46,11 @@ After each update, `display-time-hook' is run with `run-hooks'."
(setq global-mode-string
(append global-mode-string '(display-time-string))))
(setq display-time-string "")
- (setq display-time-process
- (start-process "display-time" nil
- "wakeup"
- (int-to-string display-time-interval)))
+ (let ((process-connection-type nil))
+ (setq display-time-process
+ (start-process "display-time" nil
+ (concat exec-directory "wakeup")
+ (int-to-string display-time-interval))))
(process-kill-without-query display-time-process)
(set-process-sentinel display-time-process 'display-time-sentinel)
(set-process-filter display-time-process 'display-time-filter)))))
@@ -68,7 +65,27 @@ After each update, `display-time-hook' is run with `run-hooks'."
(defun display-time-filter (proc string)
(let ((time (current-time-string))
- (load (format "%03d" (car (load-average))))
+ (load (condition-case ()
+ (if (zerop (car (load-average))) ""
+ (format "%03d" (car (load-average))))
+ (error
+ (condition-case ()
+ (unwind-protect
+ (save-excursion
+ (set-buffer (get-buffer-create " *uptime*"))
+ (call-process "/usr/ucb/uptime" nil (current-buffer))
+ (goto-char (point-min))
+ (search-forward "average: ")
+ ;; Get the integer part and fraction part,
+ ;; discarding the period.
+ ;; (Because code below adds a period.)
+ (concat
+ (buffer-substring (point)
+ (progn (forward-word 1) (point)))
+ (buffer-substring (1+ (point))
+ (progn (forward-word 1) (point)))))
+ (kill-buffer " *uptime*"))
+ (error "")))))
(mail-spool-file (or display-time-mail-file
(getenv "MAIL")
(concat rmail-spool-directory
@@ -84,8 +101,10 @@ After each update, `display-time-hook' is run with `run-hooks'."
(setq hour 12)))
(setq display-time-string
(concat (format "%d" hour) (substring time 13 16)
- (if pm "pm " "am ")
- (substring load 0 -2) "." (substring load -2)
+ (if pm "pm" "am")
+ (if (string= load "")
+ ""
+ (concat " " (substring load 0 -2) "." (substring load -2)))
(if (and (file-exists-p mail-spool-file)
;; file not empty?
(> (nth 7 (file-attributes mail-spool-file)) 0))
@@ -95,7 +114,6 @@ After each update, `display-time-hook' is run with `run-hooks'."
(if display-time-day-and-date
(setq display-time-string
(concat (substring time 0 11) display-time-string))))
- (run-hooks 'display-time-hook)
;; Force redisplay of all buffers' mode lines to be considered.
(save-excursion (set-buffer (other-buffer)))
(set-buffer-modified-p (buffer-modified-p))
diff --git a/lisp/time.elc b/lisp/time.elc
new file mode 100644
index 00000000000..5e26869c247
--- /dev/null
+++ b/lisp/time.elc
Binary files differ
diff --git a/lisp/timer.el b/lisp/timer.el
deleted file mode 100644
index 7f71f784de9..00000000000
--- a/lisp/timer.el
+++ /dev/null
@@ -1,92 +0,0 @@
-;; Run a function with args at some time in future
-;; Copyright (C) 1990 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-(defvar timer-process nil)
-(defvar timer-alist ())
-(defvar timer-out "")
-(defvar timer-dont-exit nil
- ;; this is useful for functions which will be doing their own erratic
- ;; rescheduling or people who otherwise expect to use the process frequently
- "If non-nil, don't exit the timer process when no more events are pending.")
-
-(defun run-at-time (time repeat function &rest args)
- "Run a function at a time, and optionally on a regular interval.
-Arguments are TIME, REPEAT, FUNCTION &rest ARGS.
-TIME, a string, can be specified absolutely or relative to now.
-REPEAT, an integer number of seconds, is the interval on which to repeat
-the call to the function."
- (interactive "sRun at time: \nNRepeat interval: \naFunction: ")
- (cond ((or (not timer-process)
- (memq (process-status timer-process) '(exit signal nil)))
- (if timer-process (delete-process timer-process))
- (setq timer-process (start-process "timer" nil "timer")
- timer-alist nil)
- (set-process-filter timer-process 'timer-process-filter)
- (set-process-sentinel timer-process 'timer-process-sentinel)
- (process-kill-without-query timer-process))
- ((eq (process-status timer-process) 'stop)
- (continue-process timer-process)))
- ;; There should be a living, breathing timer process now
- (let ((token (concat (current-time-string) "-" (length timer-alist))))
- (send-string timer-process (concat time "\001" token "\n"))
- (setq timer-alist (cons (list token repeat function args) timer-alist))))
-
-(defun timer-process-filter (proc str)
- (setq timer-out (concat timer-out str))
- (let (do token error)
- (while (string-match "\n" timer-out)
- (setq token (substring timer-out 0 (match-beginning 0))
- do (assoc token timer-alist)
- timer-out (substring timer-out (match-end 0)))
- (cond
- (do (apply (nth 2 do) (nth 3 do)) ; do it
- (if (natnump (nth 1 do)) ; reschedule it
- (send-string proc (concat (nth 1 do) " sec\001" (car do) "\n"))
- (setq timer-alist (delq do timer-alist))))
- ((string-match "timer: \\([^:]+\\): \\([^\001]*\\)\001\\(.*\\)$" token)
- (setq error (substring token (match-beginning 1) (match-end 1))
- do (substring token (match-beginning 2) (match-end 2))
- token (assoc (substring token (match-beginning 3) (match-end 3))
- timer-alist)
- timer-alist (delq token timer-alist))
- (ding 'no-terminate) ; using error function in process filters is rude
- (message "%s for %s; couldn't set at \"%s\"" error (nth 2 token) do))))
- (or timer-alist timer-dont-exit (process-send-eof proc))))
-
-(defun timer-process-sentinel (proc str)
- (let ((stat (process-status proc)))
- (if (eq stat 'stop) (continue-process proc)
- ;; if it exited normally, presumably it was intentional.
- ;; if there were no pending events, who cares that it exited?
- (if (or (not timer-alist) (eq stat 'exit)) ()
- (ding 'no-terminate)
- (message "Timer exited abnormally. All events cancelled."))
- (setq timer-process nil timer-alist nil timer-scratch ""))))
-
-(defun cancel-timer (function)
- "Cancel all events scheduled by ``run-at-time'' which would run FUNCTION."
- (interactive "aCancel function: ")
- (let ((alist timer-alist))
- (while alist
- (if (eq (nth 2 (car alist)) function)
- (setq timer-alist (delq (car alist) timer-alist)))
- (setq alist (cdr alist))))
- (or timer-alist timer-dont-exit (process-send-eof timer-process)))
-
-(provide 'timer)
diff --git a/lisp/uncompress.el b/lisp/uncompress.el
index 6897c7c3ccb..6b782d77820 100644
--- a/lisp/uncompress.el
+++ b/lisp/uncompress.el
@@ -1,18 +1,3 @@
-;; When we are about to make a backup file,
-;; uncompress the file we visited
-;; so that making the backup can work properly.
-;; This is used as a write-file-hook.
-
-(defun uncompress-backup-file ()
- (and buffer-file-name make-backup-files (not buffer-backed-up)
- (not (file-exists-p buffer-file-name))
- (call-process "uncompress" nil nil nil buffer-file-name))
- nil)
-
-(or (assoc "\\.Z$" auto-mode-alist)
- (setq auto-mode-alist
- (cons '("\\.Z$" . uncompress-while-visiting) auto-mode-alist)))
-
(defun uncompress-while-visiting ()
"Temporary \"major mode\" used for .Z files, to uncompress the contents.
It then selects a major mode from the uncompressed file name and contents."
@@ -25,14 +10,10 @@ It then selects a major mode from the uncompressed file name and contents."
(shell-command-on-region (point-min) (point-max) "uncompress" t))
(message "Uncompressing...done")
(set-buffer-modified-p nil)
- (make-local-variable 'write-file-hooks)
- (or (memq 'uncompress-backup-file write-file-hooks)
- (setq write-file-hooks (cons 'uncompress-backup-file write-file-hooks)))
(normal-mode))
-(or (memq 'find-compressed-version find-file-not-found-hooks)
- (setq find-file-not-found-hooks
- (cons 'find-compressed-version find-file-not-found-hooks)))
+(setq auto-mode-alist
+ (cons '("\\.Z$" . uncompress-while-visiting) auto-mode-alist))
(defun find-compressed-version ()
"Hook to read and uncompress the compressed version of a file."
@@ -45,3 +26,6 @@ It then selects a major mode from the uncompressed file name and contents."
(goto-char (point-min))
(setq error nil)
t)))
+
+(setq find-file-not-found-hooks
+ (cons 'find-compressed-version find-file-not-found-hooks))
diff --git a/lisp/textmodes/underline.el b/lisp/underline.el
index 4a9f3dfa823..ef9c7fa3651 100644
--- a/lisp/textmodes/underline.el
+++ b/lisp/underline.el
@@ -42,5 +42,5 @@ which specify the range to operate on."
(let ((end1 (make-marker)))
(move-marker end1 (max start end))
(goto-char (min start end))
- (while (re-search-forward "_\\|_" end1 t)
+ (while (search-forward "_" end1 t)
(delete-char -2)))))
diff --git a/lisp/underline.elc b/lisp/underline.elc
new file mode 100644
index 00000000000..5b4b6b1b9b7
--- /dev/null
+++ b/lisp/underline.elc
Binary files differ
diff --git a/lisp/mail/undigest.el b/lisp/undigest.el
index 583251e990f..590f225a8c2 100644
--- a/lisp/mail/undigest.el
+++ b/lisp/undigest.el
@@ -53,8 +53,7 @@ Leaves original message, deleted, before the undigestified messages."
(goto-char (point-max))
(or (mail-fetch-field "Reply-To")
(mail-fetch-field "To")
- (mail-fetch-field "Apparently-To")
- (mail-fetch-field "From")))
+ (mail-fetch-field "Apparently-To")))
(error "Message is not a digest")))))
(save-excursion
(goto-char (point-max))
diff --git a/lisp/undigest.elc b/lisp/undigest.elc
new file mode 100644
index 00000000000..4326826ce93
--- /dev/null
+++ b/lisp/undigest.elc
Binary files differ
diff --git a/lisp/userlock.el b/lisp/userlock.el
index e74621675a2..39871cc4e4c 100644
--- a/lisp/userlock.el
+++ b/lisp/userlock.el
@@ -78,9 +78,7 @@ You can <q>uit; don't modify this file.")))
This function has two choices: it can return, in which case the modification
of the buffer will proceed, or it can (signal 'file-supersession (file)),
in which case the proposed buffer modification will not be made.
-
-You can rewrite this to use any criterion you like to choose which one to do.
-The buffer in question is current when this function is called."
+You can rewrite this to use any criterion you like to choose which one to do."
(discard-input)
(save-window-excursion
(let (answer)
@@ -118,7 +116,8 @@ If you say `y' to go ahead and modify this buffer,
you risk ruining the work of whoever rewrote the file.
If you say `n', the change you started to make will be aborted.
-Usually, you should type `n' and then `M-x revert-buffer',
-to get the latest version of the file, then make the change again.")))
+You might consider answering `n', running `M-x revert-buffer' to
+bring the text in Emacs into accord with what is on disk, and then
+making the change again.")))
diff --git a/lisp/userlock.elc b/lisp/userlock.elc
new file mode 100644
index 00000000000..edd87dfcdd1
--- /dev/null
+++ b/lisp/userlock.elc
Binary files differ
diff --git a/lisp/version.el b/lisp/version.el
new file mode 100644
index 00000000000..ed412d63de4
--- /dev/null
+++ b/lisp/version.el
@@ -0,0 +1,45 @@
+;; Record version number of Emacs.
+;; Copyright (C) 1985 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+;; The following line is modified automatically
+;; by loading inc-version.el, each time a new Emacs is dumped.
+(defconst emacs-version "18.59.0" "\
+Version numbers of this version of Emacs.")
+
+(defconst emacs-build-time (current-time-string) "\
+Time at which Emacs was dumped out.")
+
+(defconst emacs-build-system (system-name))
+
+(defun emacs-version () "\
+Return string describing the version of Emacs that is running."
+ (interactive)
+ (if (interactive-p)
+ (message "%s" (emacs-version))
+ (format "GNU Emacs %s of %s %s on %s (%s)"
+ emacs-version
+ (substring emacs-build-time 0
+ (string-match " *[0-9]*:" emacs-build-time))
+ (substring emacs-build-time (string-match "[0-9]*$" emacs-build-time))
+ emacs-build-system system-type)))
+
+;;Local variables:
+;;version-control: never
+;;End:
diff --git a/lisp/emulation/vi.el b/lisp/vi.el
index 324f0b5882d..4b391ec82cc 100644
--- a/lisp/emulation/vi.el
+++ b/lisp/vi.el
@@ -748,7 +748,7 @@ scrolls default amount. The given COUNT is remembered for future scrollings."
"Go down count lines, try to keep at the same column."
(interactive "p")
(setq this-command 'next-line) ; this is a needed trick
- (if (= (point) (or (line-move count) (point)))
+ (if (= (point) (or (next-line-internal count) (point)))
(ding) ; no moving, already at end of buffer
(setq last-command 'next-line)))
diff --git a/lisp/vi.elc b/lisp/vi.elc
new file mode 100644
index 00000000000..bd9620b5c2c
--- /dev/null
+++ b/lisp/vi.elc
Binary files differ
diff --git a/lisp/view.el b/lisp/view.el
index 36f0d7bb63b..636cc38f770 100644
--- a/lisp/view.el
+++ b/lisp/view.el
@@ -1,5 +1,5 @@
;; View: Peruse file or buffer without editing.
-;; Copyright (C) 1985, 1989 Free Software Foundation, Inc.
+;; Copyright (C) 1985 Free Software Foundation, Inc.
;; Principal author K. Shane Hartman
;; This file is part of GNU Emacs.
@@ -26,9 +26,9 @@
nil
(setq view-mode-map (make-keymap))
(fillarray view-mode-map 'View-undefined)
- (define-key view-mode-map "\C-c" 'view-exit)
+ (define-key view-mode-map "\C-c" 'exit-recursive-edit)
(define-key view-mode-map "\C-z" 'suspend-emacs)
- (define-key view-mode-map "q" 'view-exit)
+ (define-key view-mode-map "q" 'exit-recursive-edit)
(define-key view-mode-map "-" 'negative-argument)
(define-key view-mode-map "0" 'digit-argument)
(define-key view-mode-map "1" 'digit-argument)
@@ -74,8 +74,8 @@
(define-key view-mode-map "h" 'Helper-describe-bindings)
(define-key view-mode-map "?" 'Helper-describe-bindings)
(define-key view-mode-map "\C-h" 'Helper-help)
- (define-key view-mode-map "\C-n" 'next-line)
- (define-key view-mode-map "\C-p" 'previous-line)
+ (define-key view-mode-map "\C-n" 'View-next-line)
+ (define-key view-mode-map "\C-p" 'View-previous-line)
(define-key view-mode-map "\C-s" 'isearch-forward)
(define-key view-mode-map "\C-r" 'isearch-backward)
(define-key view-mode-map "s" 'isearch-forward)
@@ -100,13 +100,14 @@ For list of all View commands, type ? or h while viewing.
Calls the value of view-hook if that is non-nil."
(interactive "fView file: ")
- (let ((old-buf (current-buffer))
- (had-a-buf (get-file-buffer file-name))
- (buf-to-view (find-file-noselect file-name)))
- (switch-to-buffer buf-to-view t)
- (view-mode old-buf
- (and (not had-a-buf) (not (buffer-modified-p buf-to-view))
- 'kill-buffer))))
+ (let ((had-a-buf (get-file-buffer file-name))
+ (buf-to-view nil))
+ (unwind-protect
+ (view-mode (prog1 (current-buffer)
+ (switch-to-buffer
+ (setq buf-to-view (find-file-noselect file-name)) t)))
+ (and (not had-a-buf) buf-to-view (not (buffer-modified-p buf-to-view))
+ (kill-buffer buf-to-view)))))
(defun view-buffer (buffer-name)
"View BUFFER in View mode, returning to previous buffer when done.
@@ -118,11 +119,9 @@ For list of all View commands, type ? or h while viewing.
Calls the value of view-hook if that is non-nil."
(interactive "bView buffer: ")
- (let ((old-buf (current-buffer)))
- (switch-to-buffer buffer-name t)
- (view-mode old-buf nil)))
+ (view-mode (prog1 (current-buffer) (switch-to-buffer buffer-name))))
-(defun view-mode (&optional prev-buffer action)
+(defun view-mode (&optional view-return-to-buffer)
"Major mode for viewing text but not editing it.
Letters do not insert themselves. Instead these commands are provided.
Most commands take prefix arguments. Commands dealing with lines
@@ -163,81 +162,26 @@ Entry to this mode calls the value of view-hook if non-nil.
; if you call it without passing a buffer as argument
; and they are not easy to fix.
; (interactive)
- (make-local-variable 'view-old-mode-line-buffer-identification)
- (setq view-old-mode-line-buffer-identification
- mode-line-buffer-identification)
- (make-local-variable 'view-old-buffer-read-only)
- (setq view-old-buffer-read-only buffer-read-only)
- (make-local-variable 'view-old-mode-name)
- (setq view-old-mode-name mode-name)
- (make-local-variable 'view-old-major-mode)
- (setq view-old-major-mode major-mode)
- (make-local-variable 'view-old-local-map)
- (setq view-old-local-map (current-local-map))
- (make-local-variable 'view-old-Helper-return-blurb)
- (setq view-old-Helper-return-blurb
- (and (boundp 'Helper-return-blurb) Helper-return-blurb))
-
- (setq buffer-read-only t)
- (setq mode-line-buffer-identification
- (list
- (if (buffer-file-name)
- "Viewing %f"
- "Viewing %b")))
- (setq mode-name "View")
- (setq major-mode 'view-mode)
- (setq Helper-return-blurb
- (format "continue viewing %s"
+ (let* ((view-buffer-window (selected-window))
+ (view-scroll-size nil))
+ (unwind-protect
+ (let ((buffer-read-only t)
+ (mode-line-buffer-identification
+ (list
(if (buffer-file-name)
- (file-name-nondirectory (buffer-file-name))
- (buffer-name))))
-
- (make-local-variable 'view-exit-action)
- (setq view-exit-action action)
- (make-local-variable 'view-prev-buffer)
- (setq view-prev-buffer prev-buffer)
- (make-local-variable 'view-exit-position)
- (setq view-exit-position (point-marker))
-
- (make-local-variable 'view-scroll-size)
- (setq view-scroll-size nil)
- (make-local-variable 'view-last-regexp)
- (setq view-last-regexp nil)
-
- (beginning-of-line)
- (setq goal-column nil)
-
- (use-local-map view-mode-map)
- (run-hooks 'view-hook)
- (view-helpful-message))
-
-(defun view-exit ()
- "Exit from view-mode.
-If you viewed an existing buffer, that buffer returns to its previous mode.
-If you viewed a file that was not present in Emacs, its buffer is killed."
- (interactive)
- (setq mode-line-buffer-identification
- view-old-mode-line-buffer-identification)
- (setq major-mode view-old-major-mode)
- (setq mode-name view-old-mode-name)
- (use-local-map (current-local-map))
- (setq buffer-read-only view-old-buffer-read-only)
-
- (goto-char view-exit-position)
- (set-marker view-exit-position nil)
-
- ;; Now do something to the buffer that we were viewing
- ;; (such as kill it).
- (let ((viewed-buffer (current-buffer))
- (action view-exit-action))
- (switch-to-buffer view-prev-buffer)
- (if action (funcall action viewed-buffer))))
+ "Viewing %f"
+ "Viewing %b")))
+ (mode-name "View"))
+ (beginning-of-line)
+ (catch 'view-mode-exit (view-mode-command-loop)))
+ (if view-return-to-buffer
+ (switch-to-buffer view-return-to-buffer)))))
(defun view-helpful-message ()
(message
(if (and (eq (key-binding "\C-h") 'Helper-help)
(eq (key-binding "?") 'Helper-describe-bindings)
- (eq (key-binding "\C-c") 'view-exit))
+ (eq (key-binding "\C-c") 'exit-recursive-edit))
"Type C-h for help, ? for commands, C-c to quit"
(substitute-command-keys
"Type \\[Helper-help] for help, \\[Helper-describe-bindings] for commands, \\[exit-recursive-edit] to quit."))))
@@ -247,7 +191,7 @@ If you viewed a file that was not present in Emacs, its buffer is killed."
(ding)
(view-helpful-message))
-(defun view-window-size () (1- (window-height)))
+(defun view-window-size () (1- (window-height view-buffer-window)))
(defun view-scroll-size ()
(min (view-window-size) (or view-scroll-size (view-window-size))))
@@ -255,6 +199,31 @@ If you viewed a file that was not present in Emacs, its buffer is killed."
(defvar view-hook nil
"If non-nil, its value is called when viewing buffer or file.")
+(defun view-mode-command-loop ()
+ (push-mark)
+ (let ((old-local-map (current-local-map))
+ (mark-ring)
+; (view-last-command)
+; (view-last-command-entry)
+; (view-last-command-argument)
+ (view-last-regexp)
+ (Helper-return-blurb
+ (format "continue viewing %s"
+ (if (buffer-file-name)
+ (file-name-nondirectory (buffer-file-name))
+ (buffer-name))))
+ (view-buffer (buffer-name)))
+ (unwind-protect
+ (progn
+ (use-local-map view-mode-map)
+ (run-hooks 'view-hook)
+ (view-helpful-message)
+ (recursive-edit))
+ (save-excursion
+ (set-buffer view-buffer)
+ (use-local-map old-local-map))))
+ (pop-mark))
+
;(defun view-last-command (&optional who what)
; (setq view-last-command-entry this-command)
; (setq view-last-command who)
@@ -387,3 +356,12 @@ invocations return to earlier marks."
(message "Can't find occurrence %d of %s" times regexp)
(sit-for 4))))
+(defun View-previous-line (count)
+ "Move up to start of previous line. Argument is repeat count."
+ (interactive "p")
+ (forward-line (- count)))
+
+(defun View-next-line (count)
+ "Move down to start of next line. Argument is repeat count."
+ (interactive "p")
+ (forward-line count))
diff --git a/lisp/view.elc b/lisp/view.elc
new file mode 100644
index 00000000000..e5b445dacf7
--- /dev/null
+++ b/lisp/view.elc
Binary files differ
diff --git a/lisp/emulation/vip.el b/lisp/vip.el
index da853aa9c36..f41e031bd7d 100644
--- a/lisp/emulation/vip.el
+++ b/lisp/vip.el
@@ -13,10 +13,14 @@
(defvar vip-emacs-local-map nil
"Local map used in emacs mode. \(buffer specific\)")
+(defvar vip-emacs-old-commands nil
+ "Old Emacs definitions of C-x 3 and C-x TAB.")
+
(defvar vip-insert-local-map nil
"Local map used in insert command mode. \(buffer specific\)")
(make-variable-buffer-local 'vip-emacs-local-map)
+(make-variable-buffer-local 'vip-emacs-old-commands)
(make-variable-buffer-local 'vip-insert-local-map)
(defvar vip-insert-point nil
@@ -169,20 +173,31 @@ or insert-mode."
(vip-copy-region-as-kill (point) vip-insert-point)
(vip-repeat-insert-command))
(setq vip-emacs-local-map (current-local-map)
+ vip-emacs-old-commands
+ (cons (lookup-key ctl-x-map "3")
+ (lookup-key ctl-x-map "\C-i"))
vip-emacs-mode-line-buffer-identification
mode-line-buffer-identification
vip-insert-local-map (vip-copy-keymap
- (current-local-map))))
+ (current-local-map)))
+ (define-key ctl-x-map "3" 'vip-buffer-in-two-windows)
+ (define-key ctl-x-map "\C-i" 'insert-file))
(vip-change-mode-line "Vi: ")
(use-local-map vip-mode-map))
((eq new-mode 'insert-mode)
(move-marker vip-insert-point (point))
(if (eq vip-current-mode 'emacs-mode)
- (setq vip-emacs-local-map (current-local-map)
- vip-emacs-mode-line-buffer-identification
- mode-line-buffer-identification
- vip-insert-local-map (vip-copy-keymap
- (current-local-map)))
+ (progn
+ (setq vip-emacs-local-map (current-local-map)
+ vip-emacs-old-commands
+ (cons (lookup-key ctl-x-map "3")
+ (lookup-key ctl-x-map "\C-i"))
+ vip-emacs-mode-line-buffer-identification
+ mode-line-buffer-identification
+ vip-insert-local-map (vip-copy-keymap
+ (current-local-map)))
+ (define-key ctl-x-map "3" 'vip-buffer-in-two-windows)
+ (define-key ctl-x-map "\C-i" 'insert-file))
(setq vip-insert-local-map (vip-copy-keymap
vip-emacs-local-map)))
(vip-change-mode-line "Insert")
@@ -196,6 +211,8 @@ or insert-mode."
'vip-delete-backward-word))
((eq new-mode 'emacs-mode)
(vip-change-mode-line "Emacs:")
+ (define-key ctl-x-map "3" (car vip-emacs-old-commands))
+ (define-key ctl-x-map "\C-i" (cdr vip-emacs-old-commands))
(use-local-map vip-emacs-local-map)))
(setq vip-current-mode new-mode)
(vip-refresh-mode-line))))
@@ -1115,7 +1132,7 @@ beginning of buffer, stop and signal error."
(interactive "P")
(let ((val (vip-p-val arg)) (com (vip-getCom arg)))
(if com (move-marker vip-com-point (point)))
- (line-move val)
+ (next-line-internal val)
(setq this-command 'next-line)
(if com (vip-execute-com 'vip-next-line val com))))
@@ -2017,9 +2034,6 @@ the query replace mode will toggle between string replace and regexp replace."
(define-key vip-mode-map "~" 'vip-nil)
(define-key vip-mode-map "\177" 'vip-delete-backward-char)
-(define-key ctl-x-map "3" 'vip-buffer-in-two-windows)
-(define-key ctl-x-map "\C-i" 'insert-file)
-
(defun vip-version ()
(interactive)
(message "VIP version 3.5 of September 15, 1987"))
@@ -3019,7 +3033,10 @@ vip-s-string"
(vip-enlarge-region beg end)
(write-region (point) (mark) ex-file ex-append t)))
(if (null buffer-file-name) (setq buffer-file-name ex-file))
- (if q-flag (save-buffers-kill-emacs)))
+ (if q-flag
+ (progn
+ (delete-auto-save-file-if-necessary)
+ (kill-buffer (current-buffer)))))
(defun ex-yank ()
"ex yank"
diff --git a/lisp/vip.elc b/lisp/vip.elc
new file mode 100644
index 00000000000..f787720767e
--- /dev/null
+++ b/lisp/vip.elc
Binary files differ
diff --git a/lisp/vms-patch.el b/lisp/vms-patch.el
index 15302b3fd90..3c5e1e8d606 100644
--- a/lisp/vms-patch.el
+++ b/lisp/vms-patch.el
@@ -56,7 +56,8 @@ See also auto-save-file-name-p."
(if buffer-file-name
(concat (file-name-directory buffer-file-name)
"_$"
- (file-name-nondirectory buffer-file-name)
+ (file-name-sans-versions (file-name-nondirectory
+ buffer-file-name))
"$")
(expand-file-name (concat "_$_" (make-legal-file-name (buffer-name)) "$"))))
@@ -81,29 +82,3 @@ If the logical name `EMACS_FILE_NAME' is defined, `find-file' that file."
nil)
(setq suspend-hook 'vms-suspend-hook)
-
-(defun vms-read-directory (dirname switches buffer)
- (save-excursion
- (set-buffer buffer)
- (subprocess-command-to-buffer
- (concat "DIRECTORY " switches " " dirname)
- buffer)
- (goto-char (point-min))
- ;; Remove all the trailing blanks.
- (while (search-forward " \n")
- (forward-char -1)
- (delete-horizontal-space))
- (goto-char (point-min))))
-
-(setq dired-listing-switches
- "/SIZE/DATE/OWNER/WIDTH=(FILENAME=32,SIZE=5)")
-
-(setq print-region-function
- '(lambda (start end command ign1 ign2 ign3 &rest switches)
- (write-region start end "sys$login:delete-me.txt")
- (send-command-to-subprocess
- 1
- (concat command
- " sys$login:delete-me.txt/name=""GNUprintbuffer"" "
- (mapconcat 'identity switches " "))
- nil nil nil)))
diff --git a/lisp/vms-patch.elc b/lisp/vms-patch.elc
new file mode 100644
index 00000000000..edc94a6c4b8
--- /dev/null
+++ b/lisp/vms-patch.elc
Binary files differ
diff --git a/lisp/vmsproc.el b/lisp/vmsproc.el
index b4451a40ad0..c974f88248e 100644
--- a/lisp/vmsproc.el
+++ b/lisp/vmsproc.el
@@ -35,63 +35,37 @@
(define-key command-mode-map "\C-u" 'command-kill-line))
(defun subprocess-input (name str)
- "Handles input from a subprocess. Called by Emacs."
- (if display-subprocess-window
+ "Handles input from a subprocess. Called by Emacs."
+ (if display-subprocess-window
(display-buffer subprocess-buf))
- (let ((old-buffer (current-buffer)))
- (set-buffer subprocess-buf)
- (goto-char (point-max))
- (insert str)
- (insert ?\n)
- (set-buffer old-buffer)))
+ (let ((old-buffer (current-buffer)))
+ (set-buffer subprocess-buf)
+ (goto-char (point-max))
+ (insert str)
+ (insert ?\n)
+ (set-buffer old-buffer)))
(defun subprocess-exit (name)
- "Called by Emacs upon subprocess exit."
- (setq subprocess-running nil))
+ "Called by Emacs upon subprocess exit."
+ (setq subprocess-running nil))
(defun start-subprocess ()
- "Spawns an asynchronous subprocess with output redirected to
+ "Spawns an asynchronous subprocess with output redirected to
the buffer *COMMAND*. Within this buffer, use C-m to send
the last line to the subprocess or to bring another line to
the end."
- (if subprocess-running
- (return t))
- (setq subprocess-buf (get-buffer-create "*COMMAND*"))
- (save-excursion
- (set-buffer subprocess-buf)
- (use-local-map command-mode-map))
- (setq subprocess-running (spawn-subprocess 1 'subprocess-input
- 'subprocess-exit))
- ;; Initialize subprocess so it doesn't panic and die upon
- ;; encountering the first error.
- (and subprocess-running
- (send-command-to-subprocess 1 "ON SEVERE_ERROR THEN CONTINUE")))
-
-(defun subprocess-command-to-buffer (command buffer)
- "Execute COMMAND and redirect output into BUFFER."
- (let (cmd args)
- (setq cmd (substring command 0 (string-match " " command)))
- (setq args (substring command (string-match " " command)))
- (call-process cmd nil buffer nil "*dcl*" args)))
-;BUGS: only the output up to the end of the first image activation is trapped.
-; (if (not subprocess-running)
-; (start-subprocess))
-; (save-excursion
-; (set-buffer buffer)
-; (let ((output-filename (concat "SYS$SCRATCH:OUTPUT-FOR-"
-; (getenv "USER") ".LISTING")))
-; (while (file-exists-p output-filename)
-; (delete-file output-filename))
-; (define-logical-name "SYS$OUTPUT" (concat output-filename "-NEW"))
-; (send-command-to-subprocess 1 command)
-; (send-command-to-subprocess 1 (concat
-; "RENAME " output-filename
-; "-NEW " output-filename))
-; (while (not (file-exists-p output-filename))
-; (sleep-for 1))
-; (define-logical-name "SYS$OUTPUT" nil)
-; (insert-file output-filename)
-; (delete-file output-filename))))
+ (if subprocess-running
+ (return t))
+ (setq subprocess-buf (get-buffer-create "*COMMAND*"))
+ (save-excursion
+ (set-buffer subprocess-buf)
+ (use-local-map command-mode-map))
+ (setq subprocess-running (spawn-subprocess 1 'subprocess-input
+ 'subprocess-exit))
+ ;; Initialize subprocess so it doesn't panic and die upon
+ ;; encountering the first error.
+ (and subprocess-running
+ (send-command-to-subprocess 1 "ON SEVERE_ERROR THEN CONTINUE")))
(defun subprocess-command ()
"Starts asynchronous subprocess if not running and switches to its window."
@@ -99,7 +73,7 @@ the end."
(if (not subprocess-running)
(start-subprocess))
(and subprocess-running
- (progn (pop-to-buffer subprocess-buf) (goto-char (point-max)))))
+ (progn (pop-to-buffer subprocess-buf) (goto-char (point-max)))))
(defun command-send-input ()
"If at last line of buffer, sends the current line to
@@ -110,24 +84,24 @@ line to the last line for resubmission."
(let ((current-line (buffer-substring (point)
(progn (end-of-line) (point)))))
(if (eobp)
- (progn
- (if (not subprocess-running)
- (start-subprocess))
- (if subprocess-running
- (progn
- (beginning-of-line)
- (send-command-to-subprocess 1 current-line)
- (if command-prefix-string
- (progn (beginning-of-line) (insert command-prefix-string)))
- (next-line 1))))
+ (progn
+ (if (not subprocess-running)
+ (start-subprocess))
+ (if subprocess-running
+ (progn
+ (beginning-of-line)
+ (send-command-to-subprocess 1 current-line)
+ (if command-prefix-string
+ (progn (beginning-of-line) (insert command-prefix-string)))
+ (next-line 1))))
;; else -- if not at last line in buffer
(end-of-buffer)
(backward-char)
(next-line 1)
(if (string-equal command-prefix-string
- (substring current-line 0 (length command-prefix-string)))
+ (substring current-line 0 (length command-prefix-string)))
(insert (substring current-line (length command-prefix-string)))
- (insert current-line)))))
+ (insert current-line)))))
(defun command-kill-line()
"Kills the current line. Used in command mode."
diff --git a/lisp/vmsproc.elc b/lisp/vmsproc.elc
new file mode 100644
index 00000000000..516fcb0b505
--- /dev/null
+++ b/lisp/vmsproc.elc
Binary files differ
diff --git a/lisp/vmsx.el b/lisp/vmsx.el
deleted file mode 100644
index a68c6de3796..00000000000
--- a/lisp/vmsx.el
+++ /dev/null
@@ -1,137 +0,0 @@
-;; Run asynchronous VMS subprocesses under Emacs
-;; Copyright (C) 1986 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;; Written by Mukesh Prasad.
-
-(defvar display-subprocess-window nil
- "If non-nil, the suprocess window is displayed whenever input is received.")
-
-(defvar command-prefix-string "$ "
- "String to insert to distinguish commands entered by user.")
-
-(defvar subprocess-running nil)
-(defvar command-mode-map nil)
-
-(if command-mode-map
- nil
- (setq command-mode-map (make-sparse-keymap))
- (define-key command-mode-map "\C-m" 'command-send-input)
- (define-key command-mode-map "\C-u" 'command-kill-line))
-
-(defun subprocess-input (name str)
- "Handles input from a subprocess. Called by Emacs."
- (if display-subprocess-window
- (display-buffer subprocess-buf))
- (let ((old-buffer (current-buffer)))
- (set-buffer subprocess-buf)
- (goto-char (point-max))
- (insert str)
- (insert ?\n)
- (set-buffer old-buffer)))
-
-(defun subprocess-exit (name)
- "Called by Emacs upon subprocess exit."
- (setq subprocess-running nil))
-
-(defun start-subprocess ()
- "Spawns an asynchronous subprocess with output redirected to
-the buffer *COMMAND*. Within this buffer, use C-m to send
-the last line to the subprocess or to bring another line to
-the end."
- (if subprocess-running
- (return t))
- (setq subprocess-buf (get-buffer-create "*COMMAND*"))
- (save-excursion
- (set-buffer subprocess-buf)
- (use-local-map command-mode-map))
- (setq subprocess-running (spawn-subprocess 1 'subprocess-input
- 'subprocess-exit))
- ;; Initialize subprocess so it doesn't panic and die upon
- ;; encountering the first error.
- (and subprocess-running
- (send-command-to-subprocess 1 "ON SEVERE_ERROR THEN CONTINUE")))
-
-(defvar subprocess-command-to-buffer-tmpdir "SYS$SCRATCH:"
- "*Put temporary files from subprocess-command-to-buffer here.")
-
-(defun subprocess-command-to-buffer (command buffer)
- "Execute command and redirect output into buffer.
-
-BUGS: only the output up to the end of the first image activation is trapped."
- (if (not subprocess-running)
- (start-subprocess))
- (save-excursion
- (set-buffer buffer)
- (let ((output-filename
- (concat subprocess-command-to-buffer-tmpdir
- "OUTPUT-FOR-" (getenv "USER") ".LISTING")))
- (while (file-attributes output-filename)
- (delete-file output-filename))
- (send-command-to-subprocess 1 (concat "DEFINE/USER SYS$OUTPUT "
- output-filename "-NEW"))
- (send-command-to-subprocess 1 command)
- (send-command-to-subprocess 1 (concat "RENAME " output-filename
- "-NEW " output-filename))
- (while (not (file-attributes output-filename))
- (sleep-for 2))
- (insert-file output-filename))))
-
-(defun subprocess-command ()
- "Starts asynchronous subprocess if not running and switches to its window."
- (interactive)
- (if (not subprocess-running)
- (start-subprocess))
- (and subprocess-running
- (progn (pop-to-buffer subprocess-buf) (goto-char (point-max)))))
-
-(defun command-send-input ()
- "If at last line of buffer, sends the current line to
-the spawned subprocess. Otherwise brings back current
-line to the last line for resubmission."
- (interactive)
- (beginning-of-line)
- (let ((current-line (buffer-substring (point)
- (progn (end-of-line) (point)))))
- (if (eobp)
- (progn
- (if (not subprocess-running)
- (start-subprocess))
- (if subprocess-running
- (progn
- (beginning-of-line)
- (send-command-to-subprocess 1 current-line)
- (if command-prefix-string
- (progn (beginning-of-line) (insert command-prefix-string)))
- (next-line 1))))
- ;; else -- if not at last line in buffer
- (end-of-buffer)
- (backward-char)
- (next-line 1)
- (if (string-equal command-prefix-string
- (substring current-line 0 (length command-prefix-string)))
- (insert (substring current-line (length command-prefix-string)))
- (insert current-line)))))
-
-(defun command-kill-line()
- "Kills the current line. Used in command mode."
- (interactive)
- (beginning-of-line)
- (kill-line))
-
-(define-key esc-map "$" 'subprocess-command)
diff --git a/lisp/window.el b/lisp/window.el
index f16d8942824..ced7e20e663 100644
--- a/lisp/window.el
+++ b/lisp/window.el
@@ -1,5 +1,5 @@
;; GNU Emacs window commands aside from those written in C.
-;; Copyright (C) 1985, 1989 Free Software Foundation, Inc.
+;; Copyright (C) 1985 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
@@ -18,59 +18,12 @@
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-(defun count-windows (&optional minibuf)
- "Returns the number of visible windows.
-Optional arg NO-MINI non-nil means don't count the minibuffer
-even if it is active."
- (let ((count 0))
- (walk-windows (function (lambda ()
- (setq count (+ count 1))))
- minibuf)
- count))
-
-(defun balance-windows ()
- "Makes all visible windows the same size (approximately)."
- (interactive)
- (let ((count 0))
- (walk-windows (function (lambda (w)
- (setq count (+ count 1))))
- 'nomini)
- (let ((size (/ (screen-height) count)))
- (walk-windows (function (lambda (w)
- (select-window w)
- (enlarge-window (- size (window-height)))))
- 'nomini))))
-
(defun split-window-vertically (&optional arg)
"Split current window into two windows, one above the other.
-The uppermost window gets ARG lines and the other gets the rest.
-With no argument, split equally or close to it.
-Both windows display the same buffer now current.
-The new selected window is the one that the current value of point
-appears in.
-
-The value of point can change if the text around point
-is hidden by the new mode line."
+This window becomes the uppermost of the two, and gets
+ARG lines. No arg means split equally."
(interactive "P")
- (let ((old-w (selected-window))
- (old-point (point))
- new-w bottom switch)
- (setq new-w (split-window nil (and arg (prefix-numeric-value arg))))
- (save-excursion
- (set-buffer (window-buffer))
- (goto-char (window-start))
- (vertical-motion (window-height))
- (set-window-start new-w (point))
- (if (> (point) (window-point new-w))
- (set-window-point new-w (point)))
- (vertical-motion -1)
- (setq bottom (point)))
- (if (<= bottom (point))
- (set-window-point old-w (1- bottom)))
- (if (< (window-start new-w) old-point)
- (progn
- (set-window-point new-w old-point)
- (select-window new-w)))))
+ (split-window nil (and arg (prefix-numeric-value arg))))
(defun split-window-horizontally (&optional arg)
"Split current window into two windows side by side.
@@ -89,21 +42,7 @@ ARG columns. No arg means split equally."
(interactive "p")
(shrink-window arg t))
-(defun window-config-to-register (name)
- "Save the current window configuration in register REG (a letter).
-It can be later retrieved using \\[M-x register-to-window-config]."
- (interactive "cSave window configuration in register: ")
- (set-register name (current-window-configuration)))
-
-(defun register-to-window-config (name)
- "Restore (make current) the window configuration in register REG (a letter).
-Use with a register previously set with \\[window-config-to-register]."
- (interactive "cRestore window configuration from register: ")
- (set-window-configuration (get-register name)))
-
(define-key ctl-x-map "2" 'split-window-vertically)
(define-key ctl-x-map "5" 'split-window-horizontally)
-(define-key ctl-x-map "6" 'window-config-to-register)
-(define-key ctl-x-map "7" 'register-to-window-config)
(define-key ctl-x-map "}" 'enlarge-window-horizontally)
(define-key ctl-x-map "{" 'shrink-window-horizontally)
diff --git a/lisp/window.elc b/lisp/window.elc
new file mode 100644
index 00000000000..2aba3d72ee7
--- /dev/null
+++ b/lisp/window.elc
Binary files differ
diff --git a/lisp/x-menu.elc b/lisp/x-menu.elc
new file mode 100644
index 00000000000..b7707c57aa7
--- /dev/null
+++ b/lisp/x-menu.elc
Binary files differ
diff --git a/lisp/x-mouse.el b/lisp/x-mouse.el
new file mode 100644
index 00000000000..be201d71900
--- /dev/null
+++ b/lisp/x-mouse.el
@@ -0,0 +1,295 @@
+;; Mouse support for X window system.
+;; Copyright (C) 1985, 1987 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 1, 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+(provide 'x-mouse)
+
+(defconst x-button-right (char-to-string 0))
+(defconst x-button-middle (char-to-string 1))
+(defconst x-button-left (char-to-string 2))
+
+(defconst x-button-right-up (char-to-string 4))
+(defconst x-button-middle-up (char-to-string 5))
+(defconst x-button-left-up (char-to-string 6))
+
+(defconst x-button-s-right (char-to-string 16))
+(defconst x-button-s-middle (char-to-string 17))
+(defconst x-button-s-left (char-to-string 18))
+
+(defconst x-button-s-right-up (char-to-string 20))
+(defconst x-button-s-middle-up (char-to-string 21))
+(defconst x-button-s-left-up (char-to-string 22))
+
+(defconst x-button-m-right (char-to-string 32))
+(defconst x-button-m-middle (char-to-string 33))
+(defconst x-button-m-left (char-to-string 34))
+
+(defconst x-button-m-right-up (char-to-string 36))
+(defconst x-button-m-middle-up (char-to-string 37))
+(defconst x-button-m-left-up (char-to-string 38))
+
+(defconst x-button-c-right (char-to-string 64))
+(defconst x-button-c-middle (char-to-string 65))
+(defconst x-button-c-left (char-to-string 66))
+
+(defconst x-button-c-right-up (char-to-string 68))
+(defconst x-button-c-middle-up (char-to-string 69))
+(defconst x-button-c-left-up (char-to-string 70))
+
+(defconst x-button-m-s-right (char-to-string 48))
+(defconst x-button-m-s-middle (char-to-string 49))
+(defconst x-button-m-s-left (char-to-string 50))
+
+(defconst x-button-m-s-right-up (char-to-string 52))
+(defconst x-button-m-s-middle-up (char-to-string 53))
+(defconst x-button-m-s-left-up (char-to-string 54))
+
+(defconst x-button-c-s-right (char-to-string 80))
+(defconst x-button-c-s-middle (char-to-string 81))
+(defconst x-button-c-s-left (char-to-string 82))
+
+(defconst x-button-c-s-right-up (char-to-string 84))
+(defconst x-button-c-s-middle-up (char-to-string 85))
+(defconst x-button-c-s-left-up (char-to-string 86))
+
+(defconst x-button-c-m-right (char-to-string 96))
+(defconst x-button-c-m-middle (char-to-string 97))
+(defconst x-button-c-m-left (char-to-string 98))
+
+(defconst x-button-c-m-right-up (char-to-string 100))
+(defconst x-button-c-m-middle-up (char-to-string 101))
+(defconst x-button-c-m-left-up (char-to-string 102))
+
+(defconst x-button-c-m-s-right (char-to-string 112))
+(defconst x-button-c-m-s-middle (char-to-string 113))
+(defconst x-button-c-m-s-left (char-to-string 114))
+
+(defconst x-button-c-m-s-right-up (char-to-string 116))
+(defconst x-button-c-m-s-middle-up (char-to-string 117))
+(defconst x-button-c-m-s-left-up (char-to-string 118))
+
+(defvar x-process-mouse-hook nil
+ "Hook to run after each mouse event is processed. Should take two
+arguments; the first being a list (XPOS YPOS) corresponding to character
+offset from top left of screen and the second being a specifier for the
+buttons/keys.
+
+This will normally be set on a per-buffer basis.")
+
+(defun x-flush-mouse-queue ()
+ "Process all queued mouse events."
+ ;; A mouse event causes a special character sequence to be given
+ ;; as keyboard input. That runs this function, which process all
+ ;; queued mouse events and returns.
+ (interactive)
+ (while (> (x-mouse-events) 0)
+ (x-proc-mouse-event)
+ (and (boundp 'x-process-mouse-hook)
+ (symbol-value 'x-process-mouse-hook)
+ (funcall x-process-mouse-hook x-mouse-pos x-mouse-item))))
+
+(define-key global-map "\C-c\C-m" 'x-flush-mouse-queue)
+(define-key global-map "\C-x\C-@" 'x-flush-mouse-queue)
+
+(defun x-mouse-select (arg)
+ "Select Emacs window the mouse is on."
+ (let ((start-w (selected-window))
+ (done nil)
+ (w (selected-window))
+ (rel-coordinate nil))
+ (while (and (not done)
+ (null (setq rel-coordinate
+ (coordinates-in-window-p arg w))))
+ (setq w (next-window w))
+ (if (eq w start-w)
+ (setq done t)))
+ (select-window w)
+ rel-coordinate))
+
+(defun x-mouse-keep-one-window (arg)
+ "Select Emacs window mouse is on, then kill all other Emacs windows."
+ (if (x-mouse-select arg)
+ (delete-other-windows)))
+
+(defun x-mouse-select-and-split (arg)
+ "Select Emacs window mouse is on, then split it vertically in half."
+ (if (x-mouse-select arg)
+ (split-window-vertically nil)))
+
+(defun x-mouse-set-point (arg)
+ "Select Emacs window mouse is on, and move point to mouse position."
+ (let* ((relative-coordinate (x-mouse-select arg))
+ margin-column
+ (rel-x (car relative-coordinate))
+ (rel-y (car (cdr relative-coordinate))))
+ (if relative-coordinate
+ (let ((prompt-width (if (eq (selected-window) (minibuffer-window))
+ minibuffer-prompt-width 0)))
+ (move-to-window-line rel-y)
+ (if (eobp)
+ ;; If text ends before the desired line,
+ ;; always position at end of that line.
+ nil
+ (setq margin-column
+ (if (or truncate-lines (> (window-hscroll) 0))
+ (current-column)
+ ;; If we are using line continuation,
+ ;; compensate if first character on a continuation line
+ ;; does not start precisely at the margin.
+ (- (current-column)
+ (% (current-column) (1- (window-width))))))
+ (move-to-column (+ rel-x (1- (max 1 (window-hscroll)))
+ (if (= (point) 1)
+ (- prompt-width) 0)
+ margin-column)))))))
+
+(defun x-mouse-set-mark (arg)
+ "Select Emacs window mouse is on, and set mark at mouse position.
+Display cursor at that position for a second."
+ (if (x-mouse-select arg)
+ (let ((point-save (point)))
+ (unwind-protect
+ (progn (x-mouse-set-point arg)
+ (push-mark nil t)
+ (sit-for 1))
+ (goto-char point-save)))))
+
+(defun x-cut-text (arg &optional kill)
+ "Copy text between point and mouse position into window system cut buffer.
+Save in Emacs kill ring also."
+ (if (coordinates-in-window-p arg (selected-window))
+ (save-excursion
+ (let ((opoint (point))
+ beg end)
+ (x-mouse-set-point arg)
+ (setq beg (min opoint (point))
+ end (max opoint (point)))
+ (x-store-cut-buffer (buffer-substring beg end))
+ (copy-region-as-kill beg end)
+ (if kill (delete-region beg end))))
+ (message "Mouse not in selected window")))
+
+(defun x-paste-text (arg)
+ "Move point to mouse position and insert window system cut buffer contents."
+ (x-mouse-set-point arg)
+ (insert (x-get-cut-buffer)))
+
+(defun x-cut-and-wipe-text (arg)
+ "Kill text between point and mouse; also copy to window system cut buffer."
+ (x-cut-text arg t))
+
+(defun x-mouse-ignore (arg)
+ "Don't do anything.")
+
+(defun x-buffer-menu (arg)
+ "Pop up a menu of buffers for selection with the mouse."
+ (let ((menu
+ (list "Buffer Menu"
+ (cons "Select Buffer"
+ (let ((tail (buffer-list))
+ head)
+ (while tail
+ (let ((elt (car tail)))
+ (if (not (string-match "^ "
+ (buffer-name elt)))
+ (setq head (cons
+ (cons
+ (format
+ "%14s %s"
+ (buffer-name elt)
+ (or (buffer-file-name elt) ""))
+ elt)
+ head))))
+ (setq tail (cdr tail)))
+ (reverse head))))))
+ (switch-to-buffer (or (x-popup-menu arg menu) (current-buffer)))))
+
+(defun x-help (arg)
+ "Enter a menu-based help system."
+ (let ((selection
+ (x-popup-menu
+ arg
+ '("Help" ("Is there a command that..."
+ ("Command apropos" . command-apropos)
+ ("Apropos" . apropos))
+ ("Key Commands <==> Functions"
+ ("List all keystroke commands" . describe-bindings)
+ ("Describe key briefly" . describe-key-briefly)
+ ("Describe key verbose" . describe-key)
+ ("Describe Lisp function" . describe-function)
+ ("Where is this command" . where-is))
+ ("Manual and tutorial"
+ ("Info system" . info)
+ ("Invoke Emacs tutorial" . help-with-tutorial))
+ ("Odds and ends"
+ ("Last 100 Keystrokes" . view-lossage)
+ ("Describe syntax table" . describe-syntax))
+ ("Modes"
+ ("Describe current major mode" . describe-mode)
+ ("List all keystroke commands" . describe-bindings))
+ ("Administrivia"
+ ("View Emacs news" . view-emacs-news)
+ ("View the GNU Emacs license" . describe-copying)
+ ("Describe distribution" . describe-distribution)
+ ("Describe (non)warranty" . describe-no-warranty))))))
+ (and selection (call-interactively selection))))
+
+; Prevent beeps on button-up. If the button isn't bound to anything, it
+; will beep on button-down.
+(define-key mouse-map x-button-right-up 'x-mouse-ignore)
+(define-key mouse-map x-button-middle-up 'x-mouse-ignore)
+(define-key mouse-map x-button-left-up 'x-mouse-ignore)
+(define-key mouse-map x-button-s-right-up 'x-mouse-ignore)
+(define-key mouse-map x-button-s-middle-up 'x-mouse-ignore)
+(define-key mouse-map x-button-s-left-up 'x-mouse-ignore)
+(define-key mouse-map x-button-m-right-up 'x-mouse-ignore)
+(define-key mouse-map x-button-m-middle-up 'x-mouse-ignore)
+(define-key mouse-map x-button-m-left-up 'x-mouse-ignore)
+(define-key mouse-map x-button-c-right-up 'x-mouse-ignore)
+(define-key mouse-map x-button-c-middle-up 'x-mouse-ignore)
+(define-key mouse-map x-button-c-left-up 'x-mouse-ignore)
+(define-key mouse-map x-button-m-s-right-up 'x-mouse-ignore)
+(define-key mouse-map x-button-m-s-middle-up 'x-mouse-ignore)
+(define-key mouse-map x-button-m-s-left-up 'x-mouse-ignore)
+(define-key mouse-map x-button-c-s-right-up 'x-mouse-ignore)
+(define-key mouse-map x-button-c-s-middle-up 'x-mouse-ignore)
+(define-key mouse-map x-button-c-s-left-up 'x-mouse-ignore)
+(define-key mouse-map x-button-c-m-right-up 'x-mouse-ignore)
+(define-key mouse-map x-button-c-m-middle-up 'x-mouse-ignore)
+(define-key mouse-map x-button-c-m-left-up 'x-mouse-ignore)
+(define-key mouse-map x-button-c-m-s-right-up 'x-mouse-ignore)
+(define-key mouse-map x-button-c-m-s-middle-up 'x-mouse-ignore)
+(define-key mouse-map x-button-c-m-s-left-up 'x-mouse-ignore)
+
+(define-key mouse-map x-button-c-s-left 'x-buffer-menu)
+(define-key mouse-map x-button-c-s-middle 'x-help)
+(define-key mouse-map x-button-c-s-right 'x-mouse-keep-one-window)
+(define-key mouse-map x-button-s-middle 'x-cut-text)
+(define-key mouse-map x-button-s-right 'x-paste-text)
+(define-key mouse-map x-button-c-middle 'x-cut-and-wipe-text)
+(define-key mouse-map x-button-c-right 'x-mouse-select-and-split)
+
+(if (= window-system-version 10)
+ (progn
+ (define-key mouse-map x-button-right 'x-mouse-select)
+ (define-key mouse-map x-button-left 'x-mouse-set-mark)
+ (define-key mouse-map x-button-middle 'x-mouse-set-point))
+ (define-key mouse-map x-button-right 'x-cut-text)
+ (define-key mouse-map x-button-left 'x-mouse-set-point)
+ (define-key mouse-map x-button-middle 'x-paste-text))
diff --git a/lisp/x-mouse.elc b/lisp/x-mouse.elc
new file mode 100644
index 00000000000..669405d302d
--- /dev/null
+++ b/lisp/x-mouse.elc
Binary files differ
diff --git a/lisp/xscheme.el b/lisp/xscheme.el
index 8a281cd0cf9..d8fd3d76b25 100644
--- a/lisp/xscheme.el
+++ b/lisp/xscheme.el
@@ -1,5 +1,5 @@
;; Run Scheme under Emacs
-;; Copyright (C) 1986, 1987, 1989, 1990 Free Software Foundation, Inc.
+;; Copyright (C) 1986, 1987, 1989 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
@@ -20,7 +20,7 @@
;;; Requires C-Scheme release 5 or later
;;; Changes to Control-G handler require runtime version 13.85 or later
-;;; $Header: xscheme.el,v 1.26 90/09/11 01:51:20 GMT cph Exp $
+;;; $Header: xscheme.el,v 1.23 89/04/28 22:59:40 GMT cph Rel $
(require 'scheme)
@@ -176,15 +176,13 @@ Blank lines separate paragraphs. Semicolons start comments.
\\{scheme-interaction-mode-map}
Entry to this mode calls the value of scheme-interaction-mode-hook
-with no args, if that value is non-nil.
- Likewise with the value of scheme-mode-hook.
- scheme-interaction-mode-hook is called after scheme-mode-hook."
+with no args, if that value is non-nil."
(interactive)
(kill-all-local-variables)
(scheme-interaction-mode-initialize)
(scheme-mode-variables)
(make-local-variable 'xscheme-previous-send)
- (run-hooks 'scheme-mode-hook 'scheme-interaction-mode-hook))
+ (run-hooks 'scheme-interaction-mode-hook))
(defun scheme-interaction-mode-initialize ()
(use-local-map scheme-interaction-mode-map)
@@ -678,8 +676,6 @@ When called, the current buffer will be the Scheme process-buffer.")
(defvar xscheme-process-filter-alist
'((?D xscheme-enter-debugger-mode
xscheme-process-filter:string-action)
- (?E xscheme-eval
- xscheme-process-filter:string-action)
(?P xscheme-set-prompt-variable
xscheme-process-filter:string-action)
(?R xscheme-enter-interaction-mode
@@ -774,9 +770,6 @@ the remaining input.")
(defun xscheme-unsolicited-read-char ()
nil)
-(defun xscheme-eval (string)
- (eval (car (read-from-string string))))
-
(defun xscheme-message (string)
(if (not (zerop (length string)))
(xscheme-write-message-1 string (format ";%s" string))))
diff --git a/lisp/xscheme.elc b/lisp/xscheme.elc
new file mode 100644
index 00000000000..3594cd13c8d
--- /dev/null
+++ b/lisp/xscheme.elc
Binary files differ
diff --git a/lisp/play/yow.el b/lisp/yow.el
index e574b4fa906..0890144d0e6 100644
--- a/lisp/play/yow.el
+++ b/lisp/yow.el
@@ -1,4 +1,4 @@
-;; Copyright (C) 1985, 1987 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1987 Free Software Foundation
;; This file is part of GNU Emacs.
@@ -16,8 +16,6 @@
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-(provide 'yow)
-
; Randomize the seed in the random number generator.
(random t)
@@ -26,19 +24,22 @@
; (ie strings terminated by ascii 0 characters. Leading whitespace ignored)
; Everything up to the first \000 is a comment.
(defun yow (&optional n interactive)
- "Return or display a Zippy quotation."
- (interactive "P\np")
+ "Return or display a Zippy quotation"
+ (interactive
+ (if current-prefix-arg
+ (list (prefix-numeric-value current-prefix-arg) t)
+ (list nil t)))
(if (null yow-vector)
(setq yow-vector (snarf-yows)))
- (cond (n (setq n (prefix-numeric-value n)))
- ((>= (setq n (random (length yow-vector))) 0))
+ (cond (n)
+ ((>= (setq n (% (random) (length yow-vector))) 0))
(t (setq n (- n))))
(let ((yow (aref yow-vector n)))
(cond ((not interactive)
yow)
((not (string-match "\n" yow))
(delete-windows-on (get-buffer-create "*Help*"))
- (message "%s" yow))
+ (message yow))
(t
(message "Yow!")
(with-output-to-temp-buffer "*Help*"
diff --git a/lisp/yow.elc b/lisp/yow.elc
new file mode 100644
index 00000000000..a9811121404
--- /dev/null
+++ b/lisp/yow.elc
Binary files differ