+++ /dev/null
-This file describes various problems that have been encountered
-in compiling, installing and running GNU Emacs.
-
-* `Pid xxx killed due to text modification or page I/O error'
-
-On HP/UX, you can get that error when the Emacs executable is on an NFS
-file system. HP/UX responds this way if it tries to swap in a page and
-does not get a response from the server within a timeout whose default
-value is just ten seconds.
-
-If this happens to you, extend the timeout period.
-
-* `expand-file-name' fails to work on any but the machine you dumped Emacs on.
-
-On Ultrix, if you use any of the functions which look up information
-in the passwd database before dumping Emacs (say, by using
-expand-file-name in site-init.el), then those functions will not work
-in the dumped Emacs on any host but the one Emacs was dumped on.
-
-The solution? Don't use expand-file-name in site-init.el, or in
-anything it loads. Yuck - some solution.
-
-I'm not sure why this happens; if you can find out exactly what is
-going on, and perhaps find a fix or a workaround, please let us know.
-Perhaps the YP functions cache some information, the cache is included
-in the dumped Emacs, and is then inaccurate on any other host.
-
-* On some variants of SVR4, Emacs does not work at all with X.
-
-Try defining BROKEN_FIONREAD in your config.h file. If this solves
-the problem, please send a bug report to tell us this is needed; be
-sure to say exactly what type of machine and system you are using.
-
-* Linking says that the functions insque and remque are undefined.
-
-Change oldXMenu/Makefile by adding insque.o to the variable OBJS.
-
-* Emacs fails to understand most Internet host names, even though
-the names work properly with other programs on the same system.
-
-This typically happens on Suns and other systems that use shared
-libraries. The cause is that the site has installed a version of the
-shared library which uses a name server--but has not installed a
-similar version of the unshared library which Emacs uses.
-
-The result is that most programs, using the shared library, work with
-the nameserver, but Emacs does not.
-
-The fix is to install an unshared library that corresponds to what you
-installed in the shared library, and then relink Emacs.
-
-* On a Sun running SunOS 4.1.1, you get this error message from GNU ld:
-
- /lib/libc.a(_Q_sub.o): Undefined symbol __Q_get_rp_rd referenced from text segment
-
-The problem is in the Sun shared C library, not in GNU ld.
-
-The solution is to install Patch-ID# 100267-03 from Sun.
-
-* Self documentation messages are garbled.
-
-This means that the file `etc/DOC-...' doesn't properly correspond
-with the Emacs executable. Redumping Emacs and then installing the
-corresponding pair of files should fix the problem.
-
-* Trouble using ptys on AIX.
-
-People often install the pty devices on AIX incorrectly.
-Use `smit pty' to reinstall them properly.
-
-* Shell mode on HP/UX gives the message, "`tty`: Ambiguous".
-
-christos@theory.tn.cornell.edu says:
-
-The problem is that in your .cshrc you have something that tries to
-execute `tty`. If you are not running the shell on a real tty then
-tty will print "not a tty". Csh expects one word in some places,
-but tty is giving it back 3.
-
-The solution is to add a pair of quotes around `tty` to make it a single
-word:
-
-if (`tty` == "/dev/console")
-
-should be changed to:
-
-if ("`tty`" == "/dev/console")
-
-Even better, move things that set up terminal sections out of .cshrc
-and into .login.
-
-* Using X Windows, control-shift-leftbutton makes Emacs hang.
-
-Use the shell command `xset bc' to make the old X Menu package work.
-
-* Emacs running under X Windows does not handle mouse clicks.
-* `emacs -geometry 80x20' finds a file named `80x20'.
-
-One cause of such problems is having (setq term-file-prefix nil) in
-your .emacs file. Another cause is a bad value of EMACSLOADPATH in
-the environment.
-
-* Emacs starts in a directory other than the one that is current in the shell.
-
-If the PWD environment variable exists, Emacs uses this variable as
-the initial working directory.
-
-Some shells automatically update this variable, while other shells fail
-to do so. If you use two such shells in combination, the variable can
-end up wrong. This confuses Emacs.
-
-The solution is to put something in the start-up file for the shell
-that does not update PWD, to get rid of that environment variable.
-For example, in csh, use `unsetenv PWD'.
-
-* Emacs gets error message from linker on Sun.
-
-If the error message says that a symbol such as `f68881_used' or
-`ffpa_used' or `start_float' is undefined, this probably indicates
-that you have compiled some libraries, such as the X libraries,
-with a floating point option other than the default.
-
-It's not terribly hard to make this work with small changes in
-crt0.c together with linking with Fcrt1.o, Wcrt1.o or Mcrt1.o.
-However, the easiest approach is to build Xlib with the default
-floating point option: -fsoft.
-
-* Emacs fails to get default settings from X Windows server.
-
-The X library in X11R4 has a bug; it interchanges the 2nd and 3rd
-arguments to XGetDefaults. Define the macro XBACKWARDS in config.h to
-tell Emacs to compensate for this.
-
-I don't believe there is any way Emacs can determine for itself
-whether this problem is present on a given system.
-
-* Keyboard input gets confused after a beep when using a DECserver
- as a concentrator.
-
-This problem seems to be a matter of configuring the DECserver to use
-7 bit characters rather than 8 bit characters.
-
-* M-x shell persistently reports "Process shell exited abnormally with code 1".
-
-This happened on Suns as a result of what is said to be a bug in Sunos
-version 4.0.x. The only fix was to reboot the machine.
-
-* Programs running under terminal emulator do not recognize `emacs'
- terminal type.
-
-The cause of this is a shell startup file that sets the TERMCAP
-environment variable. The terminal emulator uses that variable to
-provide the information on the special terminal type that Emacs
-emulates.
-
-Rewrite your shell startup file so that it does not change TERMCAP
-in such a case. You could use the following conditional which sets
-it only if it is undefined.
-
- if ( ! ${?TERMCAP} ) setenv TERMCAP ~/my-termcap-file
-
-Or you could set TERMCAP only when you set TERM--which should not
-happen in a non-login shell.
-
-* X Windows doesn't work if DISPLAY uses a hostname.
-
-People have reported kernel bugs in certain systems that cause Emacs
-not to work with X Windows if DISPLAY is set using a host name. But
-the problem does not occur if DISPLAY is set to `unix:0.0'. I think
-the bug has to do with SIGIO or FIONREAD.
-
-You may be able to compensate for the bug by doing (set-input-mode nil nil).
-However, that has the disadvantage of turning off interrupts, so that
-you are unable to quit out of a Lisp program by typing C-g.
-
-The easy way to do this is to put
-
- (setq x-sigio-bug t)
-
-in your site-init.el file.
-
-* Problem with remote X server on Suns.
-
-On a Sun, running Emacs on one machine with the X server on another
-may not work if you have used the unshared system libraries. This
-is because the unshared libraries fail to use YP for host name lookup.
-As a result, the host name you specify may not be recognized.
-
-* Watch out for .emacs files and EMACSLOADPATH environment vars
-
-These control the actions of Emacs.
-~/.emacs is your Emacs init file.
-EMACSLOADPATH overrides which directories the function
-"load" will search.
-
-If you observe strange problems, check for these and get rid
-of them, then try again.
-
-* Shell mode ignores interrupts on Apollo Domain
-
-You may find that M-x shell prints the following message:
-
- Warning: no access to tty; thus no job control in this shell...
-
-This can happen if there are not enough ptys on your system.
-Here is how to make more of them.
-
- % cd /dev
- % ls pty*
- # shows how many pty's you have. I had 8, named pty0 to pty7)
- % /etc/crpty 8
- # creates eight new pty's
-
-* Fatal signal in the command temacs -l loadup inc dump
-
-This command is the final stage of building Emacs. It is run by the
-Makefile in the src subdirectory, or by build.com on VMS.
-
-It has been known to get fatal errors due to insufficient swapping
-space available on the machine.
-
-On 68000's, it has also happened because of bugs in the
-subroutine `alloca'. Verify that `alloca' works right, even
-for large blocks (many pages).
-
-* test-distrib says that the distribution has been clobbered
-* or, temacs prints "Command key out of range 0-127"
-* or, temacs runs and dumps xemacs, but xemacs totally fails to work.
-* or, temacs gets errors dumping xemacs
-
-This can be because the .elc files have been garbled. Do not be
-fooled by the fact that most of a .elc file is text: these are
-binary files and can contain all 256 byte values.
-
-In particular `shar' cannot be used for transmitting GNU Emacs.
-It typically truncates "lines". What appear to be "lines" in
-a binary file can of course be of any length. Even once `shar'
-itself is made to work correctly, `sh' discards null characters
-when unpacking the shell archive.
-
-I have also seen character \177 changed into \377. I do not know
-what transfer means caused this problem. Various network
-file transfer programs are suspected of clobbering the high bit.
-
-If you have a copy of Emacs that has been damaged in its
-nonprinting characters, you can fix them:
-
- 1) Record the names of all the .elc files.
- 2) Delete all the .elc files.
- 3) Recompile alloc.c with a value of PURESIZE twice as large.
- You might as well save the old alloc.o.
- 4) Remake xemacs. It should work now.
- 5) Running xemacs, do Meta-x byte-compile-file repeatedly
- to recreate all the .elc files that used to exist.
- You may need to increase the value of the variable
- max-lisp-eval-depth to succeed in running the compiler interpreted
- on certain .el files. 400 was sufficient as of last report.
- 6) Reinstall the old alloc.o (undoing changes to alloc.c if any)
- and remake temacs.
- 7) Remake xemacs. It should work now, with valid .elc files.
-
-* temacs prints "Pure Lisp storage exhausted"
-
-This means that the Lisp code loaded from the .elc and .el
-files during temacs -l loadup inc dump took up more
-space than was allocated.
-
-This could be caused by
- 1) adding code to the preloaded Lisp files
- 2) adding more preloaded files in loadup.el
- 3) having a site-init.el or site-load.el which loads files.
- Note that ANY site-init.el or site-load.el is nonstandard;
- if you have received Emacs from some other site
- and it contains a site-init.el or site-load.el file, consider
- deleting that file.
- 4) getting the wrong .el or .elc files
- (not from the directory you expected).
- 5) deleting some .elc files that are supposed to exist.
- This would cause the source files (.el files) to be
- loaded instead. They take up more room, so you lose.
- 6) a bug in the Emacs distribution which underestimates
- the space required.
-
-If the need for more space is legitimate, change the definition
-of PURESIZE in puresize.h.
-
-But in some of the cases listed above, this problem is a consequence
-of something else that is wrong. Be sure to check and fix the real
-problem.
-
-* Changes made to .el files do not take effect.
-
-You may have forgotten to recompile them into .elc files.
-Then the old .elc files will be loaded, and your changes
-will not be seen. To fix this, do M-x byte-recompile-directory
-and specify the directory that contains the Lisp files.
-
-Emacs should print a warning when loading a .elc file which is older
-than the corresponding .el file.
-
-* The dumped Emacs (xemacs) crashes when run, trying to write pure data.
-
-Two causes have been seen for such problems.
-
-1) On a system where getpagesize is not a system call, it is defined
-as a macro. If the definition (in both unexec.c and malloc.c) is wrong,
-it can cause problems like this. You might be able to find the correct
-value in the man page for a.out (5).
-
-2) Some systems allocate variables declared static among the
-initialized variables. Emacs makes all initialized variables in most
-of its files pure after dumping, but the variables declared static and
-not initialized are not supposed to be pure. On these systems you
-may need to add "#define static" to the m- or the s- file.
-
-* Compilation errors on VMS.
-
-You will get warnings when compiling on VMS because there are
-variable names longer than 32 (or whatever it is) characters.
-This is not an error. Ignore it.
-
-VAX C does not support #if defined(foo). Uses of this construct
-were removed, but some may have crept back in. They must be rewritten.
-
-There is a bug in the C compiler which fails to sign extend characters
-in conditional expressions. The bug is:
- char c = -1, d = 1;
- int i;
-
- i = d ? c : d;
-The result is i == 255; the fix is to typecast the char in the
-conditional expression as an (int). Known occurrences of such
-constructs in Emacs have been fixed.
-
-* rmail gets error getting new mail
-
-rmail gets new mail from /usr/spool/mail/$USER using a program
-called `movemail'. This program interlocks with /bin/mail using
-the protocol defined by /bin/mail.
-
-There are two different protocols in general use. One of them uses
-the `flock' system call. The other involves creating a lock file;
-`movemail' must be able to write in /usr/spool/mail in order to do
-this. You control which one is used by defining, or not defining,
-the macro MAIL_USE_FLOCK in config.h or the m- or s- file it includes.
-IF YOU DON'T USE THE FORM OF INTERLOCKING THAT IS NORMAL ON YOUR
-SYSTEM, YOU CAN LOSE MAIL!
-
-If your system uses the lock file protocol, and fascist restrictions
-prevent ordinary users from writing the lock files in /usr/spool/mail,
-you may need to make `movemail' setgid to a suitable group such as
-`mail'. You can use these commands (as root):
-
- chgrp mail movemail
- chmod 2755 movemail
-
-* Emacs won't work with X-windows if the value of DISPLAY is HOSTNAME:0.
-* GNUs can't make contact with the specified host for nntp.
-
-Some people have found that Emacs was unable to connect to the local
-host by name, as in DISPLAY=prep:0 if you are running on prep, but
-could handle DISPLAY=unix:0. Here is what tale@rpi.edu said:
-
- Seems as
- though gethostbyname was bombing somewhere along the way. Well, we
- had just upgrade from SunOS 3.5 (which X11 was built under) to SunOS
- 4.0.1. Any new X applications which tried to be built with the pre
- OS-upgrade libraries had the same problems which Emacs was having.
- Missing /etc/resolv.conf for a little while (when one of the libraries
- was built?) also might have had a hand in it.
-
- The result of all of this (with some speculation) was that we rebuilt
- X and then rebuilt Emacs with the new libraries. Works as it should
- now. Hoorah.
-
-If you have already installed the name resolver in the file libresolv.a,
-then you need to compile Emacs to use that library. The easiest way to
-do this is to add to config.h a definition of LIBS_SYSTEM, LIBS_MACHINE
-or LIB_STANDARD which uses -lresolv. Watch out! If you redefine a macro
-that is already in use in your configuration to supply some other libraries,
-be careful not to lose the others.
-
-Thus, you could start by adding this to config.h:
-
-#define LIBS_SYSTEM -lresolv
-
-Then if this gives you an error for redefining a macro, and you see that
-the s- file defines LIBS_SYSTEM as -lfoo -lbar, you could change config.h
-again to say this:
-
-#define LIBS_SYSTEM -lresolv -lfoo -lbar
-
-* Emacs spontaneously displays "I-search: " at the bottom of the screen.
-
-This means that Control-S/Control-Q "flow control" is being used.
-C-s/C-q flow control is bad for Emacs editors because it takes away
-C-s and C-q as user commands. Since editors do not output long streams
-of text without user commands, there is no need for a user-issuable
-"stop output" command in an editor; therefore, a properly designed
-flow control mechanism would transmit all possible input characters
-without interference. Designing such a mechanism is easy, for a person
-with at least half a brain.
-
-There are three possible reasons why flow control could be taking place:
-
- 1) Terminal has not been told to disable flow control
- 2) Insufficient padding for the terminal in use
- 3) Some sort of terminal concentrator or line switch is responsible
-
-First of all, many terminals have a set-up mode which controls
-whether they generate flow control characters. This must be
-set to "no flow control" in order for Emacs to work. Sometimes
-there is an escape sequence that the computer can send to turn
-flow control off and on. If so, perhaps the termcap `ti' string
-should turn flow control off, and the `te' string should turn it on.
-
-Once the terminal has been told "no flow control", you may find it
-needs more padding. The amount of padding Emacs sends is controlled
-by the termcap entry for the terminal in use, and by the output baud
-rate as known by the kernel. The shell command `stty' will print
-your output baud rate; `stty' with suitable arguments will set it if
-it is wrong. Setting to a higher speed causes increased padding. If
-the results are wrong for the correct speed, there is probably a
-problem in the termcap entry. You must speak to a local Unix wizard
-to fix this. Perhaps you are just using the wrong terminal type.
-
-For terminals that lack a "no flow control" mode, sometimes just
-giving lots of padding will prevent actual generation of flow control
-codes. You might as well try it.
-
-If you are really unlucky, your terminal is connected to the computer
-through a concentrator which sends flow control to the computer, or it
-insists on sending flow control itself no matter how much padding you
-give it. You are screwed! You should replace the terminal or
-concentrator with a properly designed one. In the mean time,
-some drastic measures can make Emacs semi-work.
-
-One drastic measure to ignore C-s and C-q, while sending enough
-padding that the terminal will not really lose any output. To make
-such an adjustment, you need only invoke the function
-enable-flow-control-on with a list of terminal types in your own
-.emacs file. As arguments, give it the names of one or more terminal
-types you use which require flow control adjustments.
-Here's an example:
-
-(enable-flow-control-on "vt200" "vt300" "vt101" "vt131")
-
-An even more drastic measure is to make Emacs use flow control.
-To do this, evaluate the Lisp expression (set-input-mode nil t).
-Emacs will then interpret C-s and C-q as flow control commands. (More
-precisely, it will allow the kernel to do so as it usually does.) You
-will lose the ability to use them for Emacs commands. Also, as a
-consequence of using CBREAK mode, the terminal's Meta-key, if any,
-will not work, and C-g will be liable to cause a loss of output which
-will produce garbage on the screen. (These problems apply to 4.2BSD;
-they may not happen in 4.3 or VMS, and I don't know what would happen
-in sysV.) You can use keyboard-translate-table, as shown above,
-to map two other input characters (such as C-^ and C-\) into C-s and
-C-q, so that you can still search and quote.
-
-I have no intention of ever redesigning the Emacs command set for
-the assumption that terminals use C-s/C-q flow control. This
-flow control technique is a bad design, and terminals that need
-it are bad merchandise and should not be purchased. If you can
-get some use out of GNU Emacs on inferior terminals, I am glad,
-but I will not make Emacs worse for properly designed systems
-for the sake of inferior systems.
-
-* Control-S and Control-Q commands are ignored completely.
-
-For some reason, your system is using brain-damaged C-s/C-q flow
-control despite Emacs's attempts to turn it off. Perhaps your
-terminal is connected to the computer through a concentrator
-that wants to use flow control.
-
-You should first try to tell the concentrator not to use flow control.
-If you succeed in this, try making the terminal work without
-flow control, as described in the preceding section.
-
-If that line of approach is not successful, map some other characters
-into C-s and C-q using keyboard-translate-table. The example above
-shows how to do this with C-^ and C-\.
-
-* Control-S and Control-Q commands are ignored completely on a net connection.
-
-Some versions of rlogin (and possibly telnet) do not pass flow
-control characters to the remote system to which they connect.
-On such systems, emacs on the remote system cannot disable flow
-control on the local system.
-
-One way to cure this is to disable flow control on the local host
-(the one running rlogin, not the one running rlogind) using the
-stty command, before starting the rlogin process. On many systems,
-"stty start u stop u" will do this.
-
-Some versions of tcsh will prevent even this from working. One way
-around this is to start another shell before starting rlogin, and
-issue the stty command to disable flow control from that shell.
-
-* Screen is updated wrong, but only on one kind of terminal.
-
-This could mean that the termcap entry you are using for that
-terminal is wrong, or it could mean that Emacs has a bug handing
-the combination of features specified for that terminal.
-
-The first step in tracking this down is to record what characters
-Emacs is sending to the terminal. Execute the Lisp expression
-(open-termscript "./emacs-script") to make Emacs write all
-terminal output into the file ~/emacs-script as well; then do
-what makes the screen update wrong, and look at the file
-and decode the characters using the manual for the terminal.
-There are several possibilities:
-
-1) The characters sent are correct, according to the terminal manual.
-
-In this case, there is no obvious bug in Emacs, and most likely you
-need more padding, or possibly the terminal manual is wrong.
-
-2) The characters sent are incorrect, due to an obscure aspect
- of the terminal behavior not described in an obvious way
- by termcap.
-
-This case is hard. It will be necessary to think of a way for
-Emacs to distinguish between terminals with this kind of behavior
-and other terminals that behave subtly differently but are
-classified the same by termcap; or else find an algorithm for
-Emacs to use that avoids the difference. Such changes must be
-tested on many kinds of terminals.
-
-3) The termcap entry is wrong.
-
-See the file etc/TERMS for information on changes
-that are known to be needed in commonly used termcap entries
-for certain terminals.
-
-4) The characters sent are incorrect, and clearly cannot be
- right for any terminal with the termcap entry you were using.
-
-This is unambiguously an Emacs bug, and can probably be fixed
-in termcap.c, tparam.c, term.c, scroll.c, cm.c or dispnew.c.
-
-* Output from Control-V is slow.
-
-On many bit-map terminals, scrolling operations are fairly slow.
-Often the termcap entry for the type of terminal in use fails
-to inform Emacs of this. The two lines at the bottom of the screen
-before a Control-V command are supposed to appear at the top after
-the Control-V command. If Emacs thinks scrolling the lines is fast,
-it will scroll them to the top of the screen.
-
-If scrolling is slow but Emacs thinks it is fast, the usual reason is
-that the termcap entry for the terminal you are using does not
-specify any padding time for the `al' and `dl' strings. Emacs
-concludes that these operations take only as much time as it takes to
-send the commands at whatever line speed you are using. You must
-fix the termcap entry to specify, for the `al' and `dl', as much
-time as the operations really take.
-
-Currently Emacs thinks in terms of serial lines which send characters
-at a fixed rate, so that any operation which takes time for the
-terminal to execute must also be padded. With bit-map terminals
-operated across networks, often the network provides some sort of
-flow control so that padding is never needed no matter how slow
-an operation is. You must still specify a padding time if you want
-Emacs to realize that the operation takes a long time. This will
-cause padding characters to be sent unnecessarily, but they do
-not really cost much. They will be transmitted while the scrolling
-is happening and then discarded quickly by the terminal.
-
-Most bit-map terminals provide commands for inserting or deleting
-multiple lines at once. Define the `AL' and `DL' strings in the
-termcap entry to say how to do these things, and you will have
-fast output without wasted padding characters. These strings should
-each contain a single %-spec saying how to send the number of lines
-to be scrolled. These %-specs are like those in the termcap
-`cm' string.
-
-You should also define the `IC' and `DC' strings if your terminal
-has a command to insert or delete multiple characters. These
-take the number of positions to insert or delete as an argument.
-
-A `cs' string to set the scrolling region will reduce the amount
-of motion you see on the screen when part of the screen is scrolled.
-
-* Your Delete key sends a Backspace to the terminal, using an AIXterm.
-
-The solution is to include in your .Xdefaults the lines:
-
- *aixterm.Translations: #override <Key>BackSpace: string(0x7f)
- aixterm*ttyModes: erase ^?
-
-This makes your Backspace key send DEL (ASCII 127).
-
-* You type Control-H (Backspace) expecting to delete characters.
-
-Put `stty dec' in your .login file and your problems will disappear
-after a day or two.
-
-The choice of Backspace for erasure was based on confusion, caused by
-the fact that backspacing causes erasure (later, when you type another
-character) on most display terminals. But it is a mistake. Deletion
-of text is not the same thing as backspacing followed by failure to
-overprint. I do not wish to propagate this confusion by conforming
-to it.
-
-For this reason, I believe `stty dec' is the right mode to use,
-and I have designed Emacs to go with that. If there were a thousand
-other control characters, I would define Control-h to delete as well;
-but there are not very many other control characters, and I think
-that providing the most mnemonic possible Help character is more
-important than adapting to people who don't use `stty dec'.
-
-If you are obstinate about confusing buggy overprinting with deletion,
-you can redefine Backspace in your .emacs file:
- (global-set-key "\b" 'delete-backward-char)
-You may then wish to put the function help-command on some
-other key. I leave to you the task of deciding which key.
-
-* Editing files through RFS gives spurious "file has changed" warnings.
-It is possible that a change in Emacs 18.37 gets around this problem,
-but in case not, here is a description of how to fix the RFS bug that
-causes it.
-
- There was a serious pair of bugs in the handling of the fsync() system
- call in the RFS server.
-
- The first is that the fsync() call is handled as another name for the
- close() system call (!!). It appears that fsync() is not used by very
- many programs; Emacs version 18 does an fsync() before closing files
- to make sure that the bits are on the disk.
-
- This is fixed by the enclosed patch to the RFS server.
-
- The second, more serious problem, is that fsync() is treated as a
- non-blocking system call (i.e., it's implemented as a message that
- gets sent to the remote system without waiting for a reply). Fsync is
- a useful tool for building atomic file transactions. Implementing it
- as a non-blocking RPC call (when the local call blocks until the sync
- is done) is a bad idea; unfortunately, changing it will break the RFS
- protocol. No fix was supplied for this problem.
-
- (as always, your line numbers may vary)
-
- % rcsdiff -c -r1.2 serversyscall.c
- RCS file: RCS/serversyscall.c,v
- retrieving revision 1.2
- diff -c -r1.2 serversyscall.c
- *** /tmp/,RCSt1003677 Wed Jan 28 15:15:02 1987
- --- serversyscall.c Wed Jan 28 15:14:48 1987
- ***************
- *** 163,169 ****
- /*
- * No return sent for close or fsync!
- */
- ! if (syscall == RSYS_close || syscall == RSYS_fsync)
- proc->p_returnval = deallocate_fd(proc, msg->m_args[0]);
- else
- {
- --- 166,172 ----
- /*
- * No return sent for close or fsync!
- */
- ! if (syscall == RSYS_close)
- proc->p_returnval = deallocate_fd(proc, msg->m_args[0]);
- else
- {
-
-* Vax C compiler bugs affecting Emacs.
-
-You may get one of these problems compiling Emacs:
-
- foo.c line nnn: compiler error: no table entry for op STASG
- foo.c: fatal error in /lib/ccom
-
-These are due to bugs in the C compiler; the code is valid C.
-Unfortunately, the bugs are unpredictable: the same construct
-may compile properly or trigger one of these bugs, depending
-on what else is in the source file being compiled. Even changes
-in header files that should not affect the file being compiled
-can affect whether the bug happens. In addition, sometimes files
-that compile correctly on one machine get this bug on another machine.
-
-As a result, it is hard for me to make sure this bug will not affect
-you. I have attempted to find and alter these constructs, but more
-can always appear. However, I can tell you how to deal with it if it
-should happen. The bug comes from having an indexed reference to an
-array of Lisp_Objects, as an argument in a function call:
- Lisp_Object *args;
- ...
- ... foo (5, args[i], ...)...
-putting the argument into a temporary variable first, as in
- Lisp_Object *args;
- Lisp_Object tem;
- ...
- tem = args[i];
- ... foo (r, tem, ...)...
-causes the problem to go away.
-The `contents' field of a Lisp vector is an array of Lisp_Objects,
-so you may see the problem happening with indexed references to that.
-
-* 68000 C compiler problems
-
-Various 68000 compilers have different problems.
-These are some that have been observed.
-
-** Using value of assignment expression on union type loses.
-This means that x = y = z; or foo (x = z); does not work
-if x is of type Lisp_Object.
-
-** "cannot reclaim" error.
-
-This means that an expression is too complicated. You get the correct
-line number in the error message. The code must be rewritten with
-simpler expressions.
-
-** XCONS, XSTRING, etc macros produce incorrect code.
-
-If temacs fails to run at all, this may be the cause.
-Compile this test program and look at the assembler code:
-
-struct foo { char x; unsigned int y : 24; };
-
-lose (arg)
- struct foo arg;
-{
- test ((int *) arg.y);
-}
-
-If the code is incorrect, your compiler has this problem.
-In the XCONS, etc., macros in lisp.h you must replace (a).u.val with
-((a).u.val + coercedummy) where coercedummy is declared as int.
-
-This problem will not happen if the m-...h file for your type
-of machine defines NO_UNION_TYPE. That is the recommended setting now.
-
-* C compilers lose on returning unions
-
-I hear that some C compilers cannot handle returning a union type.
-Most of the functions in GNU Emacs return type Lisp_Object, which is
-defined as a union on some rare architectures.
-
-This problem will not happen if the m-...h file for your type
-of machine defines NO_UNION_TYPE.
-
+++ /dev/null
-This is a list of the status of GNU Emacs on various machines and systems.
-
-For each system and machine, we give the configuration name you should
-pass to the `configure' script to prepare to build Emacs for that
-system/machine.
-
-The `configure' script uses the configuration name to decide which
-machine and operating system description files `src/config.h' should
-include. The machine description files are all in `src/m', and have
-names similar to, but not identical to, the machine names used in
-configuration names. The operating system files are all in `src/s',
-and are named similarly. See the `configure' script if you need to
-know which configuration names use which machine and operating system
-description files.
-
-If you add support for a new configuration, add a section to this
-file, and then edit the `configure' script to tell it which
-configuration name(s) should select your new machine description and
-system description files.
-
-\f
-Here are the configurations Emacs is intended to work with, with the
-corresponding configuration names. You can postpend version numbers
-to operating system names (i.e. sunos4.1) or architecture names (i.e.
-hppa1.1). If you leave out the version number, the `configure' script
-will configure Emacs for the latest version it knows about.
-
-Acorn RISCiX (arm-acorn-riscix1.2)
-
- Emacs 19.29 has changes that ought to support RISCiX 1.2.
-
- Due to a bug in the RISCiX C compiler (3.4.5), emacs must
- be built with gcc (versions 2.5.8 onwards).
-
- In addition, you will need GNU sed and GNU make, as the RISCiX release
- versions of these utilities cannot cope with building emacs-19!
-
- GNU sed should be configured with:
-
- env 'DEFS=-Dgetopt=gnu_getopt -Dopterr=gnu_opterr -Doptind=gnu_optind \
- -Doptarg=gnu_optarg' ./configure
-
- GNU make (3.72+) should be configured with:
-
- env 'CFLAGS=-Dgetopt=gnu_getopt -Dopterr=gnu_opterr -Doptind=gnu_optind \
- -Doptarg=gnu_optarg' ./configure
-
- Emacs may be configured to use the X toolkit, by adding --with-x-toolkit
- to the configure command. If you do this, you will need to edit the line
- in src/Makefile which defines LIBW (about line 59) to read:
-
- LIBW= -lXaw_n
-
- This ensures that the non-shared widget library is used.
-
- It is unlikely that this version of emacs will work with RISCiX 1.1.
-
-Alliant (fx80-alliant-bsd):
-
- 18.52 worked on system version 4. Previous Emacs versions were
- known to work on previous system versions.
-
- If you are using older versions of their operating system, you may
- need to edit `src/config.h' to use `m/alliant1.h' (on version 1) or
- `m/alliant.h' (on versions 2 and 3).
-
-Alliant FX/2800 (i860-alliant-bsd)
-
- Known to work with 19.26 and OS version 2.2, compiler version 1.3.
-
-Alpha (DEC) running OSF/1 or GNU/Linux (alpha-dec-osf1, alpha-dec-linux-gnu)
-
- For OSF/1 (aka Digital Unix) version 4.0, update 386,
- it is reported that you need to run configure this way:
-
- configure --x-includes=/usr/include --x-libraries=/usr/shlib
-
- For 4.0 revision 564, and 4.0A and 4.0B, Emacs 20 seems to work
- with no special configuration options. However, if you use GCC as
- your compiler, you will need version 2.8.1 or later, as older
- versions fail to build with a message "Invalid dimension for the
- charset-ID 160".
-
- Note that the X11 libraries on GNU/Linux systems for the Alpha are
- said to have bugs that prevent Emacs from working with X (as of
- November 1995). Recent releases work (July 2000).
-
-Altos 3068 (m68k-altos-sysv)
-
- 18.52 was said to work, provided you don't compile unexec.c with -O.
-
-Amdahl UTS (580-amdahl-sysv)
-
- Small changes for 18.38 were merged in 18.39. It is mostly
- working, but at last report a bug sometimes causes Emacs to
- grab very large amounts of memory. No fix or explanation
- has yet been reported. It may be possible to find this bug
- if you find which Emacs command it happens within and then
- run that command with a breakpoint set at malloc.
-
- The 5.2u370 compiler is so brain damaged that it is not
- even worth trying to use it. Success was obtained with the
- uts native C compiler on uts version 5.2.5.
-
-Apollo running X Windows (m68k-apollo-bsd)
-
- Apollo version now supports dumping. It has been tested on SR10.3 and
- SR10.4. It certainly requires at least SR10.0, and maybe SR10.2. Be sure
- to build in the BSD environment.
-
- By default, everything is compiled with the switch "-W0,-opt,2". Don't try
- to change this to full optimization (-O). The full optimizer (in Domain CC
- 6.7, 6.8 and 6.9) generates some bad code in several modules which causes
- the emacs window, under X, to be refreshed with each keystroke.
-
- The configuration stuff should work for the most part. However, some Domain
- installations may have to edit src/Makefile manually after it is created.
- There are too many versions of both cc and X to automate this easily.
-
- In `lib-src/Makefile', emacsclient and emacsserver compile and work fine
- under CC 6.9. They now probably work under other versions of the compiler,
- as well.
-
- The Apollo Domain CC compiler will issue quite a few warning messages,
- mostly complaining about incompatible pointers. In general, these are
- harmless and can be ignored. If you discover otherwise, please submit a bug
- report identifying the problem in detail.
-
- When you try to dump emacs, you may get the message ".rwdi section needs
- relocation." This means you are linking with some code that has compressed
- data sections. In some cases this comes from linking with X libraries. Try
- using shared X libraries instead. With some versions of Domain/OS this is
- as simple as removing the "-lX11" from the LIBX line in src/Makefile.
-
- When running the configure script, use the configuration name
- "m68k-apollo-bsd". You will also need to use the "-with-gcc=no" and
- "-with-x" options. Depending upon your site configuration, you may have to
- use other configure options, as well. Examine the INSTALL file for other
- configure options.
-
- Check out the file 'lisp/x-apollo.el'. To use it, add
-
- (load "x-apollo")
-
- to your .emacs file. It provides useful default Apollo function key
- bindings.
-
-AT&T 3b2, 3b5, 3b15, 3b20 (we32k-att-sysv)
-
- Emacs will probably not work with certain kernel constants too small.
-
- In param.h CDLIMIT should be at least (1L << 12) in order to allow
- processes to write up to 2 Mbyte files. This parameter is configurable
- by normal means in /etc/master.d/kernel; examine that file for the
- symbol CDLIMIT or ULIMIT, and raise it by several powers of 2. Then
- do normal kernel rebuild things via "cd /boot; mkboot -k KERNEL" and so
- forth.
-
- In seg.h NSEGP and STACKSEG should be at least 16 and 4 respectively
- to allow processes with total size of up to 2Mbytes.
- However, I'm told it is unlikely this would fail to be true.
-
- The MAXMEM may also prevent Emacs from running. The file
- 3B-MAXMEM in this directory explains how to increase MAXMEM.
-
- On some of these machines, you may need to define IN_SCCS_ID
- in config.h to make Emacs work. Supposedly you can tell whether
- this is necessary by checking something in /usr/include/sys/time.h;
- we do not know precisely what.
-
-AT&T 7300 or 3b1 (m68k-att-sysv)
-
- 18.52 worked. If you have strange troubles with dumping
- Emacs, delete the last few lines from `src/m/7300.h' and recompile.
- These lines are supposed to produce a sharable executable.
-
- `src/m/7300.h' defines SHORTNAMES because operating system versions
- older than 3.5 did not support long symbol names. Version 3.5 does
- support them, so you can remove the #define SHORTNAMES in that
- version.
-
-Bull DPX/2 models 2nn or 3nn (m68k-bull-sysv3)
-
- Minor fixes merged into 19.19, which should work with CC or GCC.
-
- You should compile with all the POSIX stuff: undef _SYSV and define
- _POSIX_SOURCE, _XOPEN_SOURCE and _BULL_SOURCE.
-
- On bos2.00.45 there is a bug that makes the F_SETOWN fcntl
- call enters in an infinite loop. F_SETOWN_BUG has been defined to avoid
- calling it.
-
-Bull DPX/20 (rs6000-bull-bosx)
-
- Version 19 works.
-
-Bull sps7 (m68k-bull-sysv2)
-
- Changes partially merged in version 19, but some fixes are probably required.
-
-CCI 5/32, 6/32
-
- See "Tahoe".
-
-Celerity (celerity-celerity-bsd4.2)
-
- Version 18.49 worked. This configuration name is a hack, because we
- don't know the processor used by Celerities. If someone
- who uses a Celerity could get in touch with us, we can teach
- config.sub a better name for the configuration.
-
-Clipper (clipper-???)
-
- Version 19 has support for some brand of clipper system. If you
- have successfully built Emacs 19 on some sort of clipper system, let
- us know so we can flesh out this entry.
-
- Note that the Orion 105 is also a clipper, but some system-related
- parameters are different.
-
-Convex (c1-convex-bsd, c2-convex-bsd, c32-convex-bsd, c34-convex-bsd,
- c38-convex-bsd)
-
- Support updated and residual bugs fixed in 19.26.
-
-Cubix QBx/386 (i386-cubix-sysv)
-
- Changes merged in 19.1. Systems before 2/A/0 may fail to compile etags.c
- due to a compiler bug.
-
-Cydra 5 (cydra-cydrome-sysv)
-
- 18.51 worked in one version of their operating system but stopped
- working in a newer version. This has not been fixed.
-
-Data General Aviion (m88k-dg-dgux)
-
- 19.23 works; however, the GCC provided with DGUX 5.4R3.00 fails to
- compile src/emacs.c. GCC 2.5.8 does work.
- The 19.26 pretest was reported to work; no word on which compiler.
- System versions other than DGUX 5.4R3.00 have not been tested.
-
- DGUX 5.4R3.10 works with 19.29 and 19.30.
-
- DGUX R4.11 contains changes to the stdio internals and it doesn't work
- with versions before 20.2 without patches. 20.2 works in interactive
- mode but usually fails in batch mode. The problem is that using
- stderr in the dumped emacs usually leads to a segmentation fault.
- Only m88k has been tested.
-
-DECstation (mips-dec-ultrix or mips-dec-osf)
-
- This machine is the older Mips-based DECstation.
- Emacs should now work on the Alpha CPU.
-
- 19.25 works on Ultrix 4.2. The 19.26 pretest was reported to work
- on Ultrix 4.2a and on 4.4.
-
- One user reported 19.25 did not work at all with --with-x-toolkit
- using X11R5 patch level 10, but worked ok with X11R5 pl26.
-
- See under Ultrix for problems using X windows on Ultrix.
- Note that this is a MIPS machine.
-
- For Ultrix versions 4.1 or earlier, you may need to define
- SYSTEM_MALLOC in `src/m/pmax.h', because XvmsAlloc.o in libX11.a seems
- to insist on defining malloc itself.
-
- For Ultrix versions prior to 4.0, you may need to delete
- the definition of START_FILES from `src/m/pmax.h'.
-
-Motorola Delta 147 (m68k-motorola-sysv)
-
- The EMacs 19.26 pretest was reported to work.
-
- Motorola Delta boxes running System V/68 release 3.
- Tested on 147 board with SVR3V7, no X and gcc.
- Tested on 167 board with SVR3V7, no X, cc, gnucc and gcc.
- Reports say it works with X too.
-
- The installation script chooses the compiler itself. gnucc is
- preferred.
-
-Motorola Delta 187 (m88k-motorola-sysv,
- m88k-motorola-sysvr4, or
- m88k-motorola-m88kbcs)
-
- The 19.26 pretest was reported to run on SVR3. However, if you
- use --with-x-toolkit on svr3, you will have problems compiling some
- files because time.h and sys/time.h get included twice.
- One fix is to edit those files to protect against multiple inclusion.
-
- As of version 19.13, Emacs was reported to run under SYSVr3 and SYSVr4.
-
-Dual running System V (m68k-dual-sysv)
-
- As of 17.46, this worked except for a few changes
- needed in unexec.c.
-
-Dual running Uniplus (m68k-dual-uniplus)
-
- Worked, as of 17.51.
-
-Elxsi 6400 (elxsi-elxsi-sysv)
-
- Changes for 12.0 release are in 19.1.
- Dumping should work now.
-
-Encore machine (ns16k-encore-bsd)
-
- This machine bizarrely uses 4.2BSD modified to use the COFF format
- for object files. Works (as of 18.40). For the APC processor you
- must enable two lines at the end of `src/s/umax.h', which are commented
- out in the file as distributed.
-
- WARNING: If you compile Emacs with the "-O" compiler switch, you
- must also use the "-q enter_exits" switch so that all functions have
- stack frames. Otherwise routines that call `alloca' all lose.
-
- A kernel bug in some system versions causes input characters to be lost
- occasionally.
-
-Fujitsu DS/90 (sparc-fujitsu-sysv4)
-
- Changes merged in 20.3.
-
-GEC 63 (local-gec63-usg5.2)
-
- Changes are partially merged in version 18, but certainly require
- more work. Let us know if you get this working, and we'll give it a
- real configuration name.
-
-Gould Power Node (pn-gould-bsd4.2 or pn-gould-bsd4.3)
-
- 18.36 worked on versions 1.2 and 2.0 of the operating system.
-
- On UTX/32 2.0, use pn-gould-bsd4.3.
-
- On UTX/32 1.2 and UTX/32S 1.0, use pn-gould-bsd4.2 and note that
- compiling `lib-src/sorted-doc' tickles a compiler bug: remove the -g
- flag to cc in the makefile.
-
- UTX/32 1.3 has a bug in the bcopy library routine. Fix it by
- #undef BSTRING in `src/m/gould.h'.
-
- Version 19 incorporates support for releases 2.1 and later of UTX/32.
- A site running a pre-release of 2.1 should #define RELEASE2_1 in config.h.
-
-Gould NP1 (np1-gould-bsd)
-
- Version 19 supposedly works.
-
-Harris Night Hawk (m68k-harris-cxux or m88k-harris-cxux)
-
- This port was added in 19.23. The configuration actually tested was
- a Night Hawk 4800 running CX/UX 7.0.
-
- If you have GCC ported and want to build with it, you probably need to
- change things (like compiler switches) defined in the s/cxux.h file.
-
- If you have X11R6 installed in /usr/lib, configure will fail to find
- it and may find X11R5 instead. To work around this problem, use
- --x-libraries=/usr/lib when you run configure.
-
- With CX/UX 7.0 and later releases, you need to build after setting the
- SDE_TARGET environment variable to COFF (a port using ELF and shared
- libraries has not yet been done).
-
-Harris Power PC (powerpc-harris-powerunix)
-
- Patches have been merged in 19.31.
-
-Honeywell XPS100 (xps100-honeywell-sysv)
-
- Config file added in version 19.
-
-Hewlett-Packard 9000 series 200 or 300 (m68k-hp-bsd or m68k-hp-hpux
- or m68k-hp-netbsd)
-
- These machines are 68000-series CPUs running HP/UX
- (a derivative of sysV with some BSD features) or BSD 4.3 ported by Utah.
- The operating system suffix determines which system Emacs is built for.
-
- Series 200 HPUX runs Emacs only if it has the "HP/UX upgrade".
-
- Version 19 works under BSD. The 19.26 pretest was reported
- to work on HPUX 9. 19.31 works on HPUX 10.01, but there are
- some problems on 10.10 which have not been resolved. Emacs 19.34
- works on HPUX 10.20 provided you compile with GCC; with the HP C
- compiler, subprocess commands do not work.
-
- On HPUX 9, Emacs sometimes crashes with SIGBUS or SIGSEGV after you
- delete a frame. We think this is due to a bug in the X libraries
- provided by HP. With the alternative X libraries in
- /usr/contrib/mitX11R5/lib, the problem does not happen.
-
- If you are running HP/UX release 8.0 or later, you need the optional
- "C/ANSI C" software in order to build Emacs (older releases of HP/UX
- do not require any special software). If the file "/etc/filesets/C"
- exists on your machine, you have this software, otherwise you do not.
-
- Note that HP has used two incompatible assembler syntaxes,
- and has recently changed the format of C function frames.
- `src/crt0.c' and `src/alloca.s' have been conditionalised for the new
- assembler and new function-entry sequence. You may need to define
- OLD_HP_ASSEMBLER if you are using an older hpux version. If you
- have an official (bought from HP) series 300 machine you have
- the new assembler. Kernels that are 5.+ or later have new
- assembler. A Series 200 that has been upgraded to a 68010
- processor and a 5.+ kernel has the new compiler.
-
- Define C_SWITCH_MACHINE to be +X to make a version of Emacs that
- runs on both 68010 and 68020 based HP/UX's.
-
- Define HPUX_68010 if you are using the new assembler, for
- a system that has a 68010 without a 68881. This is to say,
- a s200 (upgraded) or s310.
-
- Define the symbol HPUX_NET if you have the optional network features
- that include the `netunam' system call. This is referred to as
- Network Services (NS/9000) in HP literature.
-
-HP 9000 series 500: not supported.
-
- The series 500 has a seriously incompatible memory architecture
- which relocates data in memory during execution of a program,
- and support for it would be difficult to implement.
-
-HP 9000 series 700 or 800 (Spectrum) (hppa1.0-hp-hpux or hppa1.1-hp-hpux
- or ...hpux9shr, or ...-nextstep)
-
- Use hppa1.1 for the 700 series and hppa1.0 for the 800
- series machines. (Emacs may not actually care which one you use.)
-
- Support for NextSTEP was added in 19.31.
-
- Emacs 20 may work on HPUX 10. You need patch PHSS_6202 to install
- the Xaw and Xmu libraries. On HPUX 10.20 you may need to compile with GCC;
- when Emacs was compiled with HP's C compiler, HP92453-01 A.10.32.03,
- the subprocess features failed to work.
-
- 19.26 is believed to work on HPUX 9 provided you compile with GCC.
- As of version 19.16, Emacs was reported to build (using GCC) and run
- on HP 9000/700 series machines running HP/UX versions 8.07 and 9.01.
- The HP compiler is known to fail on some versions if you use +O3,
- but it may work with lower optimization levels.
-
- Use hppa1.1-hp-hpux9shr to use shared libraries on HPUX version 9.
- You may need to create the X libraries libXaw.a and libXmu.a from
- the MIT X distribute, and you may need to edit src/Makefile's
- definition of LIBXT to look like this:
-
- LIBXT= $(LIBW) -lXmu -lXt $(LIBXTR6) -lXext
-
- Some people report trouble using the GNU memory allocator under
- HP/UX version 9. The problems often manifest as lots of ^@'s in the
- buffer.
-
- We are told that these problems go away if you obtain the latest
- patches for the HP/UX C compiler. James J Dempsey
- <jjd@spserv.bbn.com> says that this set of versions works for him:
- /bin/cc:
- HP92453-01 A.09.28 HP C Compiler
- /lib/ccom:
- HP92453-01 A.09.28 HP C Compiler
- HP-UX SLLIC/OPTIMIZER HP-UX.09.00.23 02/18/93
- Ucode Code Generator - HP-UX.09.00.23.5 (patch) 2/18/93
-
- For 700 series machines, the HP-UX patch needed is known as
- PHSS_2653. (Perhaps for 800 series machines as well; we don't
- know.) If you are on the Internet, you should be able to obtain
- this patch by using telnet to access the machine
- support.mayfield.hp.com and logging in as "hpslreg" and following
- the instructions there. Or you may be able to use this
- web site:
-
- HP Patch Server: http://support.mayfield.hp.com/patches/html/patches.html
- HP Support Line: http://support.mayfield.hp.com
-
- Please do not ask FSF for further support on this. If you have any
- trouble obtaining the patch, contact HP Software Support.
-
- If your buffer fills up with nulls (^@) at some point, it could well
- be that problem. That problem does not happen when people use GCC
- to compile Emacs. On the other hand, the HP compiler version 9.34
- was reported to work for the 19.26 pretest. 9.65 was also reported to work.
-
- If you turn on the DSUSP character (delayed suspend),
- Emacs 19.26 does not know how to turn it off on HPUX.
- You need to turn it off manually.
-
- If you are running HP/UX release 8.0 or later, you need the optional
- "C/ANSI C" software in order to build Emacs (older releases of HP/UX
- do not require any special software). If the file "/etc/filesets/C"
- exists on your machine, you have this software, otherwise you do not.
-
-High Level Hardware Orion (orion-highlevel-bsd)
-
- This is the original microprogrammed hardware.
- Machine description file ought to work.
-
-High Level Hardware Orion 1/05 (clipper-highlevel-bsd)
-
- Changes merged in 18.52. This is the one with the Clipper cpu.
- Note that systems which lack NFS need LOAD_AVE_TYPE changed to `double'.
-
- C compiler has a bug; it loops compiling eval.c.
- Compile it by hand without optimization.
-
-HITACHI SR2001/SR2201 series (hppa1.1-hitachi-hiuxmpp)
-
- These machines are based on PA architecture running HI-UX/MPP
- (based on OSF1. `MPP' stands for `Massively Parallel Processor').
-
- Emacs 19.34 is believed to work; its pretest was tested
- both on SR2001 (output of `uname -rv' is `00-01-BB 0') and
- SR2201 (`02-00 0').
-
- The machine description file is `src/m/sr2k.h' is based on
- `src/m/hp800.h'. The system description file is `src/s/hiuxmpp.h'
- based on `src/s/osf1.h'. Note that this system doesn't use COFF.
-
-IBM PS/2 (i386-ibm-aix1.1 or i386-ibm-aix1.2)
-
- Changes merged in version 19. You may need to copy
- /usr/lib/samples/hft/hftctl.c to the Emacs src directory.
-
- i386-ibm-aix1.1 may not work with certain new X window managers, and
- may be suboptimal.
-
-IBM RS/6000 (rs6000-ibm-aix*)
-
- Emacs 19.26 is believed to work; its pretest was tested.
-
- Compiling with the system's `cc' and CFLAGS containing `-O5' might
- fail because libXbsd isn't found. This is a compiler bug;
- re-configure Emacs so that it isn't compiled with `-O5'.
-
- At last report, Emacs didn't run well on terminals. Informed
- persons say that the tty VMIN and VTIME settings have been
- corrupted; if you have a fix, please send it to us.
-
- Compiling with -O using the IBM compiler has been known
- to make Emacs work incorrectly. It's reported that on
- AIX 3.2.5 with an IBM compiler earlier than 1.03.00.14,
- cc -O fails for some files. You need to install any
- PTF containing APAR #IX42810 to bring the compiler to
- the 1.03.00.14 level to allow optimized compiles.
-
- There are reports that IBM compiler versions earlier than 1.03.00.02
- fail even without -O. However, another report said that compiler
- version 1.02.01.00 did work, on AIX 3.2.4, with Emacs 19.31.
-
- As of 19.11, if you strip the Emacs executable, it ceases to work.
-
- If you are using AIX 3.2.3, you may get a core dump when loading
- ange-ftp. You may be able to fix the problem by defining LIBS_TERMCAP
- as -ltermcap -lcurses. Please tell us if this fails to work.
-
- If anyone can fix the above problems, or confirm that they don't happen
- with certain versions of various programs, we would appreciate it.
-
-IBM RT/PC (romp-ibm-bsd or romp-ibm-aix)
-
- Use romp-ibm-bsd for the 4.2-like system and romp-ibm-aix for AIX.
- 19.22 is reported to work under bsd. We don't know about AIX.
-
- On BSD, if you have trouble, try compiling with a different compiler.
-
- On AIX, the file /usr/lib/samples/hft/hftctl.c must be compiled into
- hftctl.o, with this result left in the src directory (hftctl.c is
- part of the standard AIX distribution).
-
- window.c must not be compiled with -O on AIX.
-
-Integrated Solutions `Optimum V' (m68k-isi-bsd4.2 or -bsd4.3)
-
- 18.52 said to work on some sort of ISI machine.
- Version 18.45 worked (running on a Optimum V (VME bus, 68020)
- BSD 4.2 (3.05e) system). 18.42 is reported to work on
- a Qbus 68010 system. Has not been tried on `WorkStation' `Cluster
- Compute Node' `Cluster WorkStation' or `Server Node' (Love the
- StudLYCaps)
-
- Compilation with -O is rumored to break something.
-
- On recent system versions, you may need to undefine the macro UMAX
- in `lib-src/loadst.c' and `src/getpagesize.h'. They stupidly defined this
- in a system header file, which confuses Emacs (which thinks that UMAX
- indicates the Umax operating system).
-
-Intel 386 (i386-*-isc, i386-*-esix, i386-*-bsdi2,
- i386-*-xenix, i386-*-freebsd, i386-*-linux-gnu,
- i386-*-sol2.4, i386-*-sysv3, i386-intsys-sysv,
- i386-*-sysv4, i386-*-sysv4.2,
- i386-*-sysv5.3, i386-*-bsd4.2,
- i386-*-sco3.2v4, i386-*-bsd386, i386-*-386bsd,
- i386-*-msdos, i386-*-windowsnt.
- i386... can be replaced with i486... or i586...)
-
- In the above configurations, * means that the manufacturer's name
- you specify does not matter, and you can use any name you like
- (but it should not contain any dashes or stars).
-
- When using the ISC configurations, be sure to specify the isc
- version number - for example, if you're running ISC 3.0, use
- i386-unknown-isc3.0 as your configuration name.
- Use i386-*-esix for Esix; Emacs runs as of version 19.6.
- Use i386-*-linux-gnu for GNU/Linux systems; Emacs runs as of version 19.26.
- Use i386-intsys-sysv for Integrated Solutions 386 machines.
- It may also be correct for Microport systems.
- Use i386-*-sco3.2v4 for SCO 3.2v4; Emacs runs as of version 19.26.
-
- On GNU/Linux systems, Emacs 19.23 was said to work properly with libc
- version 4.5.21, but not with 4.5.19. If your system uses QMAGIC
- for the executable format, you must edit config.h to define LINUX_QMAGIC.
-
- On GNU/Linux, configure may fail to put these definitions in config.h:
-
- #define HAVE_GETTIMEOFDAY
- #define HAVE_MKDIR
- #define HAVE_RMDIR
- #define HAVE_XSCREENNUMBEROFSCREEN
-
- To work around the problem, add those definitions by hand.
- It is possible that this problem happens only with X11R6.
- Newer system versions have fixed it.
-
- The 19.26 pretest was reported to work on SVR4.3 and on Freebsd.
-
- 19.29 is reported to crash when using Motif on Solaris 2.5.
- The reasons are not yet known.
-
- Use i386-*-bsdiN for BSDI BSD/OS version N; Emacs runs as of version 19.23.
- In some system versions, `make' is broken; use GNU make instead.
- Shell bugs in version 1.0 of BSD/OS cause configure
- to do the wrong thing with --with-x-toolkit; the workaround is to edit
- configure to run another shell such as bash.
-
- For System V release 3, use i386-*-sysv3.
- For System V release 4, use i386-*-sysv4.
- For System V release 4.2, use i386-*-sysv4.2.
-
- If you are using Xenix, see notes at end under Xenix.
- If you are using Esix, see notes at end under Esix.
- If you are using SCO Unix, see notes at end under SCO.
-
- On 386bsd, NetBSD and FreeBSD, at one time, it was necessary to use
- GNU make, not the system's make. Assuming it's installed as gmake,
- do `gmake install MAKE=gmake'. However, more recently it is
- reported that using the system Make on NetBSD 1.3.1 works ok.
-
- If you are using System V release 4.2, you may find that `cc -E'
- puts spurious spaces in `src/xmakefile'. If that happens,
- specify CPP=/lib/cpp as an option when you run make.
- There is no problem if you compile with GCC.
-
- Note that use of Linux with GCC 2.4 and the DLL 4.4 libraries
- requires the experimental "net 2" network patches (no relation to
- Berkeley Net 2). There is a report that (some version of) Linux
- requires including `/usr/src/linux/include/linux' in buffer.c
- but no coherent explanation of why that might be so. If it is so,
- in current versions of Linux, something else should probably be changed.
-
- Some sysV.3 systems seem to have bugs in `opendir';
- for them, alter `config.h' to define NONSYSTEM_DIR_LIBRARY
- and undefine SYSV_SYSTEM_DIR.
-
- If you use optimization on V.3, you may need the option -W2,'-y 0'
- to prevent certain faulty optimization.
-
- On 386/ix, to link with shared libraries, add #define USG_SHARED_LIBRARIES
- to config.h.
-
- On SCO, there are problems in regexp matching when Emacs is compiled
- with the system compiler. The compiler version is "Microsoft C
- version 6", SCO 4.2.0h Dev Sys Maintenance Supplement 01/06/93;
- Quick C Compiler Version 1.00.46 (Beta). The solution is to compile
- with GCC.
-
- On ISC systems (2.02 and more recent), don't try to use the versions
- of X that come with the system; use XFree86 instead.
-
- There is no consistency in the handling of certain system header files
- on V.3.
-
- Some versions have sys/sioctl.h, and require it in sysdep.c.
- But some versions do not have sys/sioctl.h.
- For a given version of the system, this may depend on whether you have
- X Windows or TCP/IP. Define or undefine NO_SIOCTL_H in config.h
- according to whether you have the file.
-
- Likewise, some versions have been known to need sys/ttold.h, sys/stream.h,
- and sys/ptem.h included in sysdep.c. If your system has these files,
- try defining NEED_PTEM_H in config.h if you have trouble without it.
-
- You may find that adding -I/usr/X/include or -I/usr/netinclude or both
- to CFLAGS avoids compilation errors on certain systems.
-
- Some versions convince sysdep.c to try to use `struct tchars'
- but define `struct tc' instead; add `#define tchars tc'
- to config.h to solve this problem.
-
-Iris 2500 and Iris 2500 Turbo (m68k-sgi-iris3.5 or m68k-sgi-iris3.6)
-
- Version 18 was said to work; use m68k-sgi-iris3.5 for system version 2.5
- and m68k-sgi-iris3.6 for system version 3.6.
- Note that the 3030 is the same as the Iris 2500 Turbo.
-
-Iris 4D (mips-sgi-irix[456].*)
-
- You can build a 64-bit executable (with larger maximum buffer size)
- on Irix 6.5 by specifying the 64-bit ABI using the `-64' compiler
- flag or otherwise (see cc(1)). This may work on earlier Irix 6
- systems if you edit src/s/irix6-0.h following irix6-5.h.
-
- If compiling with GCC on Irix 6 yields an error "conflicting types
- for `initstate'", install GCC 2.95 or a newer version, and this
- problem should go away. It is possible that this problem results
- from upgrading the operating system without reinstalling GCC; so you
- could also try reinstalling the same version of GCC, and telling us
- whether that fixes the problem.
-
- The 19.26 pretest was reported to work on IRIX 4.0.5 and 5.2.
- 19.23 was reported to work on IRIX 5.2, but you may need to install
- the "compiler_dev.hdr.internal" subsystem in order to compile unexelfsgi.c.
- 19.22 was known to work on all Silicon Graphics machines running
- IRIX 4.0.5 or IRIX 5.1.
-
- Compiling with -O using IRIX compilers prior to 3.10.1 may not work.
- Don't use -O or use GCC instead.
-
- Most IRIX 3.3 systems do not have an ANSI C compiler, but a few do.
- Compile Emacs 18 with the -cckr switch on these machines.
-
- There is a bug in IRIX 3.3 that can sometimes leave ptys owned by root
- with a permission of 622. This causes malfunctions in use of
- subprocesses of Emacs. Irix versions 4.0 and later with GNU Emacs
- versions 18.59 and later fix this bug.
-
-Masscomp (m68k-masscomp-rtu)
-
- 18.36 worked on a 5500DP running RTU v3.1a and compiler version 3.2
- with minor fixes that are included in 18.37. However, bizarre behavior
- was reported for 18.36 on a Masscomp (model and version unknown but probably
- a 68020 system). The report sounds like a compiler bug.
-
- A compiler bug affecting statements like
- unsigned char k; unsigned char *p;... x = p[k];
- has been reported for "C version 1.2 under RTU 3.1". We do not wish
- to take the time to install the numerous workarounds required to
- compensate for this bug.
-
- For RTU version 3.1, define FIRST_PTY_LETTER to be 'p' in `src/s/rtu.h'
- (or #undef and redefine it in config.h) so that ptys will be used.
-
- GNU Emacs is said to have no chance of compiling on RTU versions
- prior to v3.0.
-
-Megatest (m68k-megatest-bsd)
-
- Emacs 15 worked; do not have any reports about Emacs 16 or 17
- but any new bugs are probably not difficult.
-
-Mips (mips-mips-riscos, mips-mips-riscos4.0, or mips-mips-bsd)
-
- The C compiler on Riscos 4.51 dumps core trying to optimize
- parts of Emacs. Try without optimization or try GCC.
-
- Meanwhile, the linker on that system returns success even if
- there are undefined symbols; as a result, configure gets the
- wrong answers to various questions. No work-around is known
- except to edit src/config.h by hand to indicate which functions
- don't exist.
-
- Use mips-mips-riscos4.0 for RISCOS version 4.
- Use mips-mips-bsd with the BSD world.
-
- Note that the proper configuration names for DECstations are
- mips-dec-ultrix and mips-dec-osf.
-
- If you are compiling with GCC, then you must run fixincludes;
- the alternative of using -traditional won't work because
- the definition of SIGN_EXTEND_CHAR uses the keyword `signed'.
-
- If the SYSV world is the default, then you probably need the following
- line in etc/Makefile:
-
- CFLAGS= -g -systype bsd43
-
- Some operating systems on MIPS machines give SIGTRAP for division by
- zero instead of the usual signals. The only real solution is to fix
- the system to give a proper signal.
-
- In the meantime, you can change init_data in data.c if you wish.
- Change it to handle SIGTRAP as well as SIGFPE. But this will have a
- great disadvantage: you will not be able to run Emacs under a
- debugger. I think crashing on division by zero is a lesser problem.
-
- dsg@mitre.org reported needing to use --x-libraries=/bsd43/usr/lib
- on a riscos4bsd site. But it is not clear whether this is needed in
- general or only because of quirks on a particular site.
-
-National Semiconductor 32000 (ns32k-ns-genix)
-
- This is for a complete machine from National Semiconductor,
- running Genix. Changes merged in version 19.
-
-NCR Tower 32 (m68k-ncr-sysv2 or m68k-ncr-sysv3)
-
- If you are running System V release 2, use m68k-ncr-sysv2.
- If you are running System V release 3, use m68k-ncr-sysv3.
-
- These both worked as of 18.56. If you change `src/ymakefile' so that
- CFLAGS includes C_OPTIMIZE_SWITCH rather than C_DEBUG_SWITCH, check
- out the comments in `src/m/tower32.h' (for System V release 2) or
- `src/m/tower32v3.h' (for System V release 3) about this.
-
- There is a report that compilation with -O did not work with 18.54
- under System V release 2.
-
-NCR Intel system (i386-ncr-sysv4.2)
-
- This system works in 19.31, but if you don't link it with GNU ld,
- you may need to set LD_RUN_PATH at link time to specify where
- to find the X libraries.
-
-NEC EWS4800 (mips-nec-sysv4)
-
- This system works in 20.4, but you should use the compiler
- /usr/abiccs/bin/cc (MIPS ABI MODE).
-
-NeXT (m68k-next-nextstep)
-
- Emacs 19 has not been tested extensively yet, but it seems to work
- in a NeXTStep 3.0 terminal window, and under the X server called
- co-Xist. You may need to specify -traditional when src/Makefile
- builds xmakefile.
-
- NeXT users might want to implement direct operation with NeXTStep,
- but from the point of view of the GNU project, that is a
- distraction.
-
- Thanks to Thorsten Ohl for working on the NeXT port of Emacs 19.
-
-Nixdorf Targon 31 (m68k-nixdorf-sysv)
-
- Machine description file for version 17 is included in 18
- but whether it works is not known.
- `src/unexec.c' bombs if compiled with -O.
- Note that the "Targon 35" is really a Pyramid.
-
-Nu (TI or LMI) (m68k-nu-sysv)
-
- Version 18 is believed to work.
-
-Paragon OSF/1 (i860-intel-osf1)
-
- Changes merged in 19.29.
-
- There is a bug in OSF/1 make which claims there is a syntax error
- in the src/xmakefile. You can successfully build emacs with:
-
- pmake MAKE=pmake
-
-Plexus (m68k-plexus-sysv)
-
- Worked as of 17.56.
-
-Pmax (DEC Mips) (mips-dec-ultrix or mips-dec-osf1)
-
- See under DECstation, above.
-
-Prime EXL (i386-prime-sysv)
-
- Minor changes merged in 19.1.
-
-Pyramid (pyramid-pyramid-bsd)
-
- The 19.26 pretest was observed to work on OSx 5.0, but it is necessary
- to edit gmalloc.c. You must add #include <sys/types.h> at the top,
- and delete the #define for size_t.
-
- You need to build Emacs in the Berkeley universe with
- the `ucb' command, as in `ucb make' or `ucb build-install'.
-
- In OSx 4.0, it seems necessary to add the following two lines
- to `src/m/pyramid.h':
- #define _longjmp longjmp
- #define _setjmp setjmp
-
- In Pyramid system 2.5 there has been a compiler bug making
- Emacs crash just after screen-splitting with Qnil containing 0.
- A compiler that fixes this is Pyramid customer number 8494,
- internal number 1923.
-
- Some versions of the pyramid compiler get fatal
- errors when the -gx compiler switch is used; if this
- happens to you, change `src/m/pyramid.h' to define
- C_DEBUG_SWITCH with an empty definition.
-
- Some old system versions may require you to define PYRAMID_OLD
- in when alloca.s is preprocessed, in order to define _longjmp and _setjmp.
-
-Sequent Balance (ns32k-sequent-bsd4.2 or ns32k-sequent-bsd4.3)
-
- Emacs 18.51 worked on system version 3.0. 18.52 is said to work.
- Delete some lines at the end of `src/m/sequent.h' for earlier system
- versions.
-
-Sequent Symmetry (i386-sequent-bsd, i386-sequent-ptx, i386-sequent-ptx4)
-
- 19.33 has changes to support ptx 4 (a modified SVR4).
-
- Emacs 19 should work on Dynix (BSD). However, if you compile with
- the Sequent compiler, you may find Emacs does not restore the
- terminal settings on exit. If this happens, compile with GCC.
-
- Emacs 19.27 contains patches that should support
- DYNIX/ptx 1.4 and 2.1 with the native cc compiler.
-
- GCC can't compile src/process.c due to a non-standard Sequent asm
- keyword extension supported by cc and used for the network byte/word
- swapping functions in the PTX /usr/include/netinet/in.h file. GCC
- 2.5.8 includes the file <sys/byteorder.h> which can be included into
- netinet/in.h to perform these byte/word swapping functions in the
- same manner. Patches have been submitted to the FSF against GCC
- 2.6.0 to fix this problem and allow Emacs to be built with GCC.
-
- If your machine does not have TCP/IP installed, you will have to edit the
- src/s/ptx.h file and comment out #define TCPIP_INSTALLED.
-
-Siemens Nixdorf RM600 and RM400 (mips-siemens-sysv4)
-
- Changes merged in 19.29. This configuration should also work for
- Pyramid MIS Server running DC-OSX 1.x. The version configured with
- `--with-x' works without any modifications, but `--with-x-toolkit'
- works only if the Athena library and the Toolkit library are linked
- statically. For this, edit `src/Makefile' after the `configure' run
- and modify the lines with `-lXaw' and `-lXt' as follows:
-
- LIBW= /usr/lib/libXaw.a
- LIBXT= $(LIBW) -lXmu /usr/lib/libXt.a $(LIBXTR6) -lXext
-
- In addition, `--with-x-toolkit=motif' works only
- if the Motif library and the Toolkit library are linked statically.
- To do this, edit `src/Makefile' after the `configure' run
- and modify the lines with `-lXm' and `-lXt' as follows:
-
- LIBW= /usr/lib/libXm.a /usr/ccs/lib/libgen.a
- LIBXT= $(LIBW) -lXmu /usr/lib/libXt.a $(LIBXTR6) -lXext
-
-SONY News (m68k-sony-bsd4.2 or m68k-sony-bsd4.3)
-
- 18.52 worked. Use m68k-sony-bsd4.3 for system release 3.
-
-SONY News 3000 series (RISC NEWS) (mips-sony-bsd)
-
- The 19.26 pretest is reported to work.
-
- Some versions of the operating system give SIGTRAP for division by zero
- instead of the usual signals. This causes division by zero
- to make Emacs crash. The system should be fixed to give the proper signal.
- Changing Emacs is not a proper solution, because it would prevent
- Emacs from working under any debugger. But you can change init_data
- in data.c if you wish.
-
-Stardent i860 (i860-stardent-sysv4.0)
-
- 19.26 pretest reported to work.
-
-Stardent 1500 or 3000
-
- See Titan.
-
-Stride (m68k-stride-sysv)
-
- Works (most recent news for 18.30) on their release 2.0.
- For release 2.2, see the end of `src/m/stride.h'.
- It may be possible to run on their V.1 system but changes
- in the s- file would be needed.
-
-Sun 3, Sun 4 (sparc), Sun 386 (m68k-sun-sunos, sparc-sun-sunos, i386-sun-sunos,
- sparc-sun-sunos4.1.3noshr, sparc-sun-solaris2.*,
- i386-sun-solaris2.*, sparc*-*-linux-gnu)
-
- To build a 64-bit Emacs (with larger maximum buffer size and
- including large file support) on a Solaris system which supports
- 64-bit executables, use the Sun compiler, configuring something like
- this (see the cc documentation for information on 64-bit
- compilation): env CC="cc -xarch=v9" ./configure
-
- As of version 2.95, GCC doesn't support the 64-bit ABI properly, but
- later releases may.
-
- On Solaris 2.7, building Emacs with WorkShop Compilers 5.0 98/12/15
- C 5.0 failed, apparently with non-default CFLAGS, most probably due to
- compiler bugs. Using Sun Solaris 2.7 Sun WorkShop 6 update 1 C
- release was reported to work without problems. It worked OK on
- another system with Solaris 8 using apparently the same 5.0 compiler
- and the default CFLAGS.
-
- Emacs 20.5 and later work on SPARC GNU/Linux with the 32-bit ABI.
- As of release 2.95, GCC doesn't work properly with the 64-bit ABI
- (applicable on UltraSPARC), but that isn't the default mode.
-
- Emacs 20.3 fails to build on Solaris 2.5 if you use GCC 2.7.2.3.
- Installing GCC 2.8 fixes the problem.
-
- 19.32 works on Solaris 2.4 and 2.5. On Solaris 2.5
- you may need one of these patches to prevent Emacs from crashing
- when it starts up:
- 103093-03: [README] SunOS 5.5: kernel patch (2140557 bytes)
- 102832-01: [README] OpenWindows 3.5: Xview Jumbo Patch (4181613 bytes)
- 103242-04: [README] SunOS 5.5: linker patch (595363 bytes)
-
- There are reports that using SunSoft cc with -xO4 -xdepend produces
- bad code for some part of Emacs.
-
- Emacs works ok Sunos 4.1.x
- provided you completely replace your C shared library
- using one of the SunOS 4.1.x jumbo replacement patches from Sun.
- Here are the patch numbers for Sunos 4.1.3:
- 100890-10 SunOS 4.1.3: domestic libc jumbo patch
- 100891-10 SunOS 4.1.3: international libc jumbo patch
-
- Some people report that Emacs crashes immediately on startup when
- used with a non-X terminal, but we think this is due to compiling
- with GCC and failing to use GCC's "fixed" system header files.
-
- Some Sun versions of X windows use the clipboard, not the selections,
- for transferring text between clients. The Cut, Paste and Copy items
- in the menu bar Edit menu work with the clipboard.
-
- It's important to include the SunOS version number in the
- configuration name. For example, for SunOS release 4.0 on a Sun 3,
- use `m68k-sun-sunos4.0'; for SunOS release 4.1 on a Sparc, use
- `sparc-sun-sunos4.1'. For SunOS release 4.1.3 on a Sparc, use
- `sparc-sun-sunos4.1.3'. Note that shared libraries are now
- used by default on SunOS 4.1.
-
- A user reported irreproducible segmentation faults when using 19.29
- on Solaris 2.3 and 2.4 after compiling it with the Sun compiler.
- The problem went away when GCC 2.7.0 was used instead. We do not know
- whether anything in Emacs is partly to blame for this.
-
- X11R6 is set up to make shared libraries only, on Sunos 4.
- Therefore, in order to link Emacs, you need to create static X libraries.
- To do this, rebuild X11 after setting
- #define ForceNormalLib YES
- #define SeparateSharedCompile YES
- in site.def (after #ifdef AfterVendorCF).
-
- Use `m68k' for the 68000-based Sun boxes, `sparc' for Sparcstations,
- and `i386' for Sun Roadrunners. i386 calls for Sunos4.0.
-
- If you compile with Sun's ANSI compiler acc, you need additional options
- when linking temacs, such as
- /usr/lang/SC2.0.1/values-Xt.o -L/usr/lang/SC2.0.1/cg87 -L/usr/lang/SC2.0.1
- (those should be added just before the libraries) and you need to
- add -lansi just before -lc. The precise file names depend on the
- compiler version, so we cannot easily arrange to supply them.
-
- On SunOS 4.1.1, do not use /usr/5bin/cc. You can use gcc or/usr/bin/cc.
- Make sure the environment variable LD_LIBRARY_PATH is not defined.
-
- Some people report crashes on SunOS 4.1.3 if SYSTEM_MALLOC is defined.
- Others have reported that Emacs works if SYSTEM_MALLOC is defined, and not
- if it is undefined. So far we do not know why results vary in this way.
- The sources are set up so that SYSTEM_MALLOC is defined; if that crashes,
- or if you want the benefit of the relocating memory allocator, you can
- try enabling the #undef SYSTEM_MALLOC in src/s/sunos4-1-3.h.
-
- On Solaris 2, you need to install patch 100947-02 to fix a system bug.
- Presumably this patch comes from Sun. You must alter the definition of
- LD_SWITCH_SYSTEM if your X11 libraries are not in /usr/openwin/lib.
- You must make sure that /usr/ucblib is not in your LD_LIBRARY_PATH.
-
- On Solaris 2.2, with a multiprocessor SparcCenter 1000, Emacs 19.17 is
- reported to hang sometimes if it exits while it has one or more
- subprocesses (e.g. the `wakeup' subprocess used by `display-time').
- Emacs and its subprocesses become zombies, and in their zombie state
- slow down their host and disable rlogin and telnet. This is most
- likely due to a bug in Solaris 2.2's multiprocessor support,
- rather than an Emacs bug.
-
- On Solaris, do not use /usr/ucb/cc. Use /opt/SUNWspro/bin/cc. Make
- sure that /usr/ccs/bin and /opt/SUNWspro/bin are in your PATH before
- /usr/ucb. (Most free software packages have the same requirement on
- Solaris.)
-
- If you have trouble using open-network-stream, get the distribution
- of `bind' (the BSD name-server), build libresolv.a, and link Emacs
- with -lresolv, by copying the #definition of LIBS_SYSTEM in
- src/s/sunos4-1.h to src/config.h. This problem is due to obsolete
- software in the nonshared standard library.
-
- If you want to use SunWindows, define HAVE_SUN_WINDOWS
- in config.h to enable a special interface called `emacstool'.
- The definition must *precede* the #include "machine.h".
- System version 3.2 is required for this facility to work.
-
- We recommend that you instead use the X window system, which
- has technical advantages, is an industry standard, and is also
- free software. The FSF does not support the SunWindows code;
- we installed it only on the understanding we would not let it
- divert our efforts from what we think is important.
-
- If you are compiling for X windows, and the X window library was
- compiled to use the 68881, then you must edit config.h according
- the comments at the end of `src/m/sun3.h'.
-
- Note that Emacs on a Sun is not really as big as it looks.
- As dumped, it includes around 200k of zeros between the
- original text section and the original data section
- (now remapped as part of the text). These are never
- swapped in.
-
- To build a single Emacs that will run on Sun 2 and Sun 3
- HARDWARE, just build it on the Sun 2.
-
- On Sunos 4.1.3, the word is that Emacs can loop infinitely
- on startup with X due perhaps to a bug in Sunos. Installing all of
- these Sun patches fixes the problem. We don't know which of them
- are really relevant.
-
- 100075-11 100224-06 100347-03 100482-05 100557-02 100623-03 100804-03
- 101080-01 100103-12 100249-09 100496-02 100564-07 100630-02 100891-10
- 101134-01 100170-09 100296-04 100377-09 100507-04 100567-04 100650-02
- 101070-01 101145-01 100173-10 100305-15 100383-06 100513-04 100570-05
- 100689-01 101071-03 101200-02 100178-09 100338-05 100421-03 100536-02
- 100584-05 100784-01 101072-01 101207-01
-
-Tadpole 68K (m68k-tadpole-sysv)
-
- Changes merged in 19.1.
-
- You may need to edit Makefile to change the variables LIBDIR and
- BINDIR from /usr/local to /usr/contrib.
-
- To give movemail access to /usr/mail, you may need to execute
-
- chmod 2755 etc/movemail; chgrp mail etc/movemail
-
-Tahoe (tahoe-tahoe-bsd4.2 or tahoe-tahoe-bsd4.3)
-
- 18.52 was known to work on some Tahoes, but a compiler bug intervenes
- on others. Some Emacs versions have worked in Unisys 1r4
- (not in 1r3) and CCI I.21.
-
- If you have trouble compiling `lib-src/loadst.c', turn off the definition
- of DKSTAT_HEADER_FILE in `src/m/tahoe.h'.
-
-Tandem Integrity S2 (mips-tandem-sysv)
-
- Changes merged in 18.56 but subprocess support is turned off.
- You will probably want to see if you can make subprocesses work.
-
- You must edit `lib-src/Makefile' to define LOADLIBES = -mld.
-
-Tektronix XD88 (m88k-tektronix-sysv3*)
-
- The 19.26 pretest was reported to work.
- Minor changes merged in 19.19.
-
-Tektronix 16000 box (6130?) (ns16k-tektronix-bsd)
-
- Emacs 17.61 worked.
-
-Tektronix 4300 (m68k-tektronix-bsd)
-
- Emacs 19.26 pretest reported to work.
-
-Titan P2 or P3 (titan-titan-sysv)
-
- Changes probably merged in version 19.
-
-Ustation E30 (SS5E) (m68k-unisys-unipl)
-
- Changes merged in 18.52; don't know whether they work.
-
-Vaxen running Berkeley Unix (vax-dec-bsd4.1, vax-dec-bsd4.2, vax-dec-bsd4.3),
- Ultrix (vax-dec-ultrix),
- System V (vax-dec-sysv0, vax-dec-sysv2), or
- VMS (vax-dec-vms)
-
- Works.
-
- See under Ultrix for problems using X windows on Ultrix (vax-dec-ultrix).
-
- 18.27 worked on System V rel 2 (vax-dec-sysv2).
-
- 18.36 worked on System V rel 0 (vax-dec-sysv0).
-
- Richard Levitte <levitte@e.kth.se> distributes a set of patches to
- Emacs 18.59 to make it work nicely under VMS. Emacs 19 probably
- won't work very well, or even compile. Levitte is working on a
- port, so these problems should be fixed in the near future.
-
-Whitechapel MG1 (ns16k-whitechapel-?)
-
- May work. Supposedly no changes were needed except in `src/m/mg1.h'
- file. I do not know what Unix version runs on them.
-
-Wicat (m68k-wicat-sysv)
-
- Changes merged as of 18.6; whether they work is unknown.
- See comments in `src/m/wicat.h' for things you should change
- depending on the system and compiler version you have.
-\f
-Here are notes about some of the systems supported:
-
-Berkeley 4.1 (bsd4.1)
-
- Works on vaxes.
-
-Berkeley 4.2 (bsd4.2)
-
- Works on several machines.
-
-Berkeley 4.3 (bsd4.3)
-
- Works, on Vaxes at least.
-
-Esix
-
- The following was written for Emacs 18.59 and has been
- slightly adapted for Emacs 19. It may need more change to be correct.
-
- Use s/usg5-4.h for Esix System V 4.0.[34] systems if you also have
- XFree86. If you insist on using the Esix X Window libraries, good
- luck. s/esix5r4.h provides a starting point, but doesn't seem to
- work consistently. The basic problems involve the need to load
- -lX11 *last* in the link command, and even then some things break.
- You get best results by installing XFree86 and forgetting about the
- Esix stuff unless you want to run IXI xdt3, which really only needs
- the Esix X11 shared libraries.
-
- To compile with XFree86, make sure that your LD_LIBRARY_PATH
- contains /usr/X386/lib. Be careful if you also have the Esix X
- Window libraries that /usr/X386/lib appears *first* in the
- LD_LIBRARY_PATH. Then define C_SWITCH_X_SYSTEM -I/usr/X386/include.
-
-Linux (actually GNU/Linux)
-
- Most of the complete systems which use the Linux kernel are close
- enough to the GNU system to be considered variant GNU systems. We
- call them "Linux-based GNU systems," or GNU/Linux for short.
-
- It is not coincidence that many of the other components used with
- Linux--including GNU Emacs--were developed specifically for the GNU
- project. The GNU project was launched in 1984 to develop a free
- complete Unix-like operating system. To reach this goal, we had to
- develop whatever system components were not available as freely
- redistributable software from some other source.
-
- The GNU project wants users of GNU/Linux systems to be aware of how
- these systems relate to the GNU project, because that will help
- spread the GNU idea that software should be free--and thus encourage
- people to write more free software. See the file LINUX-GNU in this
- directory for more explanation.
-
-Microport
-
- See under "Intel 386".
-
-MSDOS
-
- For installation on MSDOS, see the file INSTALL (search for `MSDOG',
- near the end of the file). See the "MS-DOS" chapter of the manual
- for information about using Emacs on MSDOS.
-
-SCO Unix
- If you have TCP but not X, you need to edit src/s/sco4.h
- to define HAVE_SOCKETS.
-
- If you are using MMDF instead of sendmail, you need to remove
- /usr/lib/sendmail or modify lisp/paths.el before compiling.
- lisp/paths.el (which is loaded during the build) will attempt to use
- sendmail if it exists.
-
- If you are using SMAIL, you need to define the macro
- SMAIL in config.h.
-
-System V rel 0 (usg5.0)
-
- Works, on Vaxes and 3bxxx's.
- There are some problems in 18.37 due to shortnames/cccp problems:
- use the emacs 17 cpp if you have it.
-
-System V rel 2 (usg5.2)
-
- Works on various machines.
- On some (maybe all) machines the library -lPW exists and contains
- a version of `alloca'. On these machines, to use it, put
- #define HAVE_ALLOCA
- #define LIB_STANDARD -lPW -lc
- in the `src/m/MACHINENAME.h' file for the machine.
-
- If you find that the character Meta-DEL makes Emacs crash,
- find where function init_sys_modes in sysdep.c sets sg.c_cc[VQUIT]
- and make it store 7 there. I have as yet no evidence of whether
- this problem, known in HP/UX, exists in other system V versions.
-
-System V rel 2.2 (usg5.2.2)
-
- In 5.2.2 AT&T undid, incompatibly, their previous incompatible
- change to the way the nlist library is called. A different s- file
- is used to enable the other interface.
-
- They call themselves the right choice--can't they choose?
-
- Emacs version 18 unexec is currently not working properly
- on 5.2.2. Nobody knows why yet. A workaround is to define
- NO_REMAP. It is not yet known whether this applies to all
- machines running 5.2.2.
-
-System V rel 3 (usg5.3)
-
- Some versions of this system support ptys and BSD-style sockets.
- On such systems, you should define HAVE_PTYS and HAVE_SOCKETS in config.h.
-
- If you want to link Emacs with shared libraries, define
- USG_SHARED_LIBRARIES.
-
- You may have to add ANSI idempotence #-lines to your sys/types.h
- file to get Emacs to compile correctly. This may be necessary on
- other pre-ANSI systems as well.
-
- On an AT&T 6386WGS using System V Release 3.2 and X11R3, the X support
- cannot be made to work. Whether or not the GNU relocating malloc is
- used, the symptom is that the first call Emacs makes to sbrk(0) returns
- (char *)-1. Sorry, you're stuck with character-only mode. Try
- installing Xfree86 to fix this.
-
-System V rel 4.0.3 and 4.0.4 (usg5.4)
-
- Supported, including shared libraries for ELF, but ptys do not work
- because TIOCGPGRP fails to work on ptys (but Dell 2.2 seems to have
- fixed this). This failure is probably due to a misunderstanding of
- the consequences of the POSIX spec: many system designers mistakenly
- think that POSIX requires this feature to fail. This is untrue;
- ptys are an extension, and POSIX says that extensions *when used*
- may change the action of standard facilities in any fashion.
-
- If you get compilation errors about wrong number of
- arguments to getpgrp, define GETPGRP_NO_ARG.
-
- The standard C preprocessor may generate xmakefile incorrectly. However,
- /lib/cpp will work, so use `make CPP=/lib/cpp'. Standard cpp
- seems to work OK under Dell 2.2.
-
- Some versions 3 and earlier of V.4, on the Intel 386 and 860, had
- problems in the X11 libraries. These prevent Emacs from working
- with X. You can use Emacs with X provided your copy of X is based
- on X11 release 4 or newer, or is Dell's 2.2 (which is a 4.0.3).
- Unfortunately, the only way you can tell whether your X11 library is
- new enough is to try compiling Emacs to use X. If emacs runs, your
- X11 library is new enough.
-
- In this context, GSV4 and GSV4i are alternate names for X11R4.
- OL2.* is X11R3 based. OL3 is in between X11R3 and X11R4, and may or
- may not work, depending on who made the Unix system. If the library
- libXol is part of the X distribution, then you have X11R3 and Emacs
- won't work with X.
-
- Most versions of V.4 support sockets. If `/usr/lib/libsocket.so'
- exists, your system supports them. If yours does not, you must add
- #undef HAVE_SOCKETS in config.h, after the inclusion of s-usg5-4.h.
- (Any system that supports Internet should implement sockets.)
-
-Ultrix (bsd4.3)
-
- Recent versions of Ultrix appear to support the features of Berkeley 4.3.
- Ultrix was at the BSD 4.2 level for a long time after BSD 4.3 came out.
-
- Ultrix 3.0 has incompatibilities in its X library if you have the
- Ultrix version of X (UWS version 2.0). To solve them, you need to
- prevent XvmsAlloc.o in Xlib from being used. Israel Pinkas says:
-
- I added the following lines to config.h after the X defines:
-
- #if defined(ultrix) && defined(X11)
- #define OBJECTS_SYSTEM calloc.o
- #endif
-
- Then I ran the following:
-
- ar x /usr/lib/libc.a calloc.o
-
- The problem is said to be gone in UWS version 2.1.
-
-Uniplus 5.2 (unipl5.2)
-
- Works, on Dual machines at least.
-
-VMS (vmsM.N)
-
- Richard Levitte <levitte@e.kth.se> distributes a set of patches to
- Emacs 18.59 to make it work nicely under VMS. Emacs 19 probably
- won't work very well, or even compile. Levitte is working on a
- port, so these problems should be fixed in the near future.
-
- Note that Emacs for VMS is usually distributed in a special VMS
- distribution. See the file ../vms/VMSINSTALL for info on moving
- Unix distributions to VMS, and other VMS-related topics.
-
-Windows NT/95/98/ME/2000
-
- For installation on all versions of the MS-Windows platform, see the
- file nt/INSTALL.
-
-Xenix (xenix)
-
- Should work in 18.50, but you will need to edit the files
- `lib-src/Makefile' and `src/ymakefile'
- (see the comments that mention "Xenix" for what to change.)
- Compiling Emacs with -O is said not to work.
-
- If you want Emacs to work with Smail (installed as /usr/bin/smail)
- then add the line #define SMAIL to config.h.
-
- The file etc/XENIX suggests some useful things to do to Xenix
- to make the Emacs meta key work.
-\f
-Local variables:
-mode: indented-text
-fill-prefix: " "
-End:
+++ /dev/null
-Things useful to do for GNU Emacs:
-
-* Primitive for random access insertion of part of a file.
-
-* Making I/O streams for files, so that read and prin1 can
- be used on files directly. The I/O stream itself would
- serve as a function to read or write one character.
-
-* If a file you can't write is in a directory you can write,
- make sure it works to modify and save this file.
-
-* Make dired's commands handle correctly the case where
- ls has listed several subdirectories' contents.
- It needs to be able to tell which directory each file
- is really in, by searching backward for the line
- which identifies the start of a directory.
-
-* Add more dired commands, such as sorting (use the
- sort utility through call-process-region).
-
-* Make display.c record inverse-video-ness on
- a character by character basis. Then make non-full-screen-width
- mode lines inverse video, and display the marked location in
- inverse video.
-
-* VMS code to list a file directory. Make dired work.
-
-Long range:
-
- Ideas for extending GNU Emacs to deal with arbitrary character sets.
-
-I would like GNU Emacs to be extended to handle all the world's alphabets
-and word signs. I don't expect to have time to do such a thing in the next
-few years, so here are my ideas on the best way to do it.
-
-* Each graphic is represented by a sequence of ordinary 8-bit characters.
-
-* All the characters that make up such a sequence have codes >= 0200.
-
-* The first character of such a sequence is between 0200 and 0237.
-
-* The remaining characters of such a sequence are all 0240 or higher.
-
-* The first character of the sequence determines the number of characters
-in the sequence. Thus, 0200...0207 could start two-character sequences,
-0210...0227 could start three-character sequences, and 0230 could start
-four-character sequences. (Codes 0231...0237 would be reserved.)
-
-* Several common alphabets, and some mathematical symbols, would get
-two-character sequences. (Probably Greek, Russian, Hebrew(?), Arabic(?),
-Korean, and Japanese kana). The remaining alphabets, and some versions of
-Chinese, would get three-character sequences. Other sets of Chinese
-characters would get four-character sequences.
-
-Each country that uses Chinese characters has its own standard character
-set, and it is not easy to correlate them to avoid overlap. So there may
-need to be several sets of Chinese characters. That is why they need so
-much code space.
-
-True support for Hebrew and Arabic requires dealing with the problem of
-writing direction for mixed text; I don't know what to do for that.
-
-* The functions that use syntax table would determine the
-syntax of a sequence from its first character.
-
-* Functions in indent.c for computing widths and columns would
-determine the width of a sequence from its first character.
-So would display routines.
-
-* Only a few other editing routines would need any change. In
-particular, searching and regexp matching might not need any change.
-
-* Most of the work required would be in redisplay. The only case that
-needs to be supported is with X windows, since ordinary terminals
-can't display all these characters anyway.
-
-* There might need to be code to translate files from this format
-to whatever format is typically stored on disk.
-
-
-I would be very unhappy with half-measures, such as support for
-Japanese only.
-
+++ /dev/null
-@setfilename LNEWS
-
-@section New Features in the Lisp Language
-
-@end itemize
-@itemize @bullet
-@item
-The new function @code{delete} is a traditional Lisp function. It takes
-two arguments, @var{elt} and @var{list}, and deletes from @var{list} any
-elements that are equal to @var{elt}. It uses the function @code{equal}
-to compare elements with @var{elt}.
-
-@item
-The new function @code{member} is a traditional Lisp function. It takes
-two arguments, @var{elt} and @var{list}, and finds the first element of
-@var{list} that is equal to @var{elt}. It uses the function
-@code{equal} to compare each list element with @var{elt}.
-
-The value is a sublist of @var{list}, whose first element is the one
-that was found. If no matching element is found, the value is
-@code{nil}.
-
-@ignore @c Seems not to be true, from looking at the code.
-@item
-The function @code{equal} is now more robust: it does not crash due to
-circular list structure.
-@end ignore
-
-@item
-The new function @code{indirect-function} finds the effective function
-definition of an object called as a function. If the object is a
-symbol, @code{indirect-function} looks in the function definition of the
-symbol. It keeps doing this until it finds something that is not a
-symbol.
-
-@item
-There are new escape sequences for use in character and string
-constants. The escape sequence @samp{\a} is equivalent to @samp{\C-g},
-the @sc{ASCII} @sc{BEL} character (code 7). The escape sequence
-@samp{\x} followed by a hexidecimal number represents the character
-whose @sc{ASCII} code is that number. There is no limit on the number
-of digits in the hexidecimal value.
-
-@item
-The function @code{read} when reading from a buffer now does not skip a
-terminator character that terminates a symbol. It leaves that character
-to be read (or just skipped, if it is whitespace) next time.
-
-@item
-When you use a function @var{function} as the input stream for
-@code{read}, it is usually called with no arguments, and should return
-the next character. In Emacs 19, sometimes @var{function} is called
-with one argument (always a character). When that happens,
-@var{function} should save the argument and arrange to return it when
-called next time.
-
-@item
-@code{random} with integer argument @var{n} returns a random number
-between 0 and @var{n}@minus{}1.
-
-@item
-The functions @code{documentation} and @code{documentation-property} now
-take an additional optional argument which, if non-@code{nil}, says to
-refrain from calling @code{substitute-command-keys}. This way, you get
-the exact text of the documentation string as written, without the usual
-substitutions. Make sure to call @code{substitute-command-keys}
-yourself if you decide to display the string.
-
-@ignore
-@item
-The new function @code{invocation-name} returns as a string the program
-name that was used to run Emacs, with any directory names discarded.
-@c ??? This hasn't been written yet. ???
-@end ignore
-
-@item
-The new function @code{map-y-or-n-p} makes it convenient to ask a series
-of similar questions. The arguments are @var{prompter}, @var{actor},
-@var{list}, and optional @var{help}.
-
-The value of @var{list} is a list of objects, or a function of no
-arguments to return either the next object or @code{nil} meaning there
-are no more.
-
-The argument @var{prompter} specifies how to ask each question. If
-@var{prompter} is a string, the question text is computed like this:
-
-@example
-(format @var{prompter} @var{object})
-@end example
-
-@noindent
-where @var{object} is the next object to ask about.
-
-If not a string, @var{prompter} should be a function of one argument
-(the next object to ask about) and should return the question text.
-
-The argument @var{actor} should be a function of one argument, which is
-called with each object that the user says yes for. Its argument is
-always one object from @var{list}.
-
-If @var{help} is given, it is a list @code{(@var{object} @var{objects}
-@var{action})}, where @var{object} is a string containing a singular
-noun that describes the objects conceptually being acted on;
-@var{objects} is the corresponding plural noun and @var{action} is a
-transitive verb describing @var{actor}. The default is @code{("object"
-"objects" "act on")}.
-
-Each time a question is asked, the user may enter @kbd{y}, @kbd{Y}, or
-@key{SPC} to act on that object; @kbd{n}, @kbd{N}, or @key{DEL} to skip
-that object; @kbd{!} to act on all following objects; @key{ESC} or
-@kbd{q} to exit (skip all following objects); @kbd{.} (period) to act on
-the current object and then exit; or @kbd{C-h} to get help.
-
-@code{map-y-or-n-p} returns the number of objects acted on.
-
-@item
-You can now ``set'' environment variables with the @code{setenv}
-command. This works by setting the variable @code{process-environment},
-which @code{getenv} now examines in preference to the environment Emacs
-received from its parent.
-@end itemize
-
-@section New Features for Loading Libraries
-
-You can now arrange to run a hook if a particular Lisp library is
-loaded.
-
-The variable @code{after-load-alist} is an alist of expressions to be
-evalled when particular files are loaded. Each element looks like
-@code{(@var{filename} @var{forms}@dots{})}.
-
-When @code{load} is run and the file name argument equals
-@var{filename}, the @var{forms} in the corresponding element are
-executed at the end of loading. @var{filename} must match exactly!
-Normally @var{filename} is the name of a library, with no directory
-specified, since that is how @code{load} is normally called.
-
-An error in @var{forms} does not undo the load, but does prevent
-execution of the rest of the @var{forms}.
-
-The function @code{eval-after-load} provides a convenient way to add
-entries to the alist. Call it with two arguments, @var{file} and a
-form to execute.
-
-The function @code{autoload} now supports autoloading a keymap.
-Use @code{keymap} as the fourth argument if the autoloaded function
-will become a keymap when loaded.
-
-There is a new feature for specifying which functions in a library should
-be autoloaded by writing special ``magic'' comments in that library itself.
-
- Write @samp{;;;###autoload} on a line by itself before a function
-definition before the real definition of the function, in its
-autoloadable source file; then the command @kbd{M-x
-update-file-autoloads} automatically puts the @code{autoload} call into
-@file{loaddefs.el}.
-
- You can also put other kinds of forms into @file{loaddefs.el}, by
-writing @samp{;;;###autoload} followed on the same line by the form.
-@kbd{M-x update-file-autoloads} copies the form from that line.
-
-@section Compilation Features
-
-@itemize @bullet
-@item
-Inline functions.
-
-You can define an @dfn{inline function} with @code{defsubst}. Use
-@code{defsubst} just like @code{defun}, and it defines a function which
-you can call in all the usual ways. Whenever the function thus defined
-is used in compiled code, the compiler will open code it.
-
-You can get somewhat the same effects with a macro, but a macro has the
-limitation that you can use it only explicitly; a macro cannot be called
-with @code{apply}, @code{mapcar} and so on. Also, it takes some work to
-convert an ordinary function into a macro. To convert it into an inline
-function, simply replace @code{defun} with @code{defsubst}.
-
-Making a function inline makes explicit calls run faster. But it also
-has disadvantages. For one thing, it reduces flexibility; if you change
-the definition of the function, calls already inlined still use the old
-definition until you recompile them.
-
-Another disadvantage is that making a large function inline can increase
-the size of compiled code both in files and in memory. Since the
-advantages of inline functions are greatest for small functions, you
-generally should not make large functions inline.
-
-Inline functions can be used and open coded later on in the same file,
-following the definition, just like macros.
-
-@item
-The command @code{byte-compile-file} now offers to save any buffer
-visiting the file you are compiling.
-
-@item
-The new command @code{compile-defun} reads, compiles and executes the
-defun containing point. If you use this on a defun that is actually a
-function definition, the effect is to install a compiled version of
-that function.
-
-@item
-Whenever you load a Lisp file or library, you now receive a warning if
-the directory contains both a @samp{.el} file and a @samp{.elc} file,
-and the @samp{.el} file is newer. This typically indicates that someone
-has updated the Lisp code but forgotten to recompile it, so the changes
-do not take effect. The warning is a reminder to recompile.
-
-@item
-The special form @code{eval-when-compile} marks the forms it contains to
-be evaluated at compile time @emph{only}. At top-level, this is
-analogous to the Common Lisp idiom @code{(eval-when (compile)
-@dots{})}. Elsewhere, it is similar to the Common Lisp @samp{#.} reader
-macro (but not when interpreting).
-
-If you're thinking of using this feature, we recommend you consider whether
-@code{provide} and @code{require} might do the job as well.
-
-@item
-The special form @code{eval-and-compile} is similar to
-@code{eval-when-compile}, but the whole form is evaluated both at
-compile time and at run time.
-
-If you're thinking of using this feature, we recommend you consider
-whether @code{provide} and @code{require} might do the job as well.
-
-@item
-Emacs Lisp has a new data type for byte-code functions. This makes
-them faster to call, and also saves space. Internally, a byte-code
-function object is much like a vector; however, the evaluator handles
-this data type specially when it appears as a function to be called.
-
-The printed representation for a byte-code function object is like that
-for a vector, except that it starts with @samp{#} before the opening
-@samp{[}. A byte-code function object must have at least four elements;
-there is no maximum number, but only the first six elements are actually
-used. They are:
-
-@table @var
-@item arglist
-The list of argument symbols.
-
-@item byte-code
-The string containing the byte-code instructions.
-
-@item constants
-The vector of constants referenced by the byte code.
-
-@item stacksize
-The maximum stack size this function needs.
-
-@item docstring
-The documentation string (if any); otherwise, @code{nil}.
-
-@item interactive
-The interactive spec (if any). This can be a string or a Lisp
-expression. It is @code{nil} for a function that isn't interactive.
-@end table
-
-The predicate @code{byte-code-function-p} tests whether a given object
-is a byte-code function.
-
-You can create a byte-code function object in a Lisp program
-with the function @code{make-byte-code}. Its arguments are the elements
-to put in the byte-code function object.
-
-You should not try to come up with the elements for a byte-code function
-yourself, because if they are inconsistent, Emacs may crash when you
-call the function. Always leave it to the byte compiler to create these
-objects; it, we hope, always makes the elements consistent.
-@end itemize
-
-@section Floating Point Numbers
-
-You can now use floating point numbers in Emacs, if you define the macro
-@code{LISP_FLOAT_TYPE} when you compile Emacs.
-
-The printed representation for floating point numbers requires either a
-decimal point surrounded by digits, or an exponent, or both. For
-example, @samp{1500.0}, @samp{15e2}, @samp{15.0e2} and @samp{1.5e3} are
-four ways of writing a floating point number whose value is 1500.
-
-The existing predicate @code{numberp} now returns @code{t} if the
-argument is any kind of number---either integer or floating. The new
-predicates @code{integerp} and @code{floatp} check for specific types of
-numbers.
-
-You can do arithmetic on floating point numbers with the ordinary
-arithmetic functions, @code{+}, @code{-}, @code{*} and @code{/}. If you
-call one of these functions with both integers and floating point
-numbers among the arguments, the arithmetic is done in floating point.
-The same applies to the numeric comparison functions such as @code{=}
-and @code{<}. The remainder function @code{%} does not accept floating
-point arguments, and neither do the bitwise boolean operations such as
-@code{logand} or the shift functions such as @code{ash}.
-
-There is a new arithmetic function, @code{abs}, which returns the absolute
-value of its argument. It handles both integers and floating point
-numbers.
-
-To convert an integer to floating point, use the function @code{float}.
-There are four functions to convert floating point numbers to integers;
-they differ in how they round. @code{truncate} rounds toward 0,
-@code{floor} rounds down, @code{ceil} rounds up, and @code{round}
-produces the nearest integer.
-
-You can use @code{logb} to extract the binary exponent of a floating
-point number. More precisely, it is the logarithm base 2, rounded down
-to an integer.
-
-Emacs has several new mathematical functions that accept any kind of
-number as argument, but always return floating point numbers.
-
-@table @code
-@item cos
-@findex cos
-@itemx sin
-@findex sin
-@itemx tan
-@findex tan
-Trigonometric functions.
-@item acos
-@findex acos
-@itemx asin
-@findex asin
-@itemx atan
-@findex atan
-Inverse trigonometric functions.
-@item exp
-@findex exp
-The exponential function (power of @var{e}).
-@item log
-@findex log
-Logarithm base @var{e}.
-@item expm1
-@findex expm1
-Power of @var{e}, minus 1.
-@item log1p
-@findex log1p
-Add 1, then take the logarithm.
-@item log10
-@findex log10
-Logarithm base 10
-@item expt
-@findex expt
-Raise @var{x} to power @var{y}.
-@item sqrt
-@findex sqrt
-The square root function.
-@end table
-
-The new function @code{string-to-number} now parses a string containing
-either an integer or a floating point number, returning the number.
-
-The @code{format} function now handles the specifications @samp{%e},
-@samp{%f} and @samp{%g} for printing floating point numbers; likewise
-@code{message}.
-
-The new variable @code{float-output-format} controls how Lisp prints
-floating point numbers. Its value should be @code{nil} or a string.
-
-If it is a string, it should contain a @samp{%}-spec like those accepted
-by @code{printf} in C, but with some restrictions. It must start with
-the two characters @samp{%.}. After that comes an integer which is the
-precision specification, and then a letter which controls the format.
-
-The letters allowed are @samp{e}, @samp{f} and @samp{g}. Use @samp{e}
-for exponential notation (@samp{@var{dig}.@var{digits}e@var{expt}}).
-Use @samp{f} for decimal point notation
-(@samp{@var{digits}.@var{digits}}). Use @samp{g} to choose the shorter
-of those two formats for the number at hand.
-
-The precision in any of these cases is the number of digits following
-the decimal point. With @samp{f}, a precision of 0 means to omit the
-decimal point. 0 is not allowed with @samp{f} or @samp{g}.
-
-A value of @code{nil} means to use the format @samp{%.20g}.
-
-No matter what the value of @code{float-output-format}, printing ensures
-that the result fits the syntax rules for a floating point number. If
-it doesn't fit (for example, if it looks like an integer), it is
-modified to fit. By contrast, the @code{format} function formats
-floating point numbers without requiring the output to fit the
-syntax rules for floating point number.
-
-@section New Features for Printing And Formatting Output
-
-@itemize @bullet
-@item
-The @code{format} function has a new feature: @samp{%S}. This print
-spec prints any kind of Lisp object, even a string, using its Lisp
-printed representation.
-
-By contrast, @samp{%s} prints everything without quotation.
-
-@item
-@code{prin1-to-string} now takes an optional second argument which says
-not to print the Lisp quotation characters. (In other words, to use
-@code{princ} instead of @code{prin1}.)
-
-@item
-The new variable @code{print-level} specifies the maximum depth of list
-nesting to print before cutting off all deeper structure. A value of
-@code{nil} means no limit.
-@end itemize
-
-@section Changes in Basic Editing Functions
-
-@itemize @bullet
-@item
-There are two new primitives for putting text in the kill ring:
-@code{kill-new} and @code{kill-append}.
-
-The function @code{kill-new} adds a string to the front of the kill ring.
-
-Use @code{kill-append} to add a string to a previous kill. The second
-argument @var{before-p}, if non-@code{nil}, says to add the string at
-the beginning; otherwise, it goes at the end.
-
-Both of these functions apply @code{interprogram-cut-function} to the
-entire string of killed text that ends up at the beginning of the kill
-ring.
-
-@item
-The new function @code{current-kill} rotates the yanking pointer in the
-kill ring by @var{n} places, and returns the text at that place in the
-ring. If the optional second argument @var{do-not-move} is
-non-@code{nil}, it doesn't actually move the yanking point; it just
-returns the @var{n}th kill forward. If @var{n} is zero, indicating a
-request for the latest kill, @code{current-kill} calls
-@code{interprogram-paste-function} (documented below) before consulting
-the kill ring.
-
-All Emacs Lisp programs should either use @code{current-kill},
-@code{kill-new}, and @code{kill-append} to manipulate the kill ring, or
-be sure to call @code{interprogram-paste-function} and
-@code{interprogram-cut-function} as appropriate.
-
-@item
-The variables @code{interprogram-paste-function} and
-@code{interprogram-cut-function} exist so that you can provide functions
-to transfer killed text to and from other programs.
-
-@item
-The @code{kill-region} function can now be used in read-only buffers.
-It beeps, but adds the region to the kill ring without deleting it.
-
-@item
-The new function @code{compare-buffer-substrings} lets you compare two
-substrings of the same buffer or two different buffers. Its arguments
-look like this:
-
-@example
-(compare-buffer-substrings @var{buf1} @var{beg1} @var{end1} @var{buf2} @var{beg2} @var{end2})
-@end example
-
-The first three arguments specify one substring, giving a buffer and two
-positions within the buffer. The last three arguments specify the other
-substring in the same way.
-
-The value is negative if the first substring is less, positive if the
-first is greater, and zero if they are equal. The absolute value of
-the result is one plus the index of the first different characters.
-
-@item
-Overwrite mode treats tab and newline characters specially. You can now
-turn off this special treatment by setting @code{overwrite-binary-mode}
-to @code{t}.
-
-@item
-Once the mark ``exists'' in a buffer, it normally never ceases to
-exist. However, it may become @dfn{inactive}. The variable
-@code{mark-active}, which is always local in all buffers, indicates
-whether the mark is active: non-@code{nil} means yes.
-
-A command can request deactivation of the mark upon return to the editor
-command loop by setting @code{deactivate-mark} to a non-@code{nil}
-value. Transient Mark mode works by causing the buffer modification
-primitives to set @code{deactivate-mark}.
-
-The variables @code{activate-mark-hook} and @code{deactivate-mark-hook}
-are normal hooks run, respectively, when the mark becomes active andwhen
-it becomes inactive. The hook @code{activate-mark-hook} is also run at
-the end of a command if the mark is active and the region may have
-changed.
-
-@item
-The function @code{move-to-column} now accepts a second optional
-argument @var{force}, in addition to @var{column}; if the requested
-column @var{column} is in the middle of a tab character and @var{force}
-is non-@code{nil}, @code{move-to-column} replaces the tab with the
-appropriate sequence of spaces so that it can place point exactly at
-@var{column}.
-
-@item
-The search functions when successful now return the value of point
-rather than just @code{t}. This affects the functions
-@code{search-forward}, @code{search-backward},
-@code{word-search-forward}, @code{word-search-backward},
-@code{re-search-forward}, and @code{re-search-backward}.
-
-@item
-When you do regular expression searching or matching, there is no longer
-a limit to how many @samp{\(@dots{}\)} pairs you can get information
-about with @code{match-beginning} and @code{match-end}. Also, these
-parenthetical groupings may now be nested to any degree.
-
-@item
-The new special form @code{save-match-data} preserves the regular
-expression match status. Usage: @code{(save-match-data
-@var{body}@dots{})}.
-
-@item
-The function @code{translate-region} applies a translation table to the
-characters in a part of the buffer. Invoke it as
-@code{(translate-region @var{start} @var{end} @var{table})}; @var{start}
-and @var{end} bound the region to translate.
-
-The translation table @var{table} is a string; @code{(aref @var{table}
-@var{ochar})} gives the translated character corresponding to
-@var{ochar}. If the length of @var{table} is less than 256, any
-characters with codes larger than the length of @var{table} are not
-altered by the translation.
-
-@code{translate-region} returns the number of characters which were
-actually changed by the translation. This does not count characters
-which were mapped into themselves in the translation table.
-
-@item
-There are two new hook variables that let you notice all changes in all
-buffers (or in a particular buffer, if you make them buffer-local):
-@code{before-change-function} and @code{after-change-function}.
-
-If @code{before-change-function} is non-@code{nil}, then it is called
-before any buffer modification. Its arguments are the beginning and end
-of the region that is going to change, represented as integers. The
-buffer that's about to change is always the current buffer.
-
-If @code{after-change-function} is non-@code{nil}, then it is called
-after any buffer modification. It takes three arguments: the beginning
-and end of the region just changed, and the length of the text that
-existed before the change. (To get the current length, subtract the
-rrgion beginning from the region end.) All three arguments are
-integers. The buffer that's about to change is always the current
-buffer.
-
-Both of these variables are temporarily bound to @code{nil} during the
-time that either of these hooks is running. This means that if one of
-these functions changes the buffer, that change won't run these
-functions. If you do want hooks to be run recursively, write your hook
-functions to bind these variables back to their usual values.
-
-@item
-The hook @code{first-change-hook} is run using @code{run-hooks} whenever
-a buffer is changed that was previously in the unmodified state.
-
-@item
-The second argument to @code{insert-abbrev-table-description} is
-now optional.
-@end itemize
-
-@section Text Properties
-
- Each character in a buffer or a string can have a @dfn{text property
-list}, much like the property list of a symbol. The properties belong
-to a particular character at a particular place, such as, the letter
-@samp{T} at the beginning of this sentence. Each property has a name,
-which is usually a symbol, and an associated value, which can be any
-Lisp object---just as for properties of symbols (@pxref{Property Lists}).
-
- You can use the property @code{face-code} to control the font and
-color of text. That is the only property name which currently has a
-special meaning, but you can create properties of any name and examine
-them later for your own purposes.
-
- Copying text between strings and buffers preserves the properties
-along with the characters; this includes such diverse functions as
-@code{substring}, @code{insert}, and @code{buffer-substring}.
-
- Since text properties are considered part of the buffer contents,
-changing properties in a buffer ``modifies'' the buffer, and you can
-also undo such changes.
-
- Strings with text properties have a special printed representation
-which describes all the properties. This representation is also the
-read syntax for such a string. It looks like this:
-
-@example
-#("@var{characters}" @var{property-data}...)
-@end example
-
-@noindent
-where @var{property-data} is zero or more elements in groups of three as
-follows:
-
-@example
-@var{beg} @var{end} @var{plist}
-@end example
-
-@noindent
-The elements @var{beg} and @var{end} are integers, and together specify
-a portion of the string; @var{plist} is the property list for that
-portion.
-
-@subsection Examining Text Properties
-
- The simplest way to examine text properties is to ask for the value of
-a particular property of a particular character. For that, use
-@code{get-text-property}. Use @code{text-properties-at} to get the
-entire property list of a character. @xref{Property Search}, for
-functions to examine the properties of a number of characters at once.
-
-@code{(get-text-property @var{pos} @var{prop} @var{object})} returns the
-@var{prop} property of the character after @var{pos} in @var{object} (a
-buffer or string). The argument @var{object} is optional and defaults
-to the current buffer.
-
-@code{(text-properties-at @var{pos} @var{object})} returns the entire
-property list of the character after @var{pos} in the string or buffer
-@var{object} (which defaults to the current buffer).
-
-@subsection Changing Text Properties
-
- There are three primitives for changing properties of a specified
-range of text:
-
-@table @code
-@item add-text-properties
-This function puts on specified properties, leaving other existing
-properties unaltered.
-
-@item put-text-property
-This function puts on a single specified property, leaving others
-unaltered.
-
-@item remove-text-properties
-This function removes specified properties, leaving other
-properties unaltered.
-
-@item set-text-properties
-This function replaces the entire property list, leaving no vessage of
-the properties that that text used to have.
-@end table
-
-All these functions take four arguments: @var{start}, @var{end},
-@var{props}, and @var{object}. The last argument is optional and
-defaults to the current buffer. The argument @var{props} has the form
-of a property list.
-
-@subsection Property Search Functions
-
-In typical use of text properties, most of the time several or many
-consecutive characters have the same value for a property. Rather than
-writing your programs to examine characters one by one, it is much
-faster to process chunks of text that have the same property value.
-
-The functions @code{next-property-change} and
-@code{previous-property-change} scan forward or backward from position
-@var{pos} in @var{object}, looking for a change in any property between
-two characters scanned. They returns the position between those two
-characters, or @code{nil} if no change is found.
-
-The functions @code{next-single-property-change} and
-@code{previous-single-property-change} are similar except that you
-specify a particular property and they look for changes in the value of
-that property only. The property is the second argument, and
-@var{object} is third.
-
-@subsection Special Properties
-
- If a character has a @code{category} property, we call it the
-@dfn{category} of the character. It should be a symbol. The properties
-of the symbol serve as defaults for the properties of the character.
-
- You can use the property @code{face-code} to control the font and
-color of text. That is the only property name which currently has a
-special meaning, but you can create properties of any name and examine
-them later for your own purposes.
-about face codes.
-
- You can specify a different keymap for a portion of the text by means
-of a @code{local-map} property. The property's value, for the character
-after point, replaces the buffer's local map.
-
- If a character has the property @code{read-only}, then modifying that
-character is not allowed. Any command that would do so gets an error.
-
- If a character has the property @code{modification-hooks}, then its
-value should be a list of functions; modifying that character calls all
-of those functions. Each function receives two arguments: the beginning
-and end of the part of the buffer being modified. Note that if a
-particular modification hook function appears on several characters
-being modified by a single primitive, you can't predict how many times
-the function will be called.
-
- Insertion of text does not, strictly speaking, change any existing
-character, so there is a special rule for insertion. It compares the
-@code{read-only} properties of the two surrounding characters; if they
-are @code{eq}, then the insertion is not allowed. Assuming insertion is
-allowed, it then gets the @code{modification-hooks} properties of those
-characters and calls all the functions in each of them. (If a function
-appears on both characters, it may be called once or twice.)
-
- The special properties @code{point-entered} and @code{point-left}
-record hook functions that report motion of point. Each time point
-moves, Emacs compares these two property values:
-
-@itemize @bullet
-@item
-the @code{point-left} property of the character after the old location,
-and
-@item
-the @code{point-entered} property of the character after the new
-location.
-@end itemize
-
-@noindent
-If these two values differ, each of them is called (if not @code{nil})
-with two arguments: the old value of point, and the new one.
-
- The same comparison is made for the characters before the old and new
-locations. The result may be to execute two @code{point-left} functions
-(which may be the same function) and/or two @code{point-entered}
-functions (which may be the same function). The @code{point-left}
-functions are always called before the @code{point-entered} functions.
-
- A primitive function may examine characters at various positions
-without moving point to those positions. Only an actual change in the
-value of point runs these hook functions.
-
-@section New Features for Files
-
-@itemize @bullet
-@item
-The new function @code{file-accessible-directory-p} tells you whether
-you can open files in a particular directory. Specify as an argument
-either a directory name or a file name which names a directory file.
-The function returns @code{t} if you can open existing files in that
-directory.
-
-@item
-The new function @code{file-executable-p} returns @code{t} if its
-argument is the name of a file you have permission to execute.
-
-@item
-The function @code{file-truename} returns the ``true name'' of a
-specified file. This is the name that you get by following symbolic
-links until none remain. The argument must be an absolute file name.
-
-@item
-New functions @code{make-directory} and @code{delete-directory} create and
-delete directories. They both take one argument, which is the name of
-the directory as a file.
-
-@item
-The function @code{read-file-name} now takes an additional argument
-which specifies an initial file name. If you specify this argument,
-@code{read-file-name} inserts it along with the directory name. It puts
-the cursor between the directory and the initial file name.
-
-The user can then use the initial file name unchanged, modify it, or
-simply kill it with @kbd{C-k}.
-
-If the variable @code{insert-default-directory} is @code{nil}, then the
-default directory is not inserted, and the new argument is ignored.
-
-@item
-The function @code{file-relative-name} does the inverse of
-expansion---it tries to return a relative name which is equivalent to
-@var{filename} when interpreted relative to @var{directory}. (If such a
-relative name would be longer than the absolute name, it returns the
-absolute name instead.)
-
-@item
-The function @code{file-newest-backup} returns the name of the most
-recent backup file for @var{filename}, or @code{nil} that file has no
-backup files.
-
-@item
-The list returned by @code{file-attributes} now has 12 elements. The
-12th element is the file system number of the file system that the file
-is in. This element together with the file's inode number, which is the
-11th element, give enough information to distinguish any two files on
-the system---no two files can have the same values for both of these
-numbers.
-
-@item
-The new function @code{set-visited-file-modtime} updates the current
-buffer's recorded modification time from the visited file's time.
-
-This is useful if the buffer was not read from the file normally, or
-if the file itself has been changed for some known benign reason.
-
-If you give the function an argument, that argument specifies the new
-value for the recorded modification time. The argument should be a list
-of the form @code{(@var{high} . @var{low})} or @code{(@var{high}
-@var{low})} containing two integers, each of which holds 16 bits of the
-time. (This is the same format that @code[file-attributes} uses to
-return time values.)
-
-The new function @code{visited-file-modtime} returns the recorded last
-modification time, in that same format.
-
-@item
-The function @code{directory-files} now takes an optional fourth
-argument which, if non-@code{nil}, inhibits sorting the file names.
-Use this if you want the utmost possible speed and don't care what order
-the files are processed in.
-
-If the order of processing is at all visible to the user, then the user
-will probably be happier if you do sort the names.
-
-@item
-The variable @code{directory-abbrev-alist} contains an alist of
-abbreviations to use for file directories. Each element has the form
-@code{(@var{from} . @var{to})}, and says to replace @var{from} with
-@var{to} when it appears in a directory name. This replacement is done
-when setting up the default directory of a newly visited file. The
-@var{from} string is actually a regular expression; it should always
-start with @samp{^}.
-
-You can set this variable in @file{site-init.el} to describe the
-abbreviations appropriate for your site.
-
-@item
-The function @code{abbreviate-file-name} applies abbreviations from
-@code{directory-abbrev-alist} to its argument, and substitutes @samp{~}
-for the user's home directory.
-
-Abbreviated directory names are useful for directories that are normally
-accessed through symbolic links. If you think of the link's name as
-``the name'' of the directory, you can define it as an abbreviation for
-the directory's official name; then ordinarily Emacs will call that
-directory by the link name you normally use.
-
-@item
-@code{write-region} can write a given string instead of text from the
-buffer. Use the string as the first argument (in place of the
-starting character position).
-
-You can supply a second file name as the fifth argument (@var{visit}).
-Use this to write the data to one file (the first argument,
-@var{filename}) while nominally visiting a different file (the fifth
-argument, @var{visit}). The argument @var{visit} is used in the echo
-area message and also for file locking; @var{visit} is stored in
-@code{buffer-file-name}.
-
-@item
-The value of @code{write-file-hooks} does not change when you switch to
-a new major mode. The intention is that these hooks have to do with
-where the file came from, and not with what it contains.
-
-@item
-There is a new hook variable for saving files:
-@code{write-contents-hooks}. It works just like @code{write-file-hooks}
-except that switching to a new major mode clears it back to @code{nil}.
-Major modes should use this hook variable rather than
-@code{write-file-hooks}.
-
-@item
-The hook @code{after-save-hook} runs just after a buffer has been saved
-in its visited file.
-
-@item
-The new function @code{set-default-file-modes} sets the file protection
-for new files created with Emacs. The argument must be an integer. (It
-would be better to permit symbolic arguments like the @code{chmod}
-program, but that would take more work than this function merits.)
-
-Use the new function @code{default-file-modes} to read the current
-default file mode.
-
-@item
-Call the new function @code{unix-sync} to force all pending disk output
-to happen as soon as possible.
-@end itemize
-
-@section Making Certain File Names ``Magic''
-
-You can implement special handling for a class of file names. You must
-supply a regular expression to define the class of names (all those
-which match the regular expression), plus a handler that implements all
-the primitive Emacs file operations for file names that do match.
-
-The value of @code{file-name-handler-alist} is a list of handlers,
-together with regular expressions that decide when to apply each
-handler. Each element has the form @code{(@var{regexp}
-. @var{handler})}. If a file name matches @var{regexp}, then all work
-on that file is done by calling @var{handler}.
-
-All the Emacs primitives for file access and file name transformation
-check the given file name against @code{file-name-handler-alist}, and
-call @var{handler} to do the work if appropriate. The first argument
-given to @var{handler} is the name of the primitive; the remaining
-arguments are the arguments that were passed to that primitive. (The
-first of these arguments is typically the file name itself.) For
-example, if you do this:
-
-@example
-(file-exists-p @var{filename})
-@end example
-
-@noindent
-and @var{filename} has handler @var{handler}, then @var{handler} is
-called like this:
-
-@example
-(funcall @var{handler} 'file-exists-p @var{filename})
-@end example
-
-Here are the primitives that you can handle in this way:
-
-@quotation
-@code{add-name-to-file}, @code{copy-file}, @code{delete-directory},
-@code{delete-file}, @code{directory-file-name}, @code{directory-files},
-@code{dired-compress-file}, @code{dired-uncache},
-@code{expand-file-name}, @code{file-accessible-directory-p},
-@code{file-attributes}, @code{file-directory-p},
-@code{file-executable-p}, @code{file-exists-p}, @code{file-local-copy},
-@code{file-modes}, @code{file-name-all-completions},
-@code{file-name-as-directory}, @code{file-name-completion},
-@code{file-name-directory}, @code{file-name-nondirectory},
-@code{file-name-sans-versions}, @code{file-newer-than-file-p},
-@code{file-readable-p}, @code{file-symlink-p}, @code{file-writable-p},
-@code{insert-directory}, @code{insert-file-contents},
-@code{make-directory}, @code{make-symbolic-link}, @code{rename-file},
-@code{set-file-modes}, @code{verify-visited-file-modtime},
-@code{write-region}.
-@end quotation
-
-The handler function must handle all of the above operations, and
-possibly others to be added in the future. Therefore, it should always
-reinvoke the ordinary Lisp primitive when it receives an operation it
-does not recognize. Here's one way to do this:
-
-@smallexample
-(defun my-file-handler (primitive &rest args)
- ;; @r{First check for the specific operations}
- ;; @r{that we have special handling for.}
- (cond ((eq operation 'insert-file-contents) @dots{})
- ((eq operation 'write-region) @dots{})
- @dots{}
- ;; @r{Handle any operation we don't know about.}
- (t (let (file-name-handler-alist)
- (apply operation args)))))
-@end smallexample
-
-The function @code{file-local-copy} copies file @var{filename} to the
-local site, if it isn't there already. If @var{filename} specifies a
-``magic'' file name which programs outside Emacs cannot directly read or
-write, this copies the contents to an ordinary file and returns that
-file's name.
-
-If @var{filename} is an ordinary file name, not magic, then this function
-does nothing and returns @code{nil}.
-
-The function @code{unhandled-file-name-directory} is used to get a
-non-magic directory name from an arbitrary file name. It uses the
-directory part of the specified file name if that is not magic.
-Otherwise, it asks the file name's handler what to do.
-
-@section Frames
-@cindex frame
-
-Emacs now supports multiple X windows via a new data type known as a
-@dfn{frame}.
-
-A frame is a rectangle on the screen that contains one or more Emacs
-windows. Subdividing a frame works just like subdividing the screen in
-earlier versions of Emacs.
-
-@cindex terminal frame
-There are two kinds of frames: terminal frames and X window frames.
-Emacs creates one terminal frame when it starts up with no X display; it
-uses Termcap or Terminfo to display using characters. There is no way
-to create another terminal frame after startup. If Emacs has an X
-display, it does not make a terminal frame, and there is none.
-
-@cindex X window frame
-When you are using X windows, Emacs starts out with a single X window
-frame. You can create any number of X window frames using
-@code{make-frame}.
-
-Use the predicate @code{framep} to determine whether a given Lisp object
-is a frame.
-
-The function @code{redraw-frame} redisplays the entire contents of a
-given frame.
-
-@subsection Creating and Deleting Frames
-
-Use @code{make-frame} to create a new frame (supported under X Windows
-only). This is the only primitive for creating frames.
-
-@code{make-frame} takes just one argument, which is an alist
-specifying frame parameters. Any parameters not mentioned in the
-argument alist default based on the value of @code{default-frame-alist};
-parameters not specified there default from the standard X defaults file
-and X resources.
-
-When you invoke Emacs, if you specify arguments for window appearance
-and so forth, these go into @code{default-frame-alist} and that is how
-they have their effect.
-
-You can specify the parameters for the initial startup X window frame by
-setting @code{initial-frame-alist} in your @file{.emacs} file. If these
-parameters specify a separate minibuffer-only frame, and you have not
-created one, Emacs creates one for you, using the parameter values
-specified in @code{minibuffer-frame-alist}.
-
-You can specify the size and position of a frame using the frame
-parameters @code{left}, @code{top}, @code{height} and @code{width}. You
-must specify either both size parameters or neither. You must specify
-either both position parameters or neither. The geometry parameters
-that you don't specify are chosen by the window manager in its usual
-fashion.
-
-The function @code{x-parse-geometry} converts a standard X windows
-geometry string to an alist which you can use as part of the argument to
-@code{make-frame}.
-
-Use the function @code{delete-frame} to eliminate a frame. Frames are
-like buffers where deletion is concerned; a frame actually continues to
-exist as a Lisp object until it is deleted @emph{and} there are no
-references to it, but once it is deleted, it has no further effect on
-the screen.
-
-The function @code{frame-live-p} returns non-@code{nil} if the argument
-(a frame) has not been deleted.
-
-@subsection Finding All Frames
-
-The function @code{frame-list} returns a list of all the frames that have
-not been deleted. It is analogous to @code{buffer-list}. The list that
-you get is newly created, so modifying the list doesn't have any effect
-on the internals of Emacs. The function @code{visible-frame-list} returns
-the list of just the frames that are visible.
-
-@code{next-frame} lets you cycle conveniently through all the frames from an
-arbitrary starting point. Its first argument is a frame. Its second
-argument @var{minibuf} says what to do about minibuffers:
-
-@table @asis
-@item @code{nil}
-Exclude minibuffer-only frames.
-@item a window
-Consider only the frames using that particular window as their
-minibuffer.
-@item anything else
-Consider all frames.
-@end table
-
-@subsection Frames and Windows
-
-All the non-minibuffer windows in a frame are arranged in a tree of
-subdivisions; the root of this tree is available via the function
-@code{frame-root-window}. Each window is part of one and only one
-frame; you can get the frame with @code{window-frame}.
-
-At any time, exactly one window on any frame is @dfn{selected within the
-frame}. You can get the frame's current selected window with
-@code{frame-selected-window}. The significance of this designation is
-that selecting the frame selects for Emacs as a whole the window
-currently selected within that frame.
-
-Conversely, selecting a window for Emacs with @code{select-window} also
-makes that window selected within its frame.
-
-@subsection Frame Visibility
-
-A frame may be @dfn{visible}, @dfn{invisible}, or @dfn{iconified}. If
-it is invisible, it doesn't show in the screen, not even as an icon.
-You can set the visibility status of a frame with
-@code{make-frame-visible}, @code{make-frame-invisible}, and
-@code{iconify-frame}. You can examine the visibility status with
-@code{frame-visible-p}---it returns @code{t} for a visible frame,
-@code{nil} for an invisible frame, and @code{icon} for an iconified
-frame.
-
-@subsection Selected Frame
-
-At any time, one frame in Emacs is the @dfn{selected frame}. The selected
-window always resides on the selected frame.
-
-@defun selected-frame
-This function returns the selected frame.
-@end defun
-
-The X server normally directs keyboard input to the X window that the
-mouse is in. Some window managers use mouse clicks or keyboard events
-to @dfn{shift the focus} to various X windows, overriding the normal
-behavior of the server.
-
-Lisp programs can switch frames ``temporarily'' by calling the function
-@code{select-frame}. This does not override the window manager; rather,
-it escapes from the window manager's control until that control is
-somehow reasserted. The function takes one argument, a frame, and
-selects that frame. The selection lasts until the next time the user
-does something to select a different frame, or until the next time this
-function is called.
-
-Emacs cooperates with the X server and the window managers by arranging
-to select frames according to what the server and window manager ask
-for. It does so by generating a special kind of input event, called a
-@dfn{focus} event. The command loop handles a focus event by calling
-@code{internal-select-frame}. @xref{Focus Events}.
-
-@subsection Frame Size and Position
-
-The new functions @code{frame-height} and @code{frame-width} return the
-height and width of a specified frame (or of the selected frame),
-measured in characters.
-
-The new functions @code{frame-pixel-height} and @code{frame-pixel-width}
-return the height and width of a specified frame (or of the selected
-frame), measured in pixels.
-
-The new functions @code{frame-char-height} and @code{frame-char-width}
-return the height and width of a character in a specified frame (or in
-the selected frame), measured in pixels.
-
-@code{set-frame-size} sets the size of a frame, measured in characters;
-its arguments are @var{frame}, @var{cols} and @var{rows}. To set the
-size with values measured in pixels, you can use
-@code{modify-frame-parameters}.
-
-The function @code{set-frame-position} sets the position of the top left
-corner of a frame. Its arguments are @var{frame}, @var{left} and
-@var{top}.
-
-@ignore
-New functions @code{set-frame-height} and @code{set-frame-width} set the
-size of a specified frame. The frame is the first argument; the size is
-the second.
-@end ignore
-
-@subsection Frame Parameters
-
-A frame has many parameters that affect how it displays. Use the
-function @code{frame-parameters} to get an alist of all the parameters
-of a given frame. To alter parameters, use
-@code{modify-frame-parameters}, which takes two arguments: the frame to
-modify, and an alist of parameters to change and their new values. Each
-element of @var{alist} has the form @code{(@var{parm} . @var{value})},
-where @var{parm} is a symbol. Parameters that aren't meaningful are
-ignored. If you don't mention a parameter in @var{alist}, its value
-doesn't change.
-
-Just what parameters a frame has depends on what display mechanism it
-uses. Here is a table of the parameters of an X
-window frame:
-
-@table @code
-@item name
-The name of the frame.
-
-@item left
-The screen position of the left edge.
-
-@item top
-The screen position of the top edge.
-
-@item height
-The height of the frame contents, in pixels.
-
-@item width
-The width of the frame contents, in pixels.
-
-@item window-id
-The number of the X window for the frame.
-
-@item minibuffer
-Whether this frame has its own minibuffer.
-@code{t} means yes, @code{none} means no,
-@code{only} means this frame is just a minibuffer,
-a minibuffer window (in some other frame)
-means the new frame uses that minibuffer.
-
-@item font
-The name of the font for the text.
-
-@item foreground-color
-The color to use for the inside of a character.
-Use strings to designate colors;
-X windows defines the meaningful color names.
-
-@item background-color
-The color to use for the background of text.
-
-@item mouse-color
-The color for the mouse cursor.
-
-@item cursor-color
-The color for the cursor that shows point.
-
-@item border-color
-The color for the border of the frame.
-
-@item cursor-type
-The way to display the cursor. There are two legitimate values:
-@code{bar} and @code{box}. The value @code{bar} specifies a vertical
-bar between characters as the cursor. The value @code{box} specifies an
-ordinary black box overlaying the character after point; that is the
-default.
-
-@item icon-type
-Non-@code{nil} for a bitmap icon, @code{nil} for a text icon.
-
-@item border-width
-The width in pixels of the window border.
-
-@item internal-border-width
-The distance in pixels between text and border.
-
-@item auto-raise
-Non-@code{nil} means selecting the frame raises it.
-
-@item auto-lower
-Non-@code{nil} means deselecting the frame lowers it.
-
-@item vertical-scrollbar
-Non-@code{nil} gives the frame a scroll bar
-for vertical scrolling.
-
-@item horizontal-scrollbar
-Non-@code{nil} gives the frame a scroll bar
-for horizontal scrolling.
-@end table
-
-@subsection Minibufferless Frames
-
-Normally, each frame has its own minibuffer window at the bottom, which
-is used whenever that frame is selected. However, you can also create
-frames with no minibuffers. These frames must use the minibuffer window
-of some other frame.
-
-The variable @code{default-minibuffer-frame} specifies where to find a
-minibuffer for frames created without minibuffers of their own. Its
-value should be a frame which does have a minibuffer.
-
-You can also specify a minibuffer window explicitly when you create a
-frame; then @code{default-minibuffer-frame} is not used.
-
-@section X Windows Features
-
-@itemize @bullet
-@item
-The new functions @code{mouse-position} and @code{set-mouse-position} give
-access to the current position of the mouse.
-
-@code{mouse-position} returns a description of the position of the mouse.
-The value looks like @code{(@var{frame} @var{x} . @var{y})}, where @var{x}
-and @var{y} are measured in pixels relative to the top left corner of
-the inside of @var{frame}.
-
-@code{set-mouse-position} takes three arguments, @var{frame}, @var{x}
-and @var{y}, and warps the mouse cursor to that location on the screen.
-
-@item
-@code{track-mouse} is a new special form for tracking mouse motion.
-Use it in definitions of mouse clicks that want pay to attention to
-the motion of the mouse, not just where the buttons are pressed and
-released. Here is how to use it:
-
-@example
-(track-mouse @var{body}@dots{})
-@end example
-
-While @var{body} executes, mouse motion generates input events just as mouse
-clicks do. @var{body} can read them with @code{read-event} or
-@code{read-key-sequence}.
-
-@code{track-mouse} returns the value of the last form in @var{body}.
-
-The format of these events is described under ``New features for key
-bindings and input.''
-@c ???
-
-@item
-@code{x-set-selection} sets a ``selection'' in the X Windows server.
-It takes two arguments: a selection type @var{type}, and the value to
-assign to it, @var{data}. If @var{data} is @code{nil}, it means to
-clear out the selection. Otherwise, @var{data} may be a string, a
-symbol, an integer (or a cons of two integers or list of two integers),
-or a cons of two markers pointing to the same buffer. In the last case,
-the selection is considered to be the text between the markers. The
-data may also be a vector of valid non-vector selection values.
-
-Each possible @var{type} has its own selection value, which changes
-independently. The usual values of @var{type} are @code{PRIMARY} and
-@code{SECONDARY}; these are symbols with upper-case names, in accord
-with X Windows conventions. The default is @code{PRIMARY}.
-
-To get the value of the selection, call @code{x-get-selection}. This
-function accesses selections set up by Emacs and those set up by other X
-clients. It takes two optional arguments, @var{type} and
-@var{data-type}. The default for @var{type} is @code{PRIMARY}.
-
-The @var{data-type} argument specifies the form of data conversion to
-use; meaningful values include @code{TEXT}, @code{STRING},
-@code{TARGETS}, @code{LENGTH}, @code{DELETE}, @code{FILE_NAME},
-@code{CHARACTER_POSITION}, @code{LINE_NUMBER}, @code{COLUMN_NUMBER},
-@code{OWNER_OS}, @code{HOST_NAME}, @code{USER}, @code{CLASS},
-@code{NAME}, @code{ATOM}, and @code{INTEGER}. (These are symbols with
-upper-case names in accord with X Windows conventions.)
-The default for @var{data-type} is @code{STRING}.
-
-@item
-X Windows has a set of numbered @dfn{cut buffers} which can store text
-or other data being moved between applications. Use
-@code{x-get-cut-buffer} to get the contents of a cut buffer; specify the
-cut buffer number as argument. Use @code{x-set-cut-buffer} with
-argument @var{string} to store a new string into the first cut buffer
-(moving the other values down through the series of cut buffers,
-kill-ring-style).
-
-Cut buffers are considered obsolete in X Windows, but Emacs supports
-them for the sake of X clients that still use them.
-
-@item
-You can close the connection with the X Windows server with
-the function @code{x-close-current-connection}. This takes no arguments.
-
-Then you can connect to a different X Windows server with
-@code{x-open-connection}. The first argument, @var{display}, is the
-name of the display to connect to.
-
-The optional second argument @var{xrm-string} is a string of resource
-names and values, in the same format used in the @file{.Xresources}
-file. The values you specify override the resource values recorded in
-the X Windows server itself. Here's an example of what this string
-might look like:
-
-@example
-"*BorderWidth: 3\n*InternalBorder: 2\n"
-@end example
-
-@item
-A series of new functions give you information about the X server and
-the screen you are using.
-
-@table @code
-@item x-display-screens
-The number of screens associated with the current display.
-
-@item x-server-version
-The version numbers of the X server in use.
-
-@item x-server-vendor
-The vendor supporting the X server in use.
-
-@item x-display-pixel-height
-The height of this X screen in pixels.
-
-@item x-display-mm-height
-The height of this X screen in millimeters.
-
-@item x-display-pixel-width
-The width of this X screen in pixels.
-
-@item x-display-mm-width
-The width of this X screen in millimeters.
-
-@item x-display-backing-store
-The backing store capability of this screen. Values can be the symbols
-@code{always}, @code{when-mapped}, or @code{not-useful}.
-
-@item x-display-save-under
-Non-@code{nil} if this X screen supports the SaveUnder feature.
-
-@item x-display-planes
-The number of planes this display supports.
-
-@item x-display-visual-class
-The visual class for this X screen. The value is one of the symbols
-@code{static-gray}, @code{gray-scale}, @code{static-color},
-@code{pseudo-color}, @code{true-color}, and @code{direct-color}.
-
-@item x-display-color-p
-@code{t} if the X screen in use is a color screen.
-
-@item x-display-color-cells
-The number of color cells this X screen supports.
-@end table
-
-There is also a variable @code{x-no-window-manager}, whose value is
-@code{t} if no X window manager is in use.
-
-@item
-The function @code{x-synchronize} enables or disables an X Windows
-debugging mode: synchronous communication. It takes one argument,
-non-@code{nil} to enable the mode and @code{nil} to disable.
-
-In synchronous mode, Emacs waits for a response to each X protocol
-command before doing anything else. This means that errors are reported
-right away, and you can directly find the erroneous command.
-Synchronous mode is not the default because it is much slower.
-
-@item
-The function @code{x-get-resource} retrieves a resource value from the X
-Windows defaults database. Its three arguments are @var{attribute},
-@var{name} and @var{class}. It searches using a key of the form
-@samp{@var{instance}.@var{attribute}}, with class @samp{Emacs}, where
-@var{instance} is the name under which Emacs was invoked.
-
-The optional arguments @var{component} and @var{subclass} add to the key
-and the class, respectively. You must specify both of them or neither.
-If you specify them, the key is
-@samp{@var{instance}.@var{component}.@var{attribute}}, and the class is
-@samp{Emacs.@var{subclass}}.
-
-@item
-@code{x-color-display-p} returns @code{t} if you are using an X Window
-server with a color display, and @code{nil} otherwise.
-
-@c ??? Name being changed from x-defined-color.
-@code{x-color-defined-p} takes as argument a string describing a color; it
-returns @code{t} if the display supports that color. (If the color is
-@code{"black"} or @code{"white"} then even black-and-white displays
-support it.)
-
-@item
-@code{x-popup-menu} has been generalized. It now accepts a keymap as
-the @var{menu} argument. Then the menu items are the prompt strings of
-individual key bindings, and the item values are the keys which have
-those bindings.
-
-You can also supply a list of keymaps as the first argument; then each
-keymap makes one menu pane (but keymaps that don't provide any menu
-items don't appear in the menu at all).
-
-@code{x-popup-menu} also accepts a mouse button event as the
-@var{position} argument. Then it displays the menu at the location at
-which the event took place. This is convenient for mouse-invoked
-commands that pop up menus.
-
-@ignore
-@item
-x-pointer-shape, x-nontext-pointer-shape, x-mode-pointer-shape.
-@end ignore
-
-@item
-You can use the function @code{x-rebind-key} to change the sequence
-of characters generated by one of the keyboard keys. This works
-only with X Windows.
-
-The first two arguments, @var{keycode} and @var{shift-mask}, should be
-numbers representing the keyboard code and shift mask respectively.
-They specify what key to change.
-
-The third argument, @var{newstring}, is the new definition of the key.
-It is a sequence of characters that the key should produce as input.
-
-The shift mask value is a combination of bits according to this table:
-
-@table @asis
-@item 8
-Control
-@item 4
-Meta
-@item 2
-Shift
-@item 1
-Shift Lock
-@end table
-
-If you specify @code{nil} for @var{shift-mask}, then the key specified
-by @var{keycode} is redefined for all possible shift combinations.
-
-For the possible values of @var{keycode} and their meanings, see the
-file @file{/usr/lib/Xkeymap.txt}. Keep in mind that the codes in that
-file are in octal!
-
-@ignore @c Presumably this is already fixed
-NOTE: due to an X bug, this function will not take effect unless the
-user has a @file{~/.Xkeymap} file. (See the documentation for the
-@code{keycomp} program.) This problem will be fixed in X version 11.
-@end ignore
-
-The related function @code{x-rebind-keys} redefines a single keyboard
-key, specifying the behavior for each of the 16 shift masks
-independently. The first argument is @var{keycode}, as in
-@code{x-rebind-key}. The second argument @var{strings} is a list of 16
-elements, one for each possible shift mask value; each element says how
-to redefine the key @var{keycode} with the corresponding shift mask
-value. If an element is a string, it is the new definition. If an
-element is @code{nil}, the definition does not change for that shift
-mask.
-
-@item
-The function @code{x-geometry} parses a string specifying window size
-and position in the usual fashion for X windows. It returns an alist
-describing which parameters were specified, and the values that were
-given for them.
-
-The elements of the alist look like @code{(@var{parameter} .
-@var{value})}. The possible @var{parameter} values are @code{left},
-@code{top}, @code{width}, and @code{height}.
-@end itemize
-
-@section New Window Features
-
-@itemize @bullet
-@item
-The new function @code{window-at} tells you which window contains a
-given horizontal and vertical position on a specified frame. Call it
-with three arguments, like this:
-
-@example
-(window-at @var{x} @var{column} @var{frame})
-@end example
-
-The function returns the window which contains that cursor position in
-the frame @var{frame}. If you omit @var{frame}, the selected frame is
-used.
-
-@item
-The function @code{coordinates-in-window-p} takes two arguments and
-checks whether a particular frame position falls within a particular
-window.
-
-@example
-(coordinates-in-window-p @var{coordinates} @var{window})
-@end example
-
-The argument @var{coordinates} is a cons cell of this form:
-
-@example
-(@var{x} . @var{y})
-@end example
-
-@noindent
-The two coordinates are measured in characters, and count from the top
-left corner of the screen or frame.
-
-The value of the function tells you what part of the window the position
-is in. The possible values are:
-
-@table @code
-@item (@var{relx} . @var{rely})
-The coordinates are inside @var{window}. The numbers @var{relx} and
-@var{rely} are equivalent window-relative coordinates, counting from 0
-at the top left corner of the window.
-
-@item mode-line
-The coordinates are in the mode line of @var{window}.
-
-@item vertical-split
-The coordinates are in the vertical line between @var{window} and its
-neighbor to the right.
-
-@item nil
-The coordinates are not in any sense within @var{window}.
-@end table
-
-You need not specify a frame when you call
-@code{coordinates-in-window-p}, because it assumes you mean the frame
-which window @var{window} is on.
-
-@item
-The function @code{minibuffer-window} now accepts a frame as argument
-and returns the minibuffer window used for that frame. If you don't
-specify a frame, the currently selected frame is used. The minibuffer
-window may be on the frame in question, but if that frame has no
-minibuffer of its own, it uses the minibuffer window of some other
-frame, and @code{minibuffer-window} returns that window.
-
-@item
-Use @code{window-live-p} to test whether a window is still alive (that
-is, not deleted).
-
-@item
-Use @code{window-minibuffer-p} to determine whether a given window is a
-minibuffer or not. It no longer works to do this by comparing the
-window with the result of @code{(minibuffer-window)}, because there can
-be more than one minibuffer window at a time (if you have multiple
-frames).
-
-@item
-If you set the variable @code{pop-up-frames} non-@code{nil}, then the
-functions to show something ``in another window'' actually create a new
-frame for the new window. Thus, you will tend to have a frame for each
-window, and you can easily have a frame for each buffer.
-
-The value of the variable @code{pop-up-frame-function} controls how new
-frames are made. The value should be a function which takes no
-arguments and returns a frame. The default value is a function which
-creates a frame using parameters from @code{pop-up-frame-alist}.
-
-@item
-@code{display-buffer} is the basic primitive for finding a way to show a
-buffer on the screen. You can customize its behavior by storing a
-function in the variable @code{display-buffer-function}. If this
-variable is non-@code{nil}, then @code{display-buffer} calls it to do
-the work. Your function should accept two arguments, as follows:
-
-@table @var
-@item buffer
-The buffer to be displayed.
-
-@item flag
-A flag which, if non-@code{nil}, means you should find another window to
-display @var{buffer} in, even if it is already visible in the selected
-window.
-@end table
-
-The function you supply will be used by commands such as
-@code{switch-to-buffer-other-window} and @code{find-file-other-window}
-as well as for your own calls to @code{display-buffer}.
-
-@item
-@code{delete-window} now gives all of the deleted window's screen space
-to a single neighboring window. Likewise, @code{enlarge-window} takes
-space from only one neighboring window until that window disappears;
-only then does it take from another window.
-
-@item
-@code{next-window} and @code{previous-window} accept another argument,
-@var{all-frames}.
-
-These functions now take three optional arguments: @var{window},
-@var{minibuf} and @var{all-frames}. @var{window} is the window to start
-from (@code{nil} means use the selected window). @var{minibuf} says
-whether to include the minibuffer in the windows to cycle through:
-@code{t} means yes, @code{nil} means yes if it is active, and anything
-else means no.
-
-Normally, these functions cycle through all the windows in the
-selected frame, plus the minibuffer used by the selected frame even if
-it lies in some other frame.
-
-If @var{all-frames} is @code{t}, then these functions cycle through
-all the windows in all the frames that currently exist. If
-@var{all-frames} is neither @code{t} nor @code{nil}, then they limit
-themselves strictly to the windows in the selected frame, excluding the
-minibuffer in use if it lies in some other frame.
-
-@item
-The functions @code{get-lru-window} and @code{get-largest-window} now
-take an optional argument @var{all-frames}. If it is non-@code{nil},
-the functions consider all windows on all frames. Otherwise, they
-consider just the windows on the selected frame.
-
-Likewise, @code{get-buffer-window} takes an optional second argument
-@var{all-frames}.
-
-@item
-The variable @code{other-window-scroll-buffer} specifies which buffer
-@code{scroll-other-window} should scroll.
-
-@item
-You can now mark a window as ``dedicated'' to its buffer.
-Then Emacs will not try to use that window for any other buffer
-unless you explicitly request it.
-
-Use the new function @code{set-window-dedicated-p} to set the dedication
-flag of a window @var{window} to the value @var{flag}. If @var{flag} is
-@code{t}, this makes the window dedicated. If @var{flag} is
-@code{nil}, this makes the window non-dedicated.
-
-Use @code{window-dedicated-p} to examine the dedication flag of a
-specified window.
-
-@item
-The new function @code{walk-windows} cycles through all visible
-windows, calling @code{proc} once for each window with the window as
-its sole argument.
-
-The optional second argument @var{minibuf} says whether to include minibuffer
-windows. A value of @code{t} means count the minibuffer window even if
-not active. A value of @code{nil} means count it only if active. Any
-other value means not to count the minibuffer even if it is active.
-
-If the optional third argument @var{all-frames} is @code{t}, that means
-include all windows in all frames. If @var{all-frames} is @code{nil},
-it means to cycle within the selected frame, but include the minibuffer
-window (if @var{minibuf} says so) that that frame uses, even if it is on
-another frame. If @var{all-frames} is neither @code{nil} nor @code{t},
-@code{walk-windows} sticks strictly to the selected frame.
-
-@item
-The function @code{window-end} is a counterpart to @code{window-start}:
-it returns the buffer position of the end of the display in a given
-window (or the selected window).
-
-@item
-The function @code{window-configuration-p} returns non-@code{nil} when
-given an object that is a window configuration (such as is returned by
-@code{current-window-configuration}).
-@end itemize
-
-@section Display Features
-
-@itemize @bullet
-@item
-@samp{%l} as a mode line item displays the current line number.
-
-If the buffer is longer than @code{line-number-display-limit}
-characters, or if lines are too long in the viscinity of the current
-displayed text, then line number display is inhibited to save time.
-
-The default contents of the mode line include the line number if
-@code{line-number-mode} is non-@code{nil}.
-
-@item
-@code{baud-rate} is now a variable rather than a function. This is so
-you can set it to reflect the effective speed of your terminal, when the
-system doesn't accurately know the speed.
-
-@item
-You can now remove any echo area message and make the minibuffer
-visible. To do this, call @code{message} with @code{nil} as the only
-argument. This clears any existing message, and lets the current
-minibuffer contents show through. Previously, there was no reliable way
-to make sure that the minibuffer contents were visible.
-
-@item
-The variable @code{temp-buffer-show-hook} has been renamed
-@code{temp-buffer-show-function}, because its value is a single function
-(of one argument), not a normal hook.
-
-@item
-The new function @code{force-mode-line-update} causes redisplay
-of the current buffer's mode line.
-@end itemize
-
-@section Display Tables
-
-@cindex display table
-You can use the @dfn{display table} feature to control how all 256
-possible character codes display on the screen. This is useful for
-displaying European languages that have letters not in the ASCII
-character set.
-
-The display table maps each character code into a sequence of
-@dfn{glyphs}, each glyph being an image that takes up one character
-position on the screen. You can also define how to display each glyph
-on your terminal, using the @dfn{glyph table}.
-
-@subsection Display Tables
-
-Use @code{make-display-table} to create a display table. The table
-initially has @code{nil} in all elements.
-
-A display table is actually an array of 261 elements. The first 256
-elements of a display table control how to display each possible text
-character. The value should be @code{nil} or a vector (which is a
-sequence of glyphs; see below). @code{nil} as an element means to
-display that character following the usual display conventions.
-
-The remaining five elements of a display table serve special purposes
-(@code{nil} means use the default stated below):
-
-@table @asis
-@item 256
-The glyph for the end of a truncated screen line (the default for this
-is @samp{\}).
-@item 257
-The glyph for the end of a continued line (the default is @samp{$}).
-@item 258
-The glyph for the indicating an octal character code (the default is
-@samp{\}).
-@item 259
-The glyph for indicating a control characters (the default is @samp{^}).
-@item 260
-The vector of glyphs for indicating the presence of invisible lines (the
-default is @samp{...}).
-@end table
-
-Each buffer typically has its own display table. The display table for
-the current buffer is stored in @code{buffer-display-table}. (This
-variable automatically becomes local if you set it.) If this variable
-is @code{nil}, the value of @code{standard-display-table} is used in
-that buffer.
-
-Each window can have its own display table, which overrides the display
-table of the buffer it is showing.
-
-If neither the selected window nor the current buffer has a display
-table, and if @code{standard-display-table} is @code{nil}, then Emacs
-uses the usual display conventions:
-
-@itemize @bullet
-@item
-Character codes 32 through 127 map to glyph codes 32 through 127.
-@item
-Codes 0 through 31 map to sequences of two glyphs, where the first glyph
-is the ASCII code for @samp{^}.
-@item
-Character codes 128 through 255 map to sequences of four glyphs, where
-the first glyph is the ASCII code for @samp{\}, and the others represent
-digits.
-@end itemize
-
-The usual display conventions are also used for any character whose
-entry in the active display table is @code{nil}. This means that when
-you set up a display table, you need not specify explicitly what to do
-with each character, only the characters for which you want unusual
-behavior.
-
-@subsection Glyphs
-
-@cindex glyph
-A glyph stands for an image that takes up a single character position on
-the screen. A glyph is represented in Lisp as an integer.
-
-@cindex glyph table
-The meaning of each integer, as a glyph, is defined by the glyph table,
-which is the value of the variable @code{glyph-table}. It should be a
-vector; the @var{g}th element defines glyph code @var{g}. The possible
-definitions of a glyph code are:
-
-@table @var
-@item integer
-Define this glyph code as an alias for code @var{integer}.
-This is used with X windows to specify a face code.
-
-@item string
-Send the characters in @var{string} to the terminal to output
-this glyph. This alternative is not available with X Windows.
-
-@item @code{nil}
-This glyph is simple. On an ordinary terminal, the glyph code mod 256
-is the character to output. With X, the glyph code mod 256 is character
-to output, and the glyph code divided by 256 specifies the @dfn{face
-code} to use while outputting it.
-@end table
-
-Any glyph code beyond the length of the glyph table is automatically simple.
-
-A face code for X windows is the combination of a font and a color.
-Emacs uses integers to identify face codes. You can define a new face
-code with @code{(x-set-face @var{face-code} @var{font} @var{foreground}
-@var{background})}. @var{face-code} is an integer from 0 to 255; it
-specifies which face to define. The other three arguments are strings:
-@var{font} is the name of the font to use, and @var{foreground} and
-@var{background} specify the colors to use.
-
-If @code{glyph-table} is @code{nil}, then all possible glyph codes are
-simple.
-
-@subsection ISO Latin 1
-
-If you have a terminal that can handle the entire ISO Latin 1 character
-set, you can arrange to use that character set as follows:
-
-@example
-(require 'disp-table)
-(standard-display-8bit 0 255)
-@end example
-
-If you are editing buffers written in the ISO Latin 1 character set and
-your terminal doesn't handle anything but ASCII, you can load the file
-@code{iso-ascii} to set up a display table which makes the other ISO
-characters display as sequences of ASCII characters. For example, the
-character ``o with umlaut'' displays as @samp{@{"o@}}.
-
-Some European countries have terminals that don't support ISO Latin 1
-but do support the special characters for that country's language. You
-can define a display table to work one language using such terminals.
-For an example, see @file{lisp/iso-swed.el}, which handles certain
-Swedish terminals.
-
-You can load the appropriate display table for your terminal
-automatically by writing a terminal-specific Lisp file for the terminal
-type.
-
-@section New Input Event Formats
-
-Mouse clicks, mouse movements and function keys no longer appear in the
-input stream as characters; instead, other kinds of Lisp objects
-represent them as input.
-
-@itemize @bullet
-@item
-An ordinary input character event consists of a @dfn{basic code} between
-0 and 255, plus any or all of these @dfn{modifier bits}:
-
-@table @asis
-@item meta
-The 2**23 bit in the character code indicates a character
-typed with the meta key held down.
-
-@item control
-The 2**22 bit in the character code indicates a non-@sc{ASCII}
-control character.
-
-@sc{ASCII} control characters such as @kbd{C-a} have special basic
-codes of their own, so Emacs needs no special bit to indicate them.
-Thus, the code for @kbd{C-a} is just 1.
-
-But if you type a control combination not in @sc{ASCII}, such as
-@kbd{%} with the control key, the numeric value you get is the code
-for @kbd{%} plus 2**22 (assuming the terminal supports non-@sc{ASCII}
-control characters).
-
-@item shift
-The 2**21 bit in the character code indicates an @sc{ASCII} control
-character typed with the shift key held down.
-
-For letters, the basic code indicates upper versus lower case; for
-digits and punctuation, the shift key selects an entirely different
-character with a different basic code. In order to keep within
-the @sc{ASCII} character set whenever possible, Emacs avoids using
-the 2**21 bit for those characters.
-
-However, @sc{ASCII} provides no way to distinguish @kbd{C-A} from
-@kbd{C-A}, so Emacs uses the 2**21 bit in @kbd{C-A} and not in
-@kbd{C-a}.
-
-@item hyper
-The 2**20 bit in the character code indicates a character
-typed with the hyper key held down.
-
-@item super
-The 2**19 bit in the character code indicates a character
-typed with the super key held down.
-
-@item alt
-The 2**18 bit in the character code indicates a character typed with
-the alt key held down. (On some terminals, the key labeled @key{ALT}
-is actually the meta key.)
-@end table
-
-In the future, Emacs may support a larger range of basic codes. We may
-also move the modifier bits to larger bit numbers. Therefore, you
-should avoid mentioning specific bit numbers in your program. Instead,
-the way to test the modifier bits of a character is with the function
-@code{event-modifiers} (see below).
-
-@item
-Function keys are represented as symbols. The symbol's name is
-the function key's label. For example, pressing a key labeled @key{F1}
-places the symbol @code{f1} in the input stream.
-
-There are a few exceptions to the symbol naming convention:
-
-@table @asis
-@item @code{kp-add}, @code{kp-decimal}, @code{kp-divide}, @dots{}
-Keypad keys (to the right of the regular keyboard).
-@item @code{kp-0}, @code{kp-1}, @dots{}
-Keypad keys with digits.
-@item @code{kp-f1}, @code{kp-f2}, @code{kp-f3}, @code{kp-f4}
-Keypad PF keys.
-@item @code{left}, @code{up}, @code{right}, @code{down}
-Cursor arrow keys
-@end table
-
-You can use the modifier keys @key{CTRL}, @key{META}, @key{HYPER},
-@key{SUPER}, @key{ALT} and @key{SHIFT} with function keys. The way
-to represent them is with prefixes in the symbol name:
-
-@table @samp
-@item A-
-The alt modifier.
-@item C-
-The control modifier.
-@item H-
-The hyper modifier.
-@item M-
-The meta modifier.
-@item s-
-The super modifier.
-@item S-
-The shift modifier.
-@end table
-
-Thus, the symbol for the key @key{F3} with @key{META} held down is
-kbd{M-@key{F3}}. When you use more than one prefix, we recommend you
-write them in alphabetical order (though the order does not matter in
-arguments to the key-binding lookup and modification functions).
-
-@item
-Mouse events are represented as lists.
-
-If you press a mouse button and release it at the same location, this
-generates a ``click'' event. Mouse click events have this form:
-
-@example
-(@var{button-symbol}
- (@var{window} (@var{column} . @var{row})
- @var{buffer-pos} @var{timestamp}))
-@end example
-
-Here is what the elements normally mean:
-
-@table @var
-@item button-symbol
-indicates which mouse button was used. It is one of the symbols
-@code{mouse-1}, @code{mouse-2}, @dots{}, where the buttons are numbered
-numbered left to right.
-
-You can also use prefixes @samp{A-}, @samp{C-}, @samp{H-}, @samp{M-},
-@samp{S-} and @samp{s-} for modifiers alt, control, hyper, meta, shift
-and super, just as you would with function keys.
-
-@item window
-is the window in which the click occurred.
-
-@item column
-@itemx row
-are the column and row of the click, relative to the top left corner of
-@var{window}, which is @code{(0 . 0)}.
-
-@item buffer-pos
-is the buffer position of the character clicked on.
-
-@item timestamp
-is the time at which the event occurred, in milliseconds. (Since this
-value wraps around the entire range of Emacs Lisp integers in about five
-hours, it is useful only for relating the times of nearby events.)
-@end table
-
-The meanings of @var{buffer-pos}, @var{row} and @var{column} are
-somewhat different when the event location is in a special part of the
-screen, such as the mode line or a scroll bar.
-
-If the position is in the window's scroll bar, then @var{buffer-pos} is
-the symbol @code{vertical-scrollbar} or @code{horizontal-scrollbar}, and
-the pair @code{(@var{column} . @var{row})} is instead a pair
-@code{(@var{portion} . @var{whole})}, where @var{portion} is the
-distance of the click from the top or left end of the scroll bar, and
-@var{whole} is the length of the entire scroll bar.
-
-If the position is on a mode line or the vertical line separating
-@var{window} from its neighbor to the right, then @var{buffer-pos} is
-the symbol @code{mode-line} or @code{vertical-line}. In this case
-@var{row} and @var{column} do not have meaningful data.
-
-@item
-Releasing a mouse button above a different character position
-generates a ``drag'' event, which looks like this:
-
-@example
-(@var{button-symbol}
- (@var{window1} (@var{column1} . @var{row1})
- @var{buffer-pos1} @var{timestamp1})
- (@var{window2} (@var{column2} . @var{row2})
- @var{buffer-pos2} @var{timestamp2}))
-@end example
-
-The name of @var{button-symbol} contains the prefix @samp{drag-}. The
-second and third elements of the event give the starting and ending
-position of the drag.
-
-The @samp{drag-} prefix follows the modifier key prefixes such as
-@samp{C-} and @samp{M-}.
-
-If @code{read-key-sequence} receives a drag event which has no key
-binding, and the corresponding click event does have a binding, it
-changes the drag event into a click event at the drag's starting
-position. This means that you don't have to distinguish between click
-and drag events unless you want to.
-
-@item
-Click and drag events happen when you release a mouse button. Another
-kind of event happens when you press a button. It looks just like a
-click event, except that the name of @var{button-symbol} contains the
-prefix @samp{down-}. The @samp{down-} prefix follows the modifier key
-prefixes such as @samp{C-} and @samp{M-}.
-
-The function @code{read-key-sequence}, and the Emacs command loop,
-ignore any down events that don't have command bindings. This means
-that you need not worry about defining down events unless you want them
-to do something. The usual reason to define a down event is so that you
-can track mouse motion until the button is released.
-
-@item
-For example, if the user presses and releases the left mouse button over
-the same location, Emacs generates a sequence of events like this:
-
-@smallexample
-(down-mouse-1 (#<window 18 on NEWS> 2613 (0 . 38) -864320))
-(mouse-1 (#<window 18 on NEWS> 2613 (0 . 38) -864180))
-@end smallexample
-
-Or, while holding the control key down, the user might hold down the
-second mouse button, and drag the mouse from one line to the next.
-That produces two events, as shown here:
-
-@smallexample
-(C-down-mouse-2 (#<window 18 on NEWS> 3440 (0 . 27) -731219))
-(C-drag-mouse-2 (#<window 18 on NEWS> 3440 (0 . 27) -731219)
- (#<window 18 on NEWS> 3510 (0 . 28) -729648))
-@end smallexample
-
-Or, while holding down the meta and shift keys, the user might press
-the second mouse button on the window's mode line, and then drag the
-mouse into another window. That produces an event like this:
-
-@smallexample
-(M-S-down-mouse-2 (#<window 18 on NEWS> mode-line (33 . 31) -457844))
-(M-S-drag-mouse-2 (#<window 18 on NEWS> mode-line (33 . 31) -457844)
- (#<window 20 on carlton-sanskrit.tex> 161 (33 . 3)
- -453816))
-@end smallexample
-
-@item
-A key sequence that starts with a mouse click is read using the keymaps
-of the buffer in the window clicked on, not the current buffer.
-
-This does not imply that clicking in a window selects that window or its
-buffer. The execution of the command begins with no change in the
-selected window or current buffer. However, the command can switch
-windows or buffers if programmed to do so.
-
-@item
-Mouse motion events are represented by lists. During the execution of
-the body of a @code{track-mouse} form, moving the mouse generates events
-that look like this:
-
-@example
-(mouse-movement (@var{window} (@var{column} . @var{row})
- @var{buffer-pos} @var{timestamp}))
-@end example
-
-The second element of the list describes the current position of the
-mouse, just as in a mouse click event.
-
-Outside of @code{track-mouse} forms, Emacs does not generate events for
-mere motion of the mouse, and these events do not appear.
-
-@item
-Focus shifts between frames are represented by lists.
-
-When the mouse shifts temporary input focus from one frame to another,
-Emacs generates an event like this:
-
-@example
-(switch-frame @var{new-frame})
-@end example
-
-@noindent
-where @var{new-frame} is the frame switched to.
-
-In X windows, most window managers are set up so that just moving the
-mouse into a window is enough to set the focus there. As far as the
-user concern, Emacs behaves consistently with this. However, there is
-no need for the Lisp program to know about the focus change until some
-other kind of input arrives. So Emacs generates the focus event only
-when the user actually types a keyboard key or presses a mouse button in
-the new frame; just moving the mouse between frames does not generate a
-focus event.
-
-The global key map usually binds this event to the
-@code{internal-select-frame} function, so that characters typed at a
-frame apply to that frame's selected window.
-
-If the user switches frames in the middle of a key sequence, then Emacs
-delays the @code{switch-frame} event until the key sequence is over.
-For example, suppose @kbd{C-c C-a} is a key sequence in the current
-buffer's keymaps. If the user types @kbd{C-c}, moves the mouse to
-another frame, and then types @kbd{C-a}, @code{read-key-sequence}
-returns the sequence @code{"\C-c\C-a"}, and the next call to
-@code{read-event} or @code{read-key-sequence} will return the
-@code{switch-frame} event.
-@end itemize
-
-@section Working with Input Events
-
-@itemize @bullet
-@item
-Functions which work with key sequences now handle non-character
-events. Functions like @code{define-key}, @code{global-set-key}, and
-@code{local-set-key} used to accept strings representing key sequences;
-now, since events may be arbitrary lisp objects, they also accept
-vectors. The function @code{read-key-sequence} may return a string or a
-vector, depending on whether or not the sequence read contains only
-characters.
-
-List events may be represented by the symbols at their head; to bind
-clicks of the left mouse button, you need only present the symbol
-@code{mouse-1}, not an entire mouse click event. If you do put an event
-which is a list in a key sequence, only the event's head symbol is used
-in key lookups.
-
-For example, to globally bind the left mouse button to the function
-@code{mouse-set-point}, you could evaluate this:
-
-@example
-(global-set-key [mouse-1] 'mouse-set-point)
-@end example
-
-To bind the sequence @kbd{C-c @key{F1}} to the command @code{tex-view}
-in @code{tex-mode-map}, you could evaluate this:
-
-@example
-(define-key tex-mode-map [?\C-c f1] 'tex-view)
-@end example
-
-To find the binding for the function key labeled @key{NEXT} in
-@code{minibuffer-local-map}, you could evaluate this:
-
-@example
-(lookup-key minibuffer-local-map [next])
- @result{} next-history-element
-@end example
-
-If you call the function @code{read-key-sequence} and then press
-@kbd{C-x C-@key{F5}}, here is how it behaves:
-
-@example
-(read-key-sequence "Press `C-x C-F5': ")
- @result{} [24 C-f5]
-@end example
-
-Note that @samp{24} is the character @kbd{C-x}.
-
-@item
-The documentation functions (@code{single-key-description},
-@code{key-description}, etc.) now handle the new event types. Wherever
-a string of keyboard input characters was acceptable in previous
-versions of Emacs, a vector of events should now work.
-
-@item
-Special parts of a window can have their own bindings for mouse events.
-
-When mouse events occur in special parts of a window, such as a mode
-line or a scroll bar, the event itself shows nothing special---only the
-symbol that would normally represent that mouse button and modifier
-keys. The information about the screen region is kept in other parts
-of the event list. But @code{read-key-sequence} translates this
-information into imaginary prefix keys, all of which are symbols:
-@code{mode-line}, @code{vertical-line}, @code{horizontal-scrollbar} and
-@code{vertical-scrollbar}.
-
-For example, if you call @code{read-key-sequence} and then click the
-mouse on the window's mode line, this is what happens:
-
-@smallexample
-(read-key-sequence "Click on the mode line: ")
- @result{} [mode-line (mouse-1 (#<window 6 on NEWS> mode-line
- (40 . 63) 5959987))]
-@end smallexample
-
-You can define meanings for mouse clicks in special window regions by
-defining key sequences using these imaginary prefix keys. For example,
-here is how to bind the third mouse button on a window's mode line
-delete the window:
-
-@example
-(global-set-key [mode-line mouse-3] 'mouse-delete-window)
-@end example
-
-Here's how to bind the middle button (modified by @key{META}) on the
-vertical line at the right of a window to scroll the window to the
-left.
-
-@example
-(global-set-key [vertical-line M-mouse-2] 'scroll-left)
-@end example
-
-@item
-Decomposing an event symbol.
-
-Each symbol used to identify a function key or mouse button has a
-property named @code{event-symbol-elements}, which is a list containing
-an unmodified version of the symbol, followed by modifiers the symbol
-name contains. The modifiers are symbols; they include @code{shift},
-@code{control}, and @code{meta}. In addition, a mouse event symbol has
-one of @code{click}, @code{drag}, and @code{down}. For example:
-
-@example
-(get 'f5 'event-symbol-elements)
- @result{} (f5)
-(get 'C-f5 'event-symbol-elements)
- @result{} (f5 control)
-(get 'M-S-f5 'event-symbol-elements)
- @result{} (f5 meta shift)
-(get 'mouse-1 'event-symbol-elements)
- @result{} (mouse-1 click)
-(get 'down-mouse-1 'event-symbol-elements)
- @result{} (mouse-1 down)
-@end example
-
-Note that the @code{event-symbol-elements} property for a mouse click
-explicitly contains @code{click}, but the event symbol name itself does
-not contain @samp{click}.
-
-@item
-Use @code{read-event} to read input if you want to accept any kind of
-event. The old function @code{read-char} now discards events other than
-keyboard characters.
-
-@item
-@code{last-command-char} and @code{last-input-char} can now hold any
-kind of event.
-
-@item
-The new variable @code{unread-command-events} is much like
-@code{unread-command-char}. Its value is a list of events of any type,
-to be processed as command input in order of appearance in the list.
-
-@item
-The function @code{this-command-keys} may return a string or a vector,
-depending on whether or not the sequence read contains only characters.
-You may need to upgrade code which uses this function.
-
-The function @code{recent-keys} now returns a vector of events.
-You may need to upgrade code which uses this function.
-
-@item
-A keyboard macro's definition can now be either a string or a vector.
-All that really matters is what elements it has. If the elements are
-all characters, then the macro can be a string; otherwise, it has to be
-a vector.
-
-@item
-The variable @code{last-event-frame} records which frame the last input
-event was directed to. Usually this is the frame that was selected when
-the event was generated, but if that frame has redirected input focus to
-another frame, @code{last-event-frame} is the frame to which the event
-was redirected.
-
-@item
-The interactive specification now allows a new code letter @samp{e} to
-simplify commands bound to events which are lists. This code supplies
-as an argument the complete event object.
-
-You can use @samp{e} more than once in a single command's interactive
-specification. If the key sequence which invoked the command has
-@var{n} events with parameters, the @var{n}th @samp{e} provides the
-@var{n}th parameterized event. Events which are not lists, such as
-function keys and ASCII keystrokes, do not count where @samp{e} is
-concerned.
-
-@item
-You can extract the starting and ending position values from a mouse
-button or motion event using the two functions @code{event-start} and
-@code{event-end}. These two functions return different values for drag
-and motion events; for click and button-down events, they both return
-the position of the event.
-
-@item
-The position, a returned by @code{event-start} and @code{event-end}, is
-a list of this form:
-
-@example
-(@var{window} @var{buffer-position} (@var{col} . @var{row}) @var{timestamp})
-@end example
-
-You can extract parts of this list with the functions
-@code{posn-window}, @code{posn-point}, @code{posn-col-row}, and
-@code{posn-timestamp}.
-
-@item
-The function @code{scroll-bar-scale} is useful for computing where to
-scroll to in response to a mouse button event from a scroll bar. It
-takes two arguments, @var{ratio} and @var{total}, and in effect
-multiplies them. We say ``in effect'' because @var{ratio} is not a
-number; rather a pair @code{(@var{num} . @var{denom}).
-
-Here's the usual way to use @code{scroll-bar-scale}:
-
-@example
-(scroll-bar-scale (posn-col-row (event-start event))
- (buffer-size))
-@end example
-@end itemize
-
-@section Putting Keyboard Events in Strings
-
- In most of the places where strings are used, we conceptualize the
-string as containing text characters---the same kind of characters found
-in buffers or files. Occasionally Lisp programs use strings which
-conceptually contain keyboard characters; for example, they may be key
-sequences or keyboard macro definitions. There are special rules for
-how to put keyboard characters into a string, because they are not
-limited to the range of 0 to 255 as text characters are.
-
- A keyboard character typed using the @key{META} key is called a
-@dfn{meta character}. The numeric code for such an event includes the
-2**23 bit; it does not even come close to fitting in a string. However,
-earlier Emacs versions used a different representation for these
-characters, which gave them codes in the range of 128 to 255. That did
-fit in a string, and many Lisp programs contain string constants that
-use @samp{\M-} to express meta characters, especially as the argument to
-@code{define-key} and similar functions.
-
- We provide backward compatibility to run those programs with special
-rules for how to put a keyboard character event in a string. Here are
-the rules:
-
-@itemize @bullet
-@item
-If the keyboard event value is in the range of 0 to 127, it can go in the
-string unchanged.
-
-@item
-The meta variants of those events, with codes in the range of 2**23 to
-2**23+127, can also go in the string, but you must change their numeric
-values. You must set the 2**7 bit instead of the 2**23 bit, resulting
-in a value between 128 and 255.
-
-@item
-Other keyboard character events cannot fit in a string. This includes
-keyboard events in the range of 128 to 255.
-@end itemize
-
- Functions such as @code{read-key-sequence} that can construct strings
-containing events follow these rules.
-
- When you use the read syntax @samp{\M-} in a string, it produces a
-code in the range of 128 to 255---the same code that you get if you
-modify the corresponding keyboard event to put it in the string. Thus,
-meta events in strings work consistently regardless of how they get into
-the strings.
-
- New programs can avoid dealing with these rules by using vectors
-instead of strings for key sequences when there is any possibility that
-these issues might arise.
-
- The reason we changed the representation of meta characters as
-keyboard events is to make room for basic character codes beyond 127,
-and support meta variants of such larger character codes.
-
-@section Menus
-
-You can now define menus conveniently as keymaps. Menus are normally
-used with the mouse, but they can work with the keyboard also.
-
-@subsection Defining Menus
-
-A keymap is suitable for menu use if it has an @dfn{overall prompt
-string}, which is a string that appears as an element of the keymap. It
-should describes the purpose of the menu. The easiest way to construct
-a keymap with a prompt string is to specify the string as an argument
-when you run @code{make-keymap} or @code{make-sparse-keymap}.
-
-The individual bindings in the menu keymap should also have prompt
-strings; these strings are the items in the menu. A binding with a
-prompt string looks like this:
-
-@example
-(@var{char} @var{string} . @var{real-binding})
-@end example
-
-As far as @code{define-key} is concerned, the string is part of the
-character's binding---the binding looks like this:
-
-@example
-(@var{string} . @var{real-binding}).
-@end example
-
-However, only @var{real-binding} is used for executing the key.
-
-You can also supply a second string, called the help string, as follows:
-
-@example
-(@var{char} @var{string} @var{help-string} . @var{real-binding})
-@end example
-
-Currently Emacs does not actually use @var{help-string}; it knows only
-how to ignore @var{help-string} in order to extract @var{real-binding}.
-In the future we hope to make @var{help-string} serve as longer
-documentation for the menu item, available on request.
-
-The prompt string for a binding should be short---one or two words. Its
-meaning should describe the command it corresponds to.
-
-If @var{real-binding} is @code{nil}, then @var{string} appears in the
-menu but cannot be selected.
-
-If @var{real-binding} is a symbol, and has a non-@code{nil}
-@code{menu-enable} property, that property is an expression which
-controls whether the menu item is enabled. Every time the keymap is
-used to display a menu, Emacs evaluates the expression, and it enables
-the menu item only if the expression's value is non-@code{nil}. When a
-menu item is disabled, it is displayed in a ``fuzzy'' fashion, and
-cannot be selected with the mouse.
-
-@subsection Menus and the Mouse
-
-The way to make a menu keymap produce a menu is to make it the
-definition of a prefix key.
-
-When the prefix key ends with a mouse event, Emacs handles the menu
-keymap by popping up a visible menu that you can select from with the
-mouse. When you click on a menu item, the event generated is whatever
-character or symbol has the binding which brought about that menu item.
-
-A single keymap can appear as multiple panes, if you explicitly
-arrange for this. The way to do this is to make a keymap for each
-pane, then create a binding for each of those maps in the main keymap
-of the menu. Give each of these bindings a prompt string that starts
-with @samp{@@}. The rest of the prompt string becomes the name of the
-pane. See the file @file{lisp/mouse.el} for an example of this. Any
-ordinary bindings with prompt strings are grouped into one pane, which
-appears along with the other panes explicitly created for the
-submaps.
-
-You can also get multiple panes from separate keymaps. The full
-definition of a prefix key always comes from merging the definitions
-supplied by the various active keymaps (minor modes, local, and
-global). When more than one of these keymaps is a menu, each of them
-makes a separate pane or panes.
-
-@subsection Menus and the Keyboard
-
-When a prefix key ending with a keyboard event (a character or function
-key) has a definition that is a menu keymap, you can use the keyboard
-to choose a menu item.
-
-Emacs displays the menu alternatives in the echo area. If they don't
-all fit at once, type @key{SPC} to see the next line of alternatives.
-If you keep typing @key{SPC}, you eventually get to the end of the menu
-and then cycle around to the beginning again.
-
-When you have found the alternative you want, type the corresponding
-character---the one whose binding is that alternative.
-
-In a menu intended for keyboard use, each menu item must clearly
-indicate what character to type. The best convention to use is to make
-the character the first letter of the menu item prompt string. That is
-something users will understand without being told.
-
-@subsection The Menu Bar
-
- Under X Windows, each frame can have a @dfn{menu bar}---a permanently
-displayed menu stretching horizontally across the top of the frame. The
-items of the menu bar are the subcommands of the fake ``function key''
-@code{menu-bar}, as defined by all the active keymaps.
-
- To add an item to the menu bar, invent a fake ``function key'' of your
-own (let's call it @var{key}), and make a binding for the key sequence
-@code{[menu-bar @var{key}]}. Most often, the binding is a menu keymap,
-so that pressing a button on the menu bar item leads to another menu.
-
- In order for a frame to display a menu bar, its @code{menu-bar-lines}
-property must be greater than zero. Emacs uses just one line for the
-menu bar itself; if you specify more than one line, the other lines
-serve to separate the menu bar from the windows in the frame. We
-recommend you try one or two as the @code{menu-bar-lines} value.
-
-@section Keymaps
-
-@itemize @bullet
-@item
-The representation of keymaps has changed to support the new event
-types. All keymaps now have the form @code{(keymap @var{element}
-@var{element} @dots{})}. Each @var{element} takes one of the following
-forms:
-
-@table @asis
-@item @var{prompt-string}
-A string as an element of the keymap marks the keymap as a menu, and
-serves as the overal prompt string for it.
-
-@item @code{(@var{key} . @var{binding})}
-A cons cell binds @var{key} to @var{definition}. Here @var{key} may be
-any sort of event head---a character, a function key symbol, or a mouse
-button symbol.
-
-@item @var{vector}
-A vector of 128 elements binds all the ASCII characters; the @var{n}th
-element holds the binding for character number @var{n}.
-
-@item @code{(t . @var{binding})}
-A cons cell whose @sc{car} is @code{t} is a default binding; anything
-not bound by previous keymap elements is given @var{binding} as its
-binding.
-
-Default bindings are important because they allow a keymap to bind all
-possible events without having to enumerate all the possible function
-keys and mouse clicks, with all possible modifier prefixes.
-
-The function @code{lookup-key} (and likewise other functions for
-examining a key binding) normally report only explicit bindings of the
-specified key sequence; if there is none, they return @code{nil}, even
-if there is a default binding that would apply to that key sequence if
-it were actually typed in. However, these functions now take an
-optional argument @var{accept-defaults} which, if non-@code{nil}, says
-to consider default bindings.
-
-Note that if a vector in the keymap binds an ASCII character to
-@code{nil} (thus making it ``unbound''), the default binding does not
-apply to the character. Think of the vector element as an explicit
-binding of @code{nil}.
-
-Note also that if the keymap for a minor or major mode contains a
-default binding, it completely masks out any lower-priority keymaps.
-@end table
-
-@item
-A keymap can now inherit from another keymap. Do do this, make the
-latter keymap the ``tail'' of the new one. Such a keymap looks like
-this:
-
-@example
-(keymap @var{bindings}@dots{} . @var{other-keymap})
-@end example
-
-The effect is that this keymap inherits all the bindings of
-@var{other-keymap}, but can add to them or override them with
-@var{bindings}. Subsequent changes in the bindings of
-@var{other-keymap} @emph{do} affect this keymap.
-
-For example,
-
-@example
-(setq my-mode-map (cons 'keymap text-mode-map))
-@end example
-
-@noindent
-makes a keymap that by default inherits all the bindings of Text
-mode---whatever they may be at the time a key is looked up. Any
-bindings made explicitly in @code{my-mode-map} override the bindings
-inherited from Text mode, however.
-
-@item
-Minor modes can now have local keymaps. Thus, a key can act a special
-way when a minor mode is in effect, and then revert to the major mode or
-global definition when the minor mode is no longer in effect. The
-precedence of keymaps is now: minor modes (in no particular order), then
-major mode, and lastly the global map.
-
-The new @code{current-minor-mode-maps} function returns a list of all
-the keymaps of currently enabled minor modes, in the other that they
-apply.
-
-To set up a keymap for a minor mode, add an element to the alist
-@code{minor-mode-map-alist}. Its elements look like this:
-
-@example
-(@var{symbol} . @var{keymap})
-@end example
-
-The keymap @var{keymap} is active whenever @var{symbol} has a
-non-@code{nil} value. Use for @var{symbol} the variable which indicates
-whether the minor mode is enabled.
-
-When more than one minor mode keymap is active, their order of
-precedence is the order of @code{minor-mode-map-alist}. But you should
-design minor modes so that they don't interfere with each other, and if
-you do this properly, the order will not matter.
-
-The function @code{minor-mode-key-binding} returns a list of all the
-active minor mode bindings of @var{key}. More precisely, it returns an
-alist of pairs @code{(@var{modename} . @var{binding})}, where
-@var{modename} is the the variable which enables the minor mode, and
-@var{binding} is @var{key}'s definition in that mode. If @var{key} has
-no minor-mode bindings, the value is @code{nil}.
-
-If the first binding is a non-prefix, all subsequent bindings from other
-minor modes are omitted, since they would be completely shadowed.
-Similarly, the list omits non-prefix bindings that follow prefix
-bindings.
-
-@item
-The new function @code{copy-keymap} copies a keymap, producing a new
-keymap with the same key bindings in it. If the keymap contains other
-keymaps directly, these subkeymaps are copied recursively.
-
-If you want to, you can define a prefix key with a binding that is a
-symbol whose function definition is another keymap. In this case,
-@code{copy-keymap} does not look past the symbol; it doesn't copy the
-keymap inside the symbol.
-
-@item
-@code{substitute-key-definition} now accepts an optional fourth
-argument, which is a keymap to use as a template.
-
-@example
-(substitute-key-definition olddef newdef keymap oldmap)
-@end example
-
-@noindent
-finds all characters defined in @var{oldmap} as @var{olddef},
-and defines them in @var{keymap} as @var{newdef}.
-
-In addition, this function now operates recursively on the keymaps that
-define prefix keys within @var{keymap} and @var{oldmap}.
-@end itemize
-
-@section Minibuffer Features
-
-The minibuffer input functions @code{read-from-minibuffer} and
-@code{completing-read} have new features.
-
-@subsection Minibuffer History
-
-A new optional argument @var{hist} specifies which history list to use.
-If you specify a variable (a symbol), that variable is the history
-list. If you specify a cons cell @code{(@var{variable}
-. @var{startpos})}, then @var{variable} is the history list variable,
-and @var{startpos} specifies the initial history position (an integer,
-counting from zero which specifies the most recent element of the
-history).
-
-If you specify @var{startpos}, then you should also specify that element
-of the history as @var{initial-input}, for consistency.
-
-If you don't specify @var{hist}, then the default history list
-@code{minibuffer-history} is used. Other standard history lists that
-you can use when appropriate include @code{query-replace-history},
-@code{command-history}, and @code{file-name-history}.
-
-The value of the history list variable is a list of strings, most recent
-first. You should set a history list variable to @code{nil} before
-using it for the first time.
-
-@code{read-from-minibuffer} and @code{completing-read} add new elements
-to the history list automatically, and provide commands to allow the
-user to reuse items on the list. The only thing your program needs to
-do to use a history list is to initialize it and to pass its name to the
-input functions when you wish. But it is safe to modify the list by
-hand when the minibuffer input functions are not using it.
-
-@subsection Other Minibuffer Features
-
-The @var{initial} argument to @code{read-from-minibufer} and other
-minibuffer input functions can now be a cons cell @code{(@var{string}
-. @var{position})}. This means to start off with @var{string} in the
-minibuffer, but put the cursor @var{position} characters from the
-beginning, rather than at the end.
-
-In @code{read-no-blanks-input}, the @var{initial} argument is now
-optional; if it is omitted, the initial input string is the empty
-string.
-
-@section New Features for Defining Commands
-
-@itemize @bullet
-@item
-If the interactive specification begins with @samp{@@}, this means to
-select the window under the mouse. This selection takes place before
-doing anything else with the command.
-
-You can use both @samp{@@} and @samp{*} together in one command; they
-are processed in order of appearance.
-
-@item
-Prompts in an interactive specification can incorporate the values of
-the preceding arguments. Emacs replaces @samp{%}-sequences (as used
-with the @code{format} function) in the prompt with the interactive
-arguments that have been read so far. For example, a command with this
-interactive specification
-
-@example
-(interactive "sReplace: \nsReplace %s with: ")
-@end example
-
-@noindent
-prompts for the first argument with @samp{Replace: }, and then prompts
-for the second argument with @samp{Replace @var{foo} with: }, where
-@var{foo} is the string read as the first argument.
-
-@item
-If a command name has a property @code{enable-recursive-minibuffers}
-which is non-@code{nil}, then the command can use the minibuffer to read
-arguments even if it is invoked from the minibuffer. The minibuffer
-command @code{next-matching-history-element} (normally bound to
-@kbd{M-s} in the minibuffer) uses this feature.
-@end itemize
-
-@section New Features for Reading Input
-
-@itemize @bullet
-@item
-The function @code{set-input-mode} now takes four arguments. The last
-argument is optional. Their names are @var{interrupt}, @var{flow},
-@var{meta} and @var{quit}.
-
-The argument @var{interrupt} says whether to use interrupt-driven
-input. Non-@code{nil} means yes, and @code{nil} means no (use CBREAK
-mode).
-
-The argument @var{flow} says whether to enable terminal flow control.
-Non-@code{nil} means yes.
-
-The argument @var{meta} says whether to enable the use of a Meta key.
-Non-@code{nil} means yes.
-
-If @var{quit} non-@code{nil}, it is the character to use for quitting.
-(Normally this is @kbd{C-g}.)
-
-@item
-The variable @code{meta-flag} has been deleted; use
-@code{set-input-mode} to enable or disable support for a @key{META}
-key. This change was made because @code{set-input-mode} can send the
-terminal the appropriate commands to enable or disable operation of the
-@key{META} key.
-
-@item
-The new variable @code{extra-keyboard-modifiers} lets Lisp programs
-``press'' the modifier keys on the keyboard.
-The value is a bit mask:
-
-@table @asis
-@item 1
-The @key{SHIFT} key.
-@item 2
-The @key{LOCK} key.
-@item 4
-The @key{CTL} key.
-@item 8
-The @key{META} key.
-@end table
-
-When you use X windows, the program can press any of the modifier keys
-in this way. Otherwise, only the @key{CTL} and @key{META} keys can be
-virtually pressed.
-
-@item
-You can use the new function @code{keyboard-translate} to set up
-@code{keyboard-translate-table} conveniently.
-
-@item
-Y-or-n questions using the @code{y-or-n-p} function now accept @kbd{C-]}
-(usually mapped to @code{abort-recursive-edit}) as well as @kbd{C-g} to
-quit.
-
-@item
-The variable @code{num-input-keys} is the total number of key sequences
-that the user has typed during this Emacs session.
-
-@item
-A new Lisp variable, @code{function-key-map}, holds a keymap which
-describes the character sequences sent by function keys on an ordinary
-character terminal. This uses the same keymap data structure that is
-used to hold bindings of key sequences, but it has a different meaning:
-it specifies translations to make while reading a key sequence.
-
-If @code{function-key-map} ``binds'' a key sequence @var{k} to a vector
-@var{v}, then when @var{k} appears as a subsequence @emph{anywhere} in a
-key sequence, it is replaced with @var{v}.
-
-For example, VT100 terminals send @kbd{@key{ESC} O P} when the ``keypad''
-PF1 key is pressed. Thus, on a VT100, @code{function-key-map} should
-``bind'' that sequence to @code{[pf1]}. This specifies translation of
-@kbd{@key{ESC} O P} into @key{PF1} anywhere in a key sequence.
-
-Thus, typing @kbd{C-c @key{PF1}} sends the character sequence @kbd{C-c
-@key{ESC} O P}, but @code{read-key-sequence} translates this back into
-@kbd{C-c @key{PF1}}, which it returns as the vector @code{[?\C-c PF1]}.
-
-Entries in @code{function-key-map} are ignored if they conflict with
-bindings made in the minor mode, local, or global keymaps.
-
-The value of @code{function-key-map} is usually set up automatically
-according to the terminal's Terminfo or Termcap entry, and the
-terminal-specific Lisp files. Emacs comes with a number of
-terminal-specific files for many common terminals; their main purpose is
-to make entries in @code{function-key-map} beyond those that can be
-deduced from Termcap and Terminfo.
-
-@item
-The variable @code{key-translation-map} works like @code{function-key-map}
-except for two things:
-
-@itemize @bullet
-@item
-@code{key-translation-map} goes to work after @code{function-key-map} is
-finished; it receives the results of translation by
-@code{function-key-map}.
-
-@item
-@code{key-translation-map} overrides actual key bindings.
-@end itemize
-
-The intent of @code{key-translation-map} is for users to map one
-character set to another, including ordinary characters normally bound
-to @code{self-insert-command}.
-@end itemize
-
-@section New Syntax Table Features
-
-@itemize @bullet
-@item
-You can use two new functions to move across characters in certain
-syntax classes.
-
-@code{skip-syntax-forward} moves point forward across characters whose
-syntax classes are mentioned in its first argument, a string. It stops
-when it encounters the end of the buffer, or position @var{lim} (the
-optional second argument), or a character it is not supposed to skip.
-The function @code{skip-syntax-backward} is similar but moves backward.
-
-@item
-The new function @code{forward-comment} moves point by comments. It
-takes one argument, @var{count}; it moves point forward across
-@var{count} comments (backward, if @var{count} is negative). If it
-finds anything other than a comment or whitespace, it stops, leaving
-point at the far side of the last comment found. It also stops after
-satisfying @var{count}.
-
-@item
-The new variable @code{words-include-escapes} affects the behavior of
-@code{forward-word} and everything that uses it. If it is
-non-@code{nil}, then characters in the ``escape'' and ``character
-quote'' syntax classes count as part of words.
-
-@item
-There are two new syntax flags for use in syntax tables.
-
-@itemize -
-@item
-The prefix flag.
-
-The @samp{p} flag identifies additional ``prefix characters'' in Lisp
-syntax. You can set this flag with @code{modify-syntax-entry} by
-including the letter @samp{p} in the syntax specification.
-
-These characters are treated as whitespace when they appear between
-expressions. When they appear withing an expression, they are handled
-according to their usual syntax codes.
-
-The function @code{backward-prefix-chars} moves back over these
-characters, as well as over characters whose primary syntax class is
-prefix (@samp{'}).
-
-@item
-The @samp{b} comment style flag.
-
-Emacs can now supports two comment styles simultaneously. (This is for
-the sake of C++.) More specifically, it can recognize two different
-comment-start sequences. Both must share the same first character; only
-the second character may differ. Mark the second character of the
-@samp{b}-style comment start sequence with the @samp{b} flag. You can
-set this flag with @code{modify-syntax-entry} by including the letter
-@samp{b} in the syntax specification.
-
-The two styles of comment can have different comment-end sequences. A
-comment-end sequence (one or two characters) applies to the @samp{b}
-style if its first character has the @samp{b} flag set; otherwise, it
-applies to the @samp{a} style.
-
-The appropriate comment syntax settings for C++ are as follows:
-
-@table @asis
-@item @samp{/}
-@samp{124b}
-@item @samp{*}
-@samp{23}
-@item newline
-@samp{>b}
-@end table
-
-Thus @samp{/*} is a comment-start sequence for @samp{a} style, @samp{//}
-is a comment-start sequence for @samp{b} style, @samp{*/} is a
-comment-end sequence for @samp{a} style, and newline is a comment-end
-sequence for @samp{b} style.
-@end itemize
-@end itemize
-
-@section The Case Table
-
-You can customize case conversion using the new case table feature. A
-case table is a collection of strings that specifies the mapping between
-upper case and lower case letters. Each buffer has its own case table.
-You need a case table if you are using a language which has letters that
-are not standard ASCII letters.
-
-A case table is a list of this form:
-
-@example
-(@var{downcase} @var{upcase} @var{canonicalize} @var{equivalences})
-@end example
-
-@noindent
-where each element is either @code{nil} or a string of length 256. The
-element @var{downcase} says how to map each character to its lower-case
-equivalent. The element @var{upcase} maps each character to its
-upper-case equivalent. If lower and upper case characters are in 1-1
-correspondence, use @code{nil} for @var{upcase}; then Emacs deduces the
-upcase table from @var{downcase}.
-
-For some languages, upper and lower case letters are not in 1-1
-correspondence. There may be two different lower case letters with the
-same upper case equivalent. In these cases, you need to specify the
-maps for both directions.
-
-The element @var{canonicalize} maps each character to a canonical
-equivalent; any two characters that are related by case-conversion have
-the same canonical equivalent character.
-
-The element @var{equivalences} is a map that cyclicly permutes each
-equivalence class (of characters with the same canonical equivalent).
-
-You can provide @code{nil} for both @var{canonicalize} and
-@var{equivalences}, in which case both are deduced from @var{downcase}
-and @var{upcase}.
-
-Here are the functions for working with case tables:
-
-@code{case-table-p} is a predicate that says whether a Lisp object is a
-valid case table.
-
-@code{set-standard-case-table} takes one argument and makes that
-argument the case table for new buffers created subsequently.
-@code{standard-case-table} returns the current value of the new buffer
-case table.
-
-@code{current-case-table} returns the case table of the current buffer.
-@code{set-case-table} sets the current buffer's case table to the
-argument.
-
-@code{set-case-syntax-pair} is a convenient function for specifying a
-pair of letters, upper case and lower case. Call it with two arguments,
-the upper case letter and the lower case letter. It modifies the
-standard case table and a few syntax tables that are predefined in
-Emacs. This function is intended as a subroutine for packages that
-define non-ASCII character sets.
-
-Load the library @file{iso-syntax} to set up the syntax and case table for
-the 256 bit ISO Latin 1 character set.
-
-@section New Features for Dealing with Buffers
-
-@itemize @bullet
-@item
-The new function @code{buffer-modified-tick} returns a buffer's
-modification-count that ticks every time the buffer is modified. It
-takes one optional argument, which is the buffer you want to examine.
-If the argument is @code{nil} (or omitted), the current buffer is used.
-
-@item
-@code{buffer-disable-undo} is a new name for the function
-formerly known as @code{buffer-flush-undo}. This turns off recording
-of undo information in the buffer given as argument.
-
-@item
-The new function @code{generate-new-buffer-name} chooses a name that
-would be unique for a new buffer---but does not create the buffer. Give
-it one argument, a starting name. It produces a name not in use for a
-buffer by appending a number inside of @samp{<@dots{}>}.
-
-@item
-The function @code{rename-buffer} now takes an option second argument
-which tells it that if the specified new name corresponds to an existing
-buffer, it should use @code{generate-new-buffer-name} to modify the name
-to be unique, rather than signaling an error.
-
-@code{rename-buffer} now returns the name to which the buffer was
-renamed.
-
-@item
-The function @code{list-buffers} now looks at the local variable
-@code{list-buffers-directory} in each non-file-visiting buffer, and
-shows its value where the file would normally go. Dired sets this
-variable in each Dired buffer, so the buffer list now shows which
-directory each Dired buffer is editing.
-
-@item
-The function @code{other-buffer} now takes an optional second argument
-@var{visible-ok} which, if non-@code{nil}, indicates that buffers
-currently being displayed in windows may be returned even if there are
-other buffers not visible. Normally, @code{other-buffer} returns a
-currently visible buffer only as a last resort, if there are no suitable
-nonvisible buffers.
-
-@item
-The hook @code{kill-buffer-hook} now runs whenever a buffer is killed.
-@end itemize
-
-@section Local Variables Features
-
-@itemize @bullet
-@item
-If a local variable name has a non-@code{nil} @code{permanent-local}
-property, then @code{kill-all-local-variables} does not kill it. Such
-local variables are ``permanent''---they remain unchanged even if you
-select a different major mode.
-
-Permanent locals are useful when they have to do with where the file
-came from or how to save it, rather than with how to edit the contents.
-
-@item
-The function @code{make-local-variable} now never changes the value of the variable
-that it makes local. If the variable had no value before, it still has
-no value after becoming local.
-
-@item
-The new function @code{default-boundp} tells you whether a variable has
-a default value (as opposed to being unbound in its default value). If
-@code{(default-boundp 'foo)} returns @code{nil}, then
-@code{(default-value 'foo)} would get an error.
-
-@code{default-boundp} is to @code{default-value} as @code{boundp} is to
-@code{symbol-value}.
-
-@item
-The special forms @code{defconst} and @code{defvar}, when the variable
-is local in the current buffer, now set the variable's default value
-rather than its local value.
-@end itemize
-
-@section New Features for Subprocesses
-
-@itemize @bullet
-@item
-@code{call-process} and @code{call-process-region} now return a value
-that indicates how the synchronous subprocess terminated. It is either
-a number, which is the exit status of a process, or a signal name
-represented as a string.
-
-@item
-@code{process-status} now returns @code{open} and @code{closed} as the
-status values for network connections.
-
-@item
-The standard asynchronous subprocess features work on VMS now,
-and the special VMS asynchronous subprocess functions have been deleted.
-
-@item
-You can use the transaction queue feature for more convenient
-communication with subprocesses using transactions.
-
-Call @code{tq-create} to create a transaction queue communicating with a
-specified process. Then you can call @code{tq-enqueue} to send a
-transaction. @code{tq-enqueue} takes these five arguments:
-
-@example
-(tq-enqueue @var{tq} @var{question} @var{regexp} @var{closure} @var{fn})
-@end example
-
-@var{tq} is the queue to use. (Specifying the queue has the effect of
-specifying the process to talk to.) The argument @var{question} is the
-outgoing message which starts the transaction. The argument @var{fn} is
-the function to call when the corresponding answer comes back; it is
-called with two arguments: @var{closure}, and the answer received.
-
-The argument @var{regexp} is a regular expression to match the entire
-answer; that's how @code{tq-enqueue} tells where the answer ends.
-
-Call @code{tq-close} to shut down a transaction queue and terminate its
-subprocess.
-
-@item
-The function @code{signal-process} sends a signal to process @var{pid},
-which need not be a child of Emacs. The second argument @var{signal}
-specifies which signal to send; it should be an integer.
-@end itemize
-
-@section New Features for Dealing with Times And Time Delays
-
-@itemize @bullet
-@item
-The new function @code{current-time} returns the system's time value as
-a list of three integers: @code{(@var{high} @var{low} @var{microsec})}.
-The integers @var{high} and @var{low} combine to give the number of
-seconds since 0:00 January 1, 1970, which is @var{high} * 2**16 +
-@var{low}.
-
-@var{microsec} gives the microseconds since the start of the current
-second (or 0 for systems that return time only on the resolution of a
-second).
-
-@item
-The function @code{current-time-string} accepts an optional argument
-@var{time-value}. If given, this specifies a time to format instead of
-the current time. The argument should be a cons cell containing two
-integers, or a list whose first two elements are integers. Thus, you
-can use times obtained from @code{current-time} (see above) and from
-@code{file-attributes}.
-
-@item
-You can now find out the user's time zone using @code{current-time-zone}.
-It takes no arguments, and returns a list of this form:
-
-@example
-(@var{offset} @var{savings-flag} @var{standard} @var{savings})
-@end example
-
-@var{offset} is an integer specifying how many minutes east of Greenwich
-the current time zone is located. A negative value means west of
-Greenwich. Note that this describes the standard time; if daylight
-savings time is in effect, it does not affect this value.
-
-@var{savings-flag} is non-@code{nil} iff daylight savings time or some other
-sort of seasonal time adjustment is in effect.
-
-@var{standard} is a string giving the name of the time zone when no
-seasonal time adjustment is in effect.
-
-@var{savings} is a string giving the name of the time zone when there is a
-seasonal time adjustment in effect.
-
-If the user has specified a region that does not use a seasonal time
-adjustment, @var{savings-flag} is always @code{nil}, and @var{standard}
-and @var{savings} are equal.
-
-@item
-@code{sit-for}, @code{sleep-for} now let you specify the time period in
-milliseconds as well as in seconds. The first argument gives the number
-of seconds, as before, and the optional second argument gives additional
-milliseconds. The time periods specified by these two arguments are
-added together.
-
-Not all systems support this; you get an error if you specify nonzero
-milliseconds and it isn't supported.
-
-@code{sit-for} also accepts an optional third argument @var{nodisp}. If
-this is non-@code{nil}, @code{sit-for} does not redisplay. It still
-waits for the specified time or until input is available.
-
-@item
-@code{accept-process-output} now accepts a timeout specified by optional
-second and third arguments. The second argument specifies the number of
-seconds, while the third specifies the number of milliseconds. The time
-periods specified by these two arguments are added together.
-
-Not all systems support this; you get an error if you specify nonzero
-milliseconds and it isn't supported.
-
-The function returns @code{nil} if the timeout expired before output
-arrived, or non-@code{nil} if it did get some output.
-
-@item
-You can set up a timer to call a function at a specified future time.
-To do so, call @code{run-at-time}, like this:
-
-@example
-(run-at-time @var{time} @var{repeat} @var{function} @var{args}@dots{})
-@end example
-
-Here, @var{time} is a string saying when to call the function. The
-argument @var{function} is the function to call later, and @var{args}
-are the arguments to give it when it is called.
-
-The argument @var{repeat} specifies how often to repeat the call. If
-@var{repeat} is @code{nil}, there are no repetitions; @var{function} is
-called just once, at @var{time}. If @var{repeat} is an integer, it
-specifies a repetition period measured in seconds.
-
-Absolute times may be specified in a wide variety of formats; The form
-@samp{@var{hour}:@var{min}:@var{sec} @var{timezone}
-@var{month}/@var{day}/@var{year}}, where all fields are numbers, works;
-the format that @code{current-time-string} returns is also allowed.
-
-To specify a relative time, use numbers followed by units.
-For example:
-
-@table @samp
-@item 1 min
-denotes 1 minute from now.
-@item 1 min 5 sec
-denotes 65 seconds from now.
-@item 1 min 2 sec 3 hour 4 day 5 week 6 fortnight 7 month 8 year
-denotes exactly 103 months, 123 days, and 10862 seconds from now.
-@end table
-
-If @var{time} is an integer, that specifies a relative time measured in
-seconds.
-@end itemize
-
-To cancel the requested future action, pass the value that @code{run-at-time}
-returned to the function @code{cancel-timer}.
-
-@section Profiling Lisp Programs
-
-You can now make execution-time profiles of Emacs Lisp programs using
-the @file{profile} library. See the file @file{profile.el} for
-instructions; if you have written a Lisp program big enough to be worth
-profiling, you can surely understand them.
-
-@section New Features for Lisp Debuggers
-
-@itemize @bullet
-@item
-You can now specify which kinds of errors should invoke the Lisp
-debugger by setting the variable @code{debug-on-error} to a list of error
-conditions. For example, if you set it to the list @code{(void-variable)},
-then only errors about a variable that has no value invoke the
-debugger.
-
-@item
-The variable @code{command-debug-status} is used by Lisp debuggers. It
-records the debugging status of current interactive command. Each time
-a command is called interactively, this variable is bound to
-@code{nil}. The debugger can set this variable to leave information for
-future debugger invocations during the same command.
-
-The advantage of this variable over some other variable in the debugger
-itself is that the data will not be visible for any other command
-invocation.
-
-@item
-The function @code{backtrace-frame} is intended for use in Lisp
-debuggers. It returns information about what a frame on the Lisp call
-stack is doing. You specify one argument, which is the number of stack
-frames to count up from the current execution point.
-
-If that stack frame has not evaluated the arguments yet (or is a special
-form), the value is @code{(nil @var{function} @var{arg-forms}@dots{})}.
-
-If that stack frame has evaluated its arguments and called its function
-already, the value is @code{(t @var{function}
-@var{arg-values}@dots{})}.
-
-In the return value, @var{function} is whatever was supplied as @sc{car}
-of evaluated list, or a @code{lambda} expression in the case of a macro
-call. If the function has a @code{&rest} argument, that is represented
-as the tail of the list @var{arg-values}.
-
-If the argument is out of range, @code{backtrace-frame} returns
-@code{nil}.
-@end itemize
-
-@ignore
-
-@item
-@code{kill-ring-save} now gives visual feedback to indicate the region
-of text being added to the kill ring. If the opposite end of the
-region is visible in the current window, the cursor blinks there.
-Otherwise, some text from the other end of the region is displayed in
-the message area.
-@end ignore
-
-@section Memory Allocation Changes
-
-The list that @code{garbage-collect} returns now has one additional
-element. This is a cons cell containing two numbers. It gives
-information about the number of used and free floating point numbers,
-much as the first element gives such information about the number of
-used and free cons cells.
-
-The new function @code{memory-limit} returns an indication of the last
-address allocated by Emacs. More precisely, it returns that address
-divided by 1024. You can use this to get a general idea of how your
-actions affect the memory usage.
-
-@section Hook Changes
-
-@itemize @bullet
-@item
-Expanding an abbrev first runs the new hook
-@code{pre-abbrev-expand-hook}.
-
-@item
-The editor command loop runs the normal hook @code{pre-command-hook}
-before each command, and runs @code{post-command-hook} after each
-command.
-
-@item
-Auto-saving runs the new hook @code{auto-save-hook} before actually
-starting to save any files.
-
-@item
-The new variable @code{revert-buffer-insert-file-contents-function}
-holds a function that @code{revert-buffer} now uses to read in the
-contents of the reverted buffer---instead of calling
-@code{insert-file-contents}.
-
-@item
-The variable @code{lisp-indent-hook} has been renamed to
-@code{lisp-indent-function}.
-
-@item
-The variable @code{auto-fill-hook} has been renamed to
-@code{auto-fill-function}.
-
-@item
-The variable @code{blink-paren-hook} has been renamed to
-@code{blink-paren-function}.
-
-@item
-The variable @code{temp-buffer-show-hook} has been renamed to
-@code{temp-buffer-show-function}.
-
-@item
-The variable @code{suspend-hook} has been renamed to
-@code{suspend-hooks}, because it is a list of functions but is not a
-normal hook.
-
-@item
-The new function @code{add-hook} provides a handy way to add a function
-to a hook variable. For example,
-
-@example
-(add-hook 'text-mode-hook 'my-text-hook-function)
-@end example
-
-@noindent
-arranges to call @code{my-text-hook-function}
-when entering Text mode or related modes.
-@end itemize
-
-@bye
+++ /dev/null
-
-# This is termcap.dat, a copy of the /etc/termcap file included here
-# for use on VMS.
-
-# I know that many terminals are missing from this version of the file
-# because they were deleted at MIT.
-# I hope that someone will add in all the missing terminal types
-# and send me a corrected, larger file.
-
-# These are local terminals.
-
-v1|tvi912|912|920|tvi920|old televideo:\
- :ct=\E3:st=\E1:cr=^M:do=^J:nl=^J:bl=^G:\
- :al=33*\EE:le=^H:ce=\ET:cm=\E=%+ %+ :cl=^Z:co#80:dc=\EW:dl=33*\ER:ei=:\
- :kb=^h:ku=^K:kd=^J:kl=^H:kr=^L:k0=^A@\r:k1=^AA\r:k2=^AB\r:k3=^AC\r:\
- :bs:am:k4=^AD\r:k5=^AE\r:k6=^AF\r:k7=^AG\r:k8=^AH\r:k9=^AI\r:\
- :ho=^^:im=:ic=\EQ:li#24:nd=^L:ta=^I:pt:se=\Ek:so=\Ej:up=^K:us=\El:ue=\Em:\
- :ma=^K^P^L :sg#1:ug#1:
-ZV|bobcat|sbobcat|HP 9000 model 300 console:\
- :al=10*\EL:am:bs:\
- :cd=\EJ:ce=\EK:ch=6\E&a%dC:cl=\EH\EJ:\
- :co#128:da:db:dc=\EP:dl=10*\EM:do=\EB:ei=\ER:\
- :kb=^H:kd=\EB:kh=\Eh:kl=\ED:kr=\EC:ku=\EA:\
- :ke=\E&s0A:ks=\E&s1A:\
- :li#47:mi:nd=\EC:pt:\
- :se=\E&d@:so=\E&dB:\
- :up=\EA:xs:\
- :cm=6\E&a%dy%dC:cv=6\E&a%dY:\
- :im=\EQ:ml=\El:mu=\Em:\
- :ue=\E&d@:us=\E&dD:bt=\Ei:sg#0:
-ZX|gator-t|HP 9000 model 237 emulating extra-tall AAA:\
- :cr=^M:do=^J:nl=^J:bl=^G:al=\E[L:le=^H:bs:\
- :cd=\E[J:ce=\E[K:cl=\E[H\E[J:cm=\E[%i%d;%dH:co#128:li#94:\
- :dc=\E[P:dl=\E[M:ho=\E[H:ic=\E[@:\
- :AL=1*\E[%dL:DL=1*\E[%dM:IC=4\E[%d@:DC=4\E[%dP:rp=1*%.\E[%db:mr=\E[7m:me=\E[m:\
- :km:ch=\E[%i%d`:\
- :ul:ei=:im=:pt:bw:bt=\E[Z:\
- :mi:nd=\E[C:se=\E[m:so=\E[7m:ue=\E[m:us=\E[4m:up=\EM:
-ZW|gator|HP 9000 model 237 emulating AAA:\
- :cr=^M:do=^J:nl=^J:bl=^G:al=\E[L:le=^H:bs:\
- :cd=\E[J:ce=\E[K:cl=\E[H\E[J:cm=\E[%i%d;%dH:co#128:li#47:\
- :dc=\E[P:dl=\E[M:ho=\E[H:ic=\E[@:\
- :AL=1*\E[%dL:DL=1*\E[%dM:IC=4\E[%d@:DC=4\E[%dP:rp=1*%.\E[%db:mr=\E[7m:me=\E[m:\
- :km:ch=\E[%i%d`:\
- :ul:ei=:im=:pt:bw:bt=\E[Z:\
- :mi:nd=\E[C:se=\E[m:so=\E[7m:ue=\E[m:us=\E[4m:up=\EM:
-ZY|gator-52|HP 9000 model 237 emulating VT52:\
- :cr=^M:do=^J:nl=^J:bl=^G:\
- :le=^H:bs:cd=\EJ:ce=\EK:cl=\EH\EJ:cm=\EY%+ %+ :co#128:li#47:nd=\EC:\
- :ta=^I:pt:sr=\EI:up=\EA:ku=\EA:kd=\EB:kr=\EC:kl=\ED:kb=^H:\
- :ce=\EK:ho=\EH:
-ZZ|gator-52t|HP 9000 model 237 emulating extra-tall VT52:\
- :cr=^M:do=^J:nl=^J:bl=^G:\
- :le=^H:bs:cd=\EJ:ce=\EK:cl=\EH\EJ:cm=\EY%+ %+ :co#128:li#94:nd=\EC:\
- :ta=^I:pt:sr=\EI:up=\EA:ku=\EA:kd=\EB:kr=\EC:kl=\ED:kb=^H:\
- :ce=\EK:ho=\EH:
-#
-# N: ANN ARBOR
-#
-N0|aa|annarbor|4080|ann arbor 4080:\
- :cr=^M:do=^J:nl=^J:bl=^G:pt:ct=^\^P^P:st=^]^P1:\
- :cm=^O%r%\066%.%>^S^L%+@:\
- :co#80:li#40:le=^H:bs:cl=2^L:up=^N:nd=^_:ho=^K:am:\
- :kb=^^:kd=^J:ku=^N:kl=^H:kr=^_:kh=^K:ma=^_ ^N^P:
-# Needs function keys added.
-# Originally from Mike O'Brien@Rand and Howard Katseff at Bell Labs.
-# Highly modified 6/22 by Mike O'Brien.
-# split out into several for the various screen sizes by dave-yost@rand
-# Modifications made 3/82 by Mark Horton
-# Modified by Tom Quarles at UCB for greater efficiency and more diversity
-# status line moved to top of screen, vb removed 5/82
-#
-# assumes the following setup:
-# A: 0000 1010 0001 0000
-# B: 9600 0100 1000 0000 0000 1000 0000 17 19
-# C: 56 66 0 0 9600 0110 1100
-# D: 0110 1001 1 0
-#
-# Briefly, the settings are for the following modes:
-# (values are for bit set/clear with * indicating our preference
-# and the value used to test these termcaps)
-# Note that many of these settings are irrelevant to the termcap
-# and are just set to the default mode of the terminal as shipped
-# by the factory.
-#
-# A menu: 0000 1010 0001 0000
-# Block/underline cursor*
-# blinking/nonblinking cursor*
-# key click/no key click*
-# bell/no bell at column 72*
-#
-# key pad is cursor control*/key pad is numeric
-# return and line feed/return for <cr> key *
-# repeat after .5 sec*/no repeat
-# repeat at 25/15 chars per sec. *
-#
-# hold data until pause pressed/process data unless pause pressed*
-# slow scroll/no slow scroll*
-# Hold in area/don't hold in area*
-# functions keys have default*/function keys disabled on powerup
-#
-# show/don't show position of cursor during page transmit*
-# unused
-# unused
-# unused
-#
-# B menu: 9600 0100 1000 0000 0000 1000 0000 17 19
-# Baud rate (9600*)
-#
-# 2 bits of parity - 00=odd,01=even*,10=space,11=mark
-# 1 stop bit*/2 stop bits
-# parity error detection off*/on
-#
-# keyboard local/on line*
-# half/full duplex*
-# disable/do not disable keyboard after data transmission*
-#
-# transmit entire page/stop transmission at cursor*
-# transfer/do not transfer protected characters*
-# transmit all characters/transmit only selected characters*
-# transmit all selected areas/transmit only 1 selected area*
-#
-# transmit/do not transmit line separators to host*
-# transmit/do not transmit page tab stops tabs to host*
-# transmit/do not transmit column tab stop tabs to host*
-# transmit/do not transmit graphics control (underline,inverse..)*
-#
-# enable*/disable auto XON/XOFF control
-# require/do not require receipt of a DC1 from host after each LF*
-# pause key acts as a meta key/pause key is pause*
-# unused
-#
-# unused
-# unused
-# unused
-# unused
-#
-# XON character (17*)
-# XOFF character (19*)
-#
-# C menu: 56 66 0 0 9600 0110 1100
-# number of lines to print data on (printer) (56*)
-#
-# number of lines on a sheet of paper (printer) (66*)
-#
-# left margin (printer) (0*)
-#
-# number of pad chars on new line to printer (0*)
-#
-# printer baud rate (9600*)
-#
-# printer parity: 00=odd,01=even*,10=space,11=mark
-# printer stop bits: 2*/1
-# print/do not print guarded areas*
-#
-# new line is: 01=LF,10=CR,11=CRLF*
-# unused
-# unused
-#
-# D menu: 0110 1001 1 0
-# LF is newline/LF is down one line, same column*
-# wrap to preceding line if move left from col 1*/don't wrap
-# wrap to next line if move right from col 80*/don't wrap
-# backspace is/is not destructive*
-#
-# display*/ignore DEL character
-# display will not/will scroll*
-# page/column tab stops*
-# erase everything*/erase unprotected only
-#
-# editing extent: 0=display,1=line*,2=field,3=area
-#
-# unused
-#
-N1|aaa-29-np|aaa-29 with no padding (for psl):\
- :al=\E[L:ce=\E[K:cl=\E[H\E[J:\
- :dc=\E[P:dl=\E[M:ic=\E[@:
-tc=aaa-29:
-N2|aaa-unk|ann arbor ambassador (internal - don't use this directly):\
- :cr=^M:do=^J:nl=^J:bl=^G:al=1*\E[L:am:le=^H:bs:km:\
- :cd=7.2*\E[J:ce=5\E[K:cl=7.2*\E[H\E[J:cm=\E[%i%d;%dH:co#80:\
- :dc=4\E[P:dl=1*\E[M:ho=\E[H:ic=4\E[@:\
- :md=\E[1m:mr=\E[7m:mb=\E[5m:mk=\E[8m:me=\E[m:\
- :ku=\EM:kd=\ED:kl=\E[D:kr=\E[C:kh=\E[H:ce=\E[K:\
- :ks=\EP`?z~[H~[[J`>z~[[J`8xz~[M`4xz~[[D`6xz~[[C`2xz~[D\E\\:\
- :ke=\EP`?y~[H~[[J`>y~[[2J`8xy~[M`4xy~[[D`6xy~[[C`2xy~[D\E\\:\
- :ch=\E[%i%d`:\
- :ei=:im=:pt:bw:bt=\E[Z:\
- :mi:nd=\E[C:se=\E[m:so=\E[7m:ue=\E[m:us=\E[4m:up=\EM:\
- :AL=1*\E[%dL:DL=1*\E[%dM:IC=4\E[%d@:DC=4\E[%dP:\
- :cS=\E[%d;%d;%d;%dp:\
- :vs=\E[>52;54h\E[>30;37;38;39l:ve=\E[>52l\E[>37h:
-# All the ti strings used to start with \E[2J, which cleared the screen.
-# But this was so slow that it caused ^S/^Q lossage.
-# So I removed the \E[2J's. -- rms, 1/29/86
-N3|aaa-18|ann arbor ambassador/18 lines:\
- :ti=\E[18;0;0;18p:\
- :te=\E[60;0;0;18p\E[18;1H\E[J:\
- :is=\EP`+x~M\E\\\E[m\E7\E[60;0;0;18p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\
- :li#18:tc=aaa-unk:
-N4|aaa-20|ann arbor ambassador/20 lines:\
- :ti=\E[20;0;0;20p:\
- :te=\E[60;0;0;20p\E[20;1H\E[J:\
- :is=\EP`+x~M\E\\\E[m\E7\E[60;0;0;20p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\
- :li#20:tc=aaa-unk:
-N5|aaa-22|ann arbor ambassador/22 lines:\
- :ti=\E[22;0;0;22p:\
- :te=\E[60;0;0;22p\E[22;1H\E[J:\
- :is=\EP`+x~M\E\\\E[m\E7\E[60;0;0;22p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\
- :li#22:tc=aaa-unk:
-N6|aaa-24|ann arbor ambassador/24 lines:\
- :ti=\E[24;0;0;24p:\
- :te=\E[60;0;0;24p\E[24;1H\E[J:\
- :is=\EP`+x~M\E\\\E[m\E7\E[60;0;0;24p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\
- :li#24:tc=aaa-unk:
-N7|aaa-26|ann arbor ambassador/26 lines:\
- :ti=\E[26;0;0;26p:\
- :te=\E[60;0;0;26p\E[26;1H\E[J:\
- :is=\EP`+x~M\E\\\E[m\E7\E[60;0;0;26p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\
- :li#26:tc=aaa-unk:
-N8|aaa-28|ann arbor ambassador/28 lines:\
- :ti=\E[28;0;0;28p:\
- :te=\E[60;0;0;28p\E[28;1H\E[J:\
- :is=\EP`+x~M\E\\\E[m\E7\E[60;0;0;28p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\
- :li#28:tc=aaa-unk:
-N9|aaa|ambassador|aaa-30|ann arbor ambassador/30 lines:\
- :ti=\E[30;0;0;30p:\
- :te=\E[60;0;0;30p\E[30;1H\E[J:\
- :is=\EP`+x~M\E\\\E[m\E7\E[30;0;0;30p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\
- :li#30:tc=aaa-unk:
-NA|aaa-36|ann arbor ambassador/36 lines:\
- :ti=\E[36;0;0;36p:\
- :te=\E[60;0;0;36p\E[36;1H\E[J:\
- :is=\EP`+x~M\E\\\E[m\E7\E[60;0;0;36p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\
- :li#36:tc=aaa-unk:
-NB|aaa-40|ann arbor ambassador/40 lines:\
- :ti=\E[40;0;0;40p:\
- :te=\E[60;0;0;40p\E[40;1H\E[J:\
- :is=\EP`+x~M\E\\\E[m\E7\E[60;0;0;40p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\
- :li#40:tc=aaa-unk:
-NC|aaa-48|ann arbor ambassador/48 lines:\
- :ti=\E[48;0;0;48p:\
- :te=\E[60;0;0;48p\E[48;1H\E[J:\
- :is=\EP`+x~M\E\\\E[m\E7\E[60;0;0;48p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\
- :li#48:tc=aaa-unk:
-ND|aaa-60|ann arbor ambassador/60 lines:\
- :ti=\E[60;0;0;60p:\
- :te=\E[60;0;0;60p\E[60;1H\E[J:\
- :is=\EP`+x~M\E\\\E[m\E7\E[60;0;0;60p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\
- :li#60:tc=aaa-unk:
-NE|aaa-unk-s|ann arbor ambassador unknown with/status:\
- :hs:es:i2=\E7\E[>51h\E[H\E[2K\E[>51l\E8:\
- :ts=\E7\E[>51h\E[H\E[2K\E[%i%d`:fs=\E[>51l\E8:\
- :ds=\E7\E[>51h\E[H\E[2K\E[>51l\E8:\
- :tc=aaa-unk:
-NF|aaa-18-s|ann arbor ambassador/18 lines + status line:\
- :ti=\E[18;1;0;18p:\
- :te=\E[60;1;0;18p\E[17;1H\E[J:\
- :is=\EP`+x~M\E\\\E[m\E7\E[60;1;0;18p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\
- :li#17:tc=aaa-unk-s:
-NG|aaa-20-s|ann arbor ambassador/20 lines + status line:\
- :ti=\E[20;1;0;20p:\
- :te=\E[60;1;0;20p\E[19;1H\E[J:\
- :is=\EP`+x~M\E\\\E[m\E7\E[60;1;0;20p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\
- :li#19:tc=aaa-unk-s:
-NH|aaa-22-s|ann arbor ambassador/22 lines + status line:\
- :ti=\E[22;1;0;22p:\
- :te=\E[60;1;0;22p\E[21;1H\E[J:\
- :is=\EP`+x~M\E\\\E[m\E7\E[60;1;0;22p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\
- :li#21:tc=aaa-unk-s:
-NI|aaa-24-s|ann arbor ambassador/24 lines + status line:\
- :ti=\E[24;1;0;24p:\
- :te=\E[60;1;0;24p\E[23;1H\E[J:\
- :is=\EP`+x~M\E\\\E[m\E7\E[60;1;0;24p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\
- :li#23:tc=aaa-unk-s:
-NJ|aaa-26-s|ann arbor ambassador/26 lines + status line:\
- :ti=\E[26;1;0;26p:\
- :te=\E[60;1;0;26p\E[25;1H\E[J:\
- :is=\EP`+x~M\E\\\E[m\E7\E[60;1;0;26p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\
- :li#25:tc=aaa-unk-s:
-NK|aaa-28-s|ann arbor ambassador/28 lines + status line:\
- :ti=\E[28;1;0;28p:\
- :te=\E[60;1;0;28p\E[27;1H\E[J:\
- :is=\EP`+x~M\E\\\E[m\E7\E[60;1;0;28p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\
- :li#27:tc=aaa-unk-s:
-NL|aaa-30-s|ann arbor ambassador/30 lines + status line:\
- :ti=\E[30;1;0;30p:\
- :te=\E[60;1;0;30p\E[29;1H\E[J:\
- :is=\EP`+x~M\E\\\E[m\E7\E[60;1;0;30p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\
- :li#29:tc=aaa-unk-s:
-NM|aaa-36-s|ann arbor ambassador/36 lines + status line:\
- :ti=\E[36;1;0;36p:\
- :te=\E[60;1;0;36p\E[35;1H\E[J:\
- :is=\EP`+x~M\E\\\E[m\E7\E[60;1;0;36p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\
- :li#35:tc=aaa-unk-s:
-NN|aaa-40-s|ann arbor ambassador/40 lines + status line:\
- :ti=\E[40;1;0;40p:\
- :te=\E[60;1;0;40p\E[39;1H\E[J:\
- :is=\EP`+x~M\E\\\E[m\E7\E[60;1;0;40p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\
- :li#39:tc=aaa-unk-s:
-NO|aaa-48-s|ann arbor ambassador/48 lines+sl:\
- :ti=\E[48;1;0;48p:te=\E[60;1;0;48p\E[47;1H\E[J:\
- :is=\EP`+x~M\E\\\E[m\EP`?y~[[2J~[[H\E7\E[60;1;0;48p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\
- :li#47:tc=aaa-unk-s:
-NP|aaa-60-s|ann arbor ambassador/60 lines + status line:\
- :ti=\E[60;1;0;60p:te=\E[60;1;0;60p\E[59;1H\E[J:\
- :is=\EP`+x~M\E\\\E[m\E7\E[60;1;0;60p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\
- :li#59:tc=aaa-unk-s:
-NQ|aaa-18-rv|ambassador/18 lines+rv:\
- :md=\E[1;7m:mr=\E[m:mb=\E[5;7m:mk=\E[7;8m:me=\E[7m:\
- :us=\E[4;7m:ue=\E[7m:se=\E[7m:so=\E[m:\
- :is=\EP`+x~M\E\\\E[7m\E7\E[60;0;0;18p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\
- :tc=aaa-18:
-NR|aaa-20-rv|ambassador/20 lines+rv:\
- :md=\E[1;7m:mr=\E[m:mb=\E[5;7m:mk=\E[7;8m:me=\E[7m:\
- :us=\E[4;7m:ue=\E[7m:se=\E[7m:so=\E[m:\
- :is=\EP`+x~M\E\\\E[7m\E7\E[60;0;0;20p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\
- :tc=aaa-20:
-NS|aaa-22-rv|ambassador/22 lines+rv:\
- :md=\E[1;7m:mr=\E[m:mb=\E[5;7m:mk=\E[7;8m:me=\E[7m:\
- :us=\E[4;7m:ue=\E[7m:se=\E[7m:so=\E[m:\
- :is=\EP`+x~M\E\\\E[7m\E7\E[60;0;0;22p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\
- :tc=aaa-22:
-NT|aaa-24-rv|ambassador/24 lines+rv:\
- :md=\E[1;7m:mr=\E[m:mb=\E[5;7m:mk=\E[7;8m:me=\E[7m:\
- :us=\E[4;7m:ue=\E[7m:se=\E[7m:so=\E[m:\
- :is=\EP`+x~M\E\\\E[7m\E7\E[60;0;0;24p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\
- :tc=aaa-24:
-NU|aaa-26-rv|ambassador/26 lines+rv:\
- :md=\E[1;7m:mr=\E[m:mb=\E[5;7m:mk=\E[7;8m:me=\E[7m:\
- :us=\E[4;7m:ue=\E[7m:se=\E[7m:so=\E[m:\
- :is=\EP`+x~M\E\\\E[7m\E7\E[60;0;0;26p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\
- :tc=aaa-26:
-NV|aaa-28-rv|ambassador/28 lines+rv:\
- :md=\E[1;7m:mr=\E[m:mb=\E[5;7m:mk=\E[7;8m:me=\E[7m:\
- :us=\E[4;7m:ue=\E[7m:se=\E[7m:so=\E[m:\
- :is=\EP`+x~M\E\\\E[7m\E7\E[60;0;0;28p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\
- :tc=aaa-28:
-NW|aaa-30-rv|ann arbor ambassador/30 lines in reverse video:\
- :md=\E[1;7m:mr=\E[m:mb=\E[5;7m:mk=\E[7;8m:me=\E[7m:\
- :us=\E[4;7m:ue=\E[7m:se=\E[7m:so=\E[m:\
- :is=\EP`+x~M\E\\\E[7m\E7\E[60;0;0;30p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\
- :tc=aaa-30:
-NX|aaa-36-rv|ann arbor ambassador/36 lines in reverse video:\
- :md=\E[1;7m:mr=\E[m:mb=\E[5;7m:mk=\E[7;8m:me=\E[7m:\
- :us=\E[4;7m:ue=\E[7m:se=\E[7m:so=\E[m:\
- :is=\EP`+x~M\E\\\E[7m\E7\E[60;0;0;36p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\
- :tc=aaa-36:
-NY|aaa-40-rv|ann arbor ambassador/40 lines in reverse video:\
- :md=\E[1;7m:mr=\E[m:mb=\E[5;7m:mk=\E[7;8m:me=\E[7m:\
- :us=\E[4;7m:ue=\E[7m:se=\E[7m:so=\E[m:\
- :is=\EP`+x~M\E\\\E[7m\E7\E[60;0;0;40p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\
- :tc=aaa-40:
-NZ|aaa-48-rv|ann arbor ambassador/48 lines in reverse video:\
- :md=\E[1;7m:mr=\E[m:mb=\E[5;7m:mk=\E[7;8m:me=\E[7m:\
- :us=\E[4;7m:ue=\E[7m:se=\E[7m:so=\E[m:\
- :is=\EP`+x~M\E\\\E[7m\E7\E[60;0;0;48p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\
- :tc=aaa-48:
-Na|aaa-60-rv|ann arbor ambassador/60 lines in reverse video:\
- :md=\E[1;7m:mr=\E[m:mb=\E[5;7m:mk=\E[7;8m:me=\E[7m:\
- :us=\E[4;7m:ue=\E[7m:se=\E[7m:so=\E[m:\
- :is=\EP`+x~M\E\\\E[7m\E7\E[60;0;0;60p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\
- :tc=aaa-60:
-Nb|aaa-18-rv-s|aaa-18-s-rv|ambassador/18 lines+sl+rv:\
- :md=\E[1;7m:mr=\E[m:mb=\E[5;7m:mk=\E[7;8m:me=\E[7m:\
- :us=\E[4;7m:ue=\E[7m:se=\E[7m:so=\E[m:\
- :is=\EP`+x~M\E\\\E[7m\E7\E[60;1;0;18p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\
- :tc=aaa-18-s:
-Nc|aaa-20-rv-s|aaa-20-s-rv|ambassador/20 lines+sl+rv:\
- :md=\E[1;7m:mr=\E[m:mb=\E[5;7m:mk=\E[7;8m:me=\E[7m:\
- :us=\E[4;7m:ue=\E[7m:se=\E[7m:so=\E[m:\
- :is=\EP`+x~M\E\\\E[7m\E7\E[60;1;0;20p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\
- :tc=aaa-20-s:
-Nd|aaa-22-rv-s|aaa-22-s-rv|ambassador/22 lines+sl+rv:\
- :md=\E[1;7m:mr=\E[m:mb=\E[5;7m:mk=\E[7;8m:me=\E[7m:\
- :us=\E[4;7m:ue=\E[7m:se=\E[7m:so=\E[m:\
- :is=\EP`+x~M\E\\\E[7m\E7\E[60;1;0;22p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\
- :tc=aaa-22-s:
-Ne|aaa-24-rv-s|aaa-24-s-rv|ambassador/24 lines+sl+rv:\
- :md=\E[1;7m:mr=\E[m:mb=\E[5;7m:mk=\E[7;8m:me=\E[7m:\
- :us=\E[4;7m:ue=\E[7m:se=\E[7m:so=\E[m:\
- :is=\EP`+x~M\E\\\E[7m\E7\E[60;1;0;24p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\
- :tc=aaa-24-s:
-Nf|aaa-26-rv-s|aaa-26-s-rv|ambassador/26 lines+sl+rv:\
- :md=\E[1;7m:mr=\E[m:mb=\E[5;7m:mk=\E[7;8m:me=\E[7m:\
- :us=\E[4;7m:ue=\E[7m:se=\E[7m:so=\E[m:\
- :is=\EP`+x~M\E\\\E[7m\E7\E[60;1;0;26p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\
- :tc=aaa-26-s:
-Ng|aaa-28-rv-s|aaa-28-s-rv|ambassador/28 lines+sl+rv:\
- :md=\E[1;7m:mr=\E[m:mb=\E[5;7m:mk=\E[7;8m:me=\E[7m:\
- :us=\E[4;7m:ue=\E[7m:se=\E[7m:so=\E[m:\
- :is=\EP`+x~M\E\\\E[7m\E7\E[60;1;0;28p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\
- :tc=aaa-28-s:
-Nh|aaa-30-rv-s|aaa-30-s-rv|ambassador/30 lines+sl+rv:\
- :md=\E[1;7m:mr=\E[m:mb=\E[5;7m:mk=\E[7;8m:me=\E[7m:\
- :us=\E[4;7m:ue=\E[7m:se=\E[7m:so=\E[m:\
- :is=\EP`+x~M\E\\\E[7m\E7\E[60;1;0;30p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\
- :tc=aaa-30-s:
-Ni|aaa-36-rv-s|aaa-36-s-rv|ambassador/36 lines+sl+rv:\
- :md=\E[1;7m:mr=\E[m:mb=\E[5;7m:mk=\E[7;8m:me=\E[7m:\
- :us=\E[4;7m:ue=\E[7m:se=\E[7m:so=\E[m:\
- :is=\EP`+x~M\E\\\E[7m\E7\E[60;1;0;36p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\
- :tc=aaa-36-s:
-Nj|aaa-40-rv-s|aaa-40-s-rv|ambassador/40 lines+sl+rv:\
- :md=\E[1;7m:mr=\E[m:mb=\E[5;7m:mk=\E[7;8m:me=\E[7m:\
- :us=\E[4;7m:ue=\E[7m:se=\E[7m:so=\E[m:\
- :is=\EP`+x~M\E\\\E[7m\E7\E[60;1;0;40p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\
- :tc=aaa-40-s:
-Nk|aaa-48-rv-s|aaa-48-s-rv|ambassador/48 lines+sl+rv:\
- :md=\E[1;7m:mr=\E[m:mb=\E[5;7m:mk=\E[7;8m:me=\E[7m:\
- :us=\E[4;7m:ue=\E[7m:se=\E[7m:so=\E[m:\
- :is=\EP`+x~M\E\\\E[7m\E7\E[60;1;0;48p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\
- :tc=aaa-48-s:
-Nl|aaa-60-rv-s|aaa-60-s-rv|ambassador/60 lines+sl+rv:\
- :md=\E[1;7m:mr=\E[m:mb=\E[5;7m:mk=\E[7;8m:me=\E[7m:\
- :us=\E[4;7m:ue=\E[7m:se=\E[7m:so=\E[m:\
- :is=\EP`+x~M\E\\\E[7m\E7\E[60;1;0;60p\E[3g\E[f\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E[8a\EH\E8\E[>6h\E[1Q:\
- :tc=aaa-60-s:
-Nm|aaa-24-ctxt:\
- :ti=\E[30;1H\E[K\E[24;0;0;24p:te=\E[60;1;0;24p\E[60;1H\E[K:tc=aaa-24:
-Nn|aaa-24-rv-ctxt:\
- :ti=\E[30;1H\E[K\E[24;0;0;24p:te=\E[60;1;0;24p\E[60;1H\E[K:tc=aaa-24-rv:
-No|aaa-30-s-ctxt:\
- :ti=\E[30;1H\E[K\E[30;1;0;30p:te=\E[60;1;0;30p\E[59;1H\E[K:tc=aaa-30-s:
-Np|aaa-30-s-rv-ctxt:\
- :ti=\E[30;1H\E[K\E[30;1;0;30p:\
- :te=\E[60;1;0;30p\E[59;1H\E[K:tc=aaa-30-s-rv:
-Nq|aaa-ctxt|aaa-30-ctxt:\
- :ti=\E[30;0;0;30p:te=\E[60;0;0;30p\E[60;1H\E[K:tc=aaa-30:
-Nr|aaa-rv-ctxt|aaa-30-rv-ctxt:\
- :ti=\E[30;0;0;30p:te=\E[60;0;0;30p\E[60;1H\E[K:tc=aaa-30-rv:
-Ns|aaa-db|ann arbor ambassador 30/destructive backspace:\
- :ti=\E[H\E[J\E[30;0;0;30p:te=\E7\E[60;0;0;30p\E8:li#30:\
- :is=\E[60;0;0;30p\E[H\E[J\E[1Q\E[m\E[20l\E[>30h:le=\E[D:bc=\E[D:bs@:\
- :tc=aaa-unk:
-#Kludge for supdup
-aaa-supdup|ann arbor ambassador 30/ for supdup :\
- :ns:tc=aaa-30:
-
-#
-# yet another attempt at the aaa terminal from CCA:
-#
-ZJ|aaax|ambasx|ambassadorx|ann arbor ambassador base descriptor/:\
- :al=\E[L:bs:bt=\E[Z:bw:\
- :cd=\E[J:ce=\E[K:ch=\E[%i%d`:cl=\E[H\E[2J:cm=\E[%i%d;%dH:co#80:\
- :cv=\E[%i%dd:da:db:dc=\E[P:dl=\E[M:ho=\E[H:ic=\E[@:\
- :mi:nd=\E[C:pt:sf=\E[S:sr=\E[T:se=\E[m:so=\E[7m:\
- :km:mm=\E[>52h:mo=\E[>52l:\
- :ue=\E[m:up=\E[A:us=\E[4m:
-ZK|aaa48|ambas|ambassador|ann arbor ambassador/48 lines:\
- :is=\E[48;0;0;48p\E[H\E[J\E[1Q\E[m\E[>30l\E[>26l\E[>32h\E[>33h\E[>52h:\
- :li#48:mi:tc=aaax:
-ZL|aaa24|ambas24|ambassador24|ann arbor ambassador/24 lines:\
- :is=\E[24;0;0;24p\E[H\E[J\E[1Q\E[m\E[>30l\E[>26l\E[>32h\E[>33h\E[>52h:\
- :li#24:mi:tc=aaax:
-ZM|aaa30|ambas30|ambassador30|ann arbor ambassador/30 lines:\
- :is=\E[30;0;0;30p\E[H\E[J\E[1Q\E[m\E[>30l\E[>26l\E[>32h\E[>33h\E[>52h:\
- :li#30:mi:tc=aaax:
-ZN|aaa60|ambas60|ambassador60|ann arbor ambassador/60 lines:\
- :is=\E[60;0;0;60p\E[H\E[J\E[1Q\E[m\E[>30l\E[>26l\E[>32h\E[>33h\E[>52h:\
- :li#60:mi:tc=aaax:
-# vt100 -- this has been changed to delete the "pt" ("real tabs")
-# option, which was losing. -- walter 10/84
-d0|vt100-132|vt125-132|dec vt100 with 132 columns:\
- :co#132:tc=vt100:
-d0|vt100|vt100-am|vt100-80|vt125|vt125-80|dec vt100:\
- :cr=^M:bl=^G:le=^H:do=\ED:ho=\E[H:\
- :co#80:li#24:cl=45\E[H\E[2J:bs:am:cm=5\E[%i%d;%dH:nd=\E[C:up=\E[A:\
- :ce=2\E[K:cd=2*\E[J:so=2\E[7m:se=2\E[m:us=2\E[4m:ue=2\E[m:\
- :md=2\E[1m:mr=2\E[7m:mb=2\E[5m:me=2\E[m:\
- :is=\E<\E[m\E>\E[?7h\E[?3;4;6l\200\200\200\200\200\200\200\200:\
- :rs=\E<\E[m\E>\E[?7h\E[?3;4;6l\200\200\200\200\200\200\200\200:\
- :ku=\EOA:kd=\EOB:kr=\EOC:kl=\EOD:kb=^H:\
- :cs=\E[%i%d;%dr:ks=\E[?1h\E=:ke=\E[?1l\E>:\
- :kh=\E[H:k1=\EOP:k2=\EOQ:k3=\EOR:k4=\EOS:ta=^I:sf=5\ED:sr=5\EM:xn:\
- :dN#4:vt#3:sc=\E7:rc=\E8:
-d0|vt132-132|dec vt132 with 132 columns:\
- :al=99\E[L:dl=99\E[M:ip=7:dc=7\E[P:ei=\E[4l:im=\E[4h:xn:dN#30:\
- :co#132:tc=vt100:
-d0|vt132|vt132-80|dec vt132 with 80 columns:\
- :al=99\E[L:dl=99\E[M:ip=7:dc=7\E[P:ei=\E[4l:im=\E[4h:xn:dN#30:tc=vt100:
-
-dw|vt52|vt52-80|dec vt52:\
- :cr=^M:do=^J:nl=^J:bl=^G:\
- :le=^H:bs:cd=\EJ:ce=\EK:cl=\EH\EJ:cm=\EY%+ %+ :co#80:li#24:nd=\EC:\
- :ta=^I:pt:sr=\EI:up=\EA:ku=\EA:kd=\EB:kr=\EC:kl=\ED:kb=^H:
-
-# Sun workstation consoles
-Mu|sun|Sun Microsystems Workstation console:\
- :li#34:co#80:cl=^L:cm=\E[%i%d;%dH:nd=\E[C:up=\E[A:\
- :am:bs:km:mi:ms:pt:\
- :ce=\E[K:cd=\E[J:so=\E[7m:se=\E[m:rs=\E[s:\
- :kd=\E[B:kl=\E[D:ku=\E[A:kr=\E[C:kh=\E[H:\
- :k1=\E[224z:k2=\E[225z:k3=\E[226z:k4=\E[227z:k5=\E[228z:\
- :k6=\E[229z:k7=\E[230z:k8=\E[231z:k9=\E[232z:\
- :al=\E[L:dl=\E[M:im=:ei=:ic=\E[@:dc=\E[P:\
- :AL=\E[%dL:DL=\E[%dM:IC=\E[%d@:DC=\E[%dP:
-# From john@ucbrenoir Tue Sep 24 13:14:44 1985
-Mu|sun-s|Sun Microsystems Workstation window with status line:\
- :hs:ts=\E]l:fs=\E\\:ds=\E]l\E\\:tc=sun
-Mu|sun-e-s|sun-s-e|Sun Microsystems Workstation with status hacked for emacs:\
- :hs:ts=\E]l:fs=\E\\:ds=\E]l\E\\:tc=sun-e:
-M0|sun-48|Sun 48-line window:\
- :li#48:co#80:tc=sun:
-M1|sun-34|Sun 34-line window:\
- :li#34:co#80:tc=sun:
-M2|sun-24|Sun 24-line window:\
- :li#24:co#80:tc=sun:
-M3|sun-17|Sun 17-line window:\
- :li#17:co#80:tc=sun:
-M4|sun-12|Sun 12-line window:\
- :li#12:co#80:tc=sun:
-M5|sun-1|Sun 1-line window for sysline:\
- :li#1:co#80:es:hs:ts=\r:fs=\E[K:ds=^L:tc=sun:
-M6|sun-e|sun-nic|sune|Sun Microsystems Workstation without insert character:\
- :ic@:im@:ei@:tc=sun:
-
-# Nu machine parameters taken from mit-vax.
-# smc - 5/21/85
-#
-dg|nuterminal:\
- :al=1*\EL:am:bs:cd=60\EJ:ce=10\EK:cl=60\EE:cm=10\EY%+ %+ :\
- co#80:dc=2.5*\EN:\
- :dl=1*\EM:do=\EB:ei=\EO:ho=\EH:im=\E@:ip=2.5*:li#24:mi:nd=\EC:\
- :as=\EF:ae=\EG:\
- :ms:pt:sr=\EI:se=\Eq:so=\Ep:up=\EA:vs=\Ex4:ve=\Ey4:\
- :kb=^h:ku=\EA:kd=\EB:kl=\ED:kr=\EC:kh=\EH:kn#8:\
- :k1=\ES:k2=\ET:k3=\EU:k4=\EV:k5=\EW:\
- :l6=blue:l7=red:l8=white:k6=\EP:k7=\EQ:k8=\ER:
-nu|nu24|nuwindow:\
- :al=1*\EL:bs:cd=\EJ:ce=\EK:cl=\EE:cm=\EY%+ %+ :co#86:\
- :dl=1*\EM:do=\EB:ei=\EO:ho=\EH:im=\E@:ip=2.5*:li#24:mi:nd=\EC:\
- :as=\EF:ae=\EG:\
- :ms:pt:sr=\EI:se=\Eq:so=\Ep:up=\EA:vs=\Ex4:ve=\Ey4:\
- :kb=^h:ku=\EA:kd=\EB:kl=\ED:kr=\EC:kh=\EH:
-bnu|nu51|bnuwindow:\
- :co#86:li#51:tc=nu:
-fnu|nu61|fnuwindow:\
- :co#86:li#61:tc=nu:
-nunix-30|nu-telnet-30|nu-half: Half nu screen thru telnet:\
- :am:al=\EL:bs:cd=\EJ:ce=\EK:cl=\EE:cm=\EY%+ %+ :co#78:\
- :dl=\EM:do=\EB:ip=2.5*:ho=\EH:li#30:nd=\EC:\
- :pt:sr=\EI:se=\Eq:so=\Ep:up=\EA:
-nunix-61|nu-telnet-61|nu-full| Full nu screen thru telnet:\
- :co#78:li#61:tc=nunix-30:
-
-## VT200 entry for VMS. Also for VT300.
-# Make sure not to use \n for nl or anything else.
-# It is bad form to use ^J,^L,^K to scroll the screen.
-# If the VT2xx doesn't have newline mode set those characters
-# donot move the cursor down a line. Use \ED instead.
-d0|vt200-80|vt200|vt300-80|VT 200 with 80 columns, on VMS:\
- :AL=\E[%dL:DC=\E[%dP:DL=\E[%dM:DO=\E[%dB:IC=\E[%d@:\
- :LE=\E[%dD:RI=\E[%dC:SR=1*\E[%dM:UP=\E[%dA:al=\E[L:\
- :am:bl=^G:bs:cd=2*\E[J:ce=2*\E[K:cl=45\E[H\E[2J:\
- :cm=%i\E[%d;%dH:co#80:cr=\r:cs=\E[%i%d;%dr:ct=\E[3g:\
- :dc=\E[P:dl=\E[M:dm=:do=\ED:ec=\E[%dX:ed=:ei=\E[4l:\
- :ho=\E[H:ic:im=\E[4h:it#8:k1=\EOP:k2=\EOQ:k3=\EOR:\
- :k4=\EOS:kd=\E[B:ke=\E[?1l\E>:kl=\E[D:kn#4:kr=\E[C:ks=\E[?1h\E=:\
- :ku=\E[A:le=^H:li#24:mb=\E[5m:md=\E[1m:me=\E[0m:mi:\
- :mr=\E[7m:ms:nd=\E[C:nl=\ED:nw=\EE:pf=\E[?4i:po=\E[?5i:\
- :ps=\E[i:rc=\E8:sc=\E7:se=\E[27m:sf=1*\ED:so=\E[7m:\
- :sr=1*\EM:st=\EH:ue=\E[24m:up=\EM:us=\E[4m:xn:
-d0|vt200-132|vt300-132|VT 200 with 132 columns, on VMS:\
- :co#132:tc=vt200-80:
-
-aP|apollo_15P|apollo 15 inch display:\
- :dN@:tc=vt132:
-aQ|apollo_19L|apollo 19 inch display:\
- :dN@:tc=vt132:
-aR|apollo_color|apollo color display:\
- :dN@:tc=vt132:
-aS|apollo_800_color|apollo 800 line color display:\
- :dN@:tc=vt132:
-d3|vt132|vt-132:\
- :al=99\E[L:dl=99\E[M:ip=7:dc=7\E[P:ei=\E[4l:im=\E[4h:xn:dN#30:tc=vt100:
-d0|vt100|vt100n|vt100 with no init:\
- :co#80:li#24:am:bs:pt:xn:cl=45\E[H\E[2J:\
- :cm=%i\E[%d;%dH:nd=\E[C:up=\EM:ho=\E[H:ce=2\E[K:cd=2*\E[J:\
- :nl=\EE:cr=\r:sr=5\EM:sf=30\E7\E[200H\ED\E8:\
- :sc=\E7:rc=\E8:cs=\E[%i%d;%dr:so=\E[7m:se=\E[m:us=\E[4m:ue=\E[m:LC:\
- :kl=\E[D:kr=\E[C:ku=\E[A:kd=\E[B:k1=\EOP:k2=\EOQ:k3=\EOR:k4=\EOS:
-# *************************************************************************
-# Added for del to use a 132 char width terminal
-#
-d0|vt100l|vt100n|vt100 with no init:\
- :co#132:li#24:am:bs:pt:xn:cl=45\E[H\E[2J:\
- :cm=%i\E[%d;%dH:nd=\E[C:up=\EM:ho=\E[H:ce=2\E[K:cd=2*\E[J:\
- :nl=\EE:cr=\r:sr=5\EM:sf=30\E7\E[200H\ED\E8:\
- :sc=\E7:rc=\E8:cs=\E[%i%d;%dr:so=\E[7m:se=\E[m:us=\E[4m:ue=\E[m:LC:\
- :kl=\E[D:kr=\E[C:ku=\E[A:kd=\E[B:k1=\EOP:k2=\EOQ:k3=\EOR:k4=\EOS:
-#
-# End of "Add for del"
-# **************************************************************************
-df|vt100|vt-100|vt100f|pt100|pt-100|dec vt100 (fast scroll, reverse video):\
- :is=\E>\E[?4l\E[?5h\E[?7h\E[?8h:\
- :if=/usr/lib/tabset/vt100:tc=vt100n:
-d1|vt100|vt100fnv|dec vt100 (fast scroll, normal video):\
- :is=\E>\E[?4l\E[?5l\E[?7h\E[?8h:\
- :if=/usr/lib/tabset/vt100:tc=vt100n:
-ds|vt100|vt100s|dec vt100 (smooth scroll, reverse video):\
- :is=\E>\E[?4h\E[?5h\E[?7h\E[?8h:\
- :if=/usr/lib/tabset/vt100:tc=vt100n:
-dn|vt100|vt100snv|dec vt100 (smooth scroll, normal video):\
- :is=\E>\E[?4h\E[?5l\E[?7h\E[?8h:\
- :if=/usr/lib/tabset/vt100:tc=vt100n:
-# This was designed for a VT320 emulator, but it is probably a good start
-# at support for the VT320 itself.
-# Please send changes with explanations to bug-gnu-emacs@prep.ai.mit.edu.
-k3|vt320|vt320-k3|kermit|MS-Kermit 3.00's vt320 emulation:\
- :AL=\E[%dL:CC=\E:DL=\E[%dM:IC=\E[%d@:DC=\E[%dP:DO=\E[%dB:LE=\E[%dD:\
- :RI=\E[%dC:SR=\E[%dL:UP=\E[%dA:ae=\E(B:al=\E[L:am:as=\E(0:bl=^G:\
- :cd=\E[J:ce=\E[K:ch=\E[%i%dG:cl=\E[H\E[J:cm=\E[%i%d;%dH:co#80:cr=^M:\
- :cs=\E[%i%d;%dr:ct=\E[3g:cv=\E[%i%dd:dc=\E[P:do=^J:dl=\E[M:ds=\E[0$~:\
- :ec=\E[%dX:ei=\E[4l:es:fs=\E[0$}:ho=\E[H:hs:im=\E[4h:\
- :is=\E>\E F\E[?1l\E[?7h\E[r\E[2$~:k1=\EOP:k2=\EOQ:\
- :k3=\EOR:k4=\EOS:k6=\E[17~:k7=\E[18~:k8=\E[19~:k9=\E[20~:k0=\E[21~:\
- :kI=\E[2~:kL=\E[3~:kN=\E[6~:kP=\E[5~:kb=^H:kd=\EOB:ke=\E[?1l\E>:\
- :kl=\EOD:km:kn#20:kr=\EOC:ks=\E[?1h\E=:ku=\EOA:\
- :le=^H:li#49:mb=\E[5m:md=\E[1m:me=\E[m:mi:mr=\E[7m:ms:nd=\E[C:\
- :nl=^J:pb#9600:po=\E[5i:pf=\E[4i:ps=\E[0i:pt:rc=\E8:\
- :rs=\E(B\E)B\E>\E F\E[4;20l\E[12h\E[?1;5;6;38;42l\E[?7;25h\E4i\E?4i\E[m\E[r\E[2$~:\
- :sc=\E7:se=\E[27m:sf=^J:so=\E[7m:sr=\EM:st=\EH:ta=^I:\
- :ts=\E[1$}^M\E[K:ue=\E[24m:\
- :up=\E[A:us=\E[4m:vb=\E[?5h\E[?5l\E[?5h\E[?5l\E[?5h\E[?5l:ve=\E[?25h:\
- :vi=\E[?25l:vt#3:xn:
-sw|switch|intelligent switch:co#80:os:am:
-su|dumb|un|unknown:co#80:os:am:
-sp|plugboard:co#80:os:am:
-sa|arpanet|network:co#80:os:am:
-sd|du|dialup:co#80:os:am:
-sb|bussiplexer:co#80:os:am:
-# Note that all of these claim to be "c100" in order to please the
-# pen and emacs editors. If the user does a "tset c100" he will get co.
-co|c100|concept|concept100|concept 100:\
- :is=\EU\Ef\E7\E5\E8\El\ENH\EK\E\200\Eo&\200\Eo\47\E:\
- :al=3*\E^R:am:bs:cd=16*\E^C:ce=16\E^S:cl=2*^L:cm=\Ea%+ %+ :co#80:\
- :dc=16\E^A:dl=3*\E^B:ei=\E\200:eo:im=\E^P:in:ip=16*:li#24:mi:nd=\E=:\
- :pt:kb=^h:so=\ENh:se=\ENH:ta=8\t:ul:up=\E;:db:xn:vs=\EW:ve=\Ew:\
- :vb=\Ek\200\200\200\200\200\200\200\200\200\200\200\200\200\200\EK:\
- :us=\EG:ue=\Eg:ks=\EX\ES:ke=\Ex\Es:ku=\E;:kd=\E<:kl=\E>:kr=\E=:kh=\E?:\
- :k1=\E5:k2=\E6:k3=\E7:.dN#9:dC#9:
-c4|c100|c1004p|c100 w/4 pages:\
- :ti=\EU\Ev 8p\Ep\r:te=\Ev ~p\Ep\r\n:vs@:ve@:tc=concept:
-cP|c100|c100rv4ppp|c100 with printer port:\
- :is=\EU\Ef\E7\E5\E8\El\ENH\Ek\E\200\Eo&\200\Eo!\200\EQ"\EY(^W\Eo\47\E:\
- :tc=c100rv4p:
-cR|c100|c100rv4p|c100 w/4 pages:\
- :ti=\EU\Ev 8p\Ep\r:te=\Ev ~p\Ep\r\n:tc=c100rv:
-# Some tty drivers use cr3 for concept, others use nl3, hence dN/dC below.
-cd|c100|c100rvs|slow reverse concept 100:\
- :vb=\EK\200\Ek:pt:dC@:dN@:tc=c100rv:
-cn|c100|c100rv4pna|c100 with no arrows:ks@:ke@:tc=c100rv4p:
-cr|c100|c100rv|c100 rev video:\
- :is=\EU\Ef\E7\E5\E8\El\ENH\Ek\E\200\Eo&\200\Eo\47\E:vs@:ve@:\
- :vb=\EK\200\200\200\200\200\200\200\200\200\200\200\200\200\200\Ek:\
- :tc=concept:
-cs|c100|c100s|slowconcept|slowconcept100|slow concept 100:\
- :vb=\Ek\200\EK:pt:dC@:dN@:tc=concept:
-# vt100 and vt132 are still untested
-# Note that all of these claim to be "vt100", so the first one wins.
-dG|gigi|GIGI|dec gigi (naively treated as a straight vt100):\
- :tc=vt100n:
-dR|vt125|dec vt125 (naively treated as a straight vt100; R for ReGIS):\
- :tc=vt100n:
-kA|h19A|heathA|h19A|heathkitA|heathkit h19 ansi mode:\
- :al=1*\E[1L:am:bs:cd=\E[J:ce=\E[K:cl=\E[2J:cm=\E[%i%2;%2H:co#80:\
- :dc=\E[1P:dl=1*\E[1M:dn=\E[1B:ei=\E[4l:ho=\E[H:im=\E[4h:li#24:mi:\
- :nd=\E[1C:as=\E[10m:ae=\E[11m:ms:pt:se=\E[0m:so=\E[7m:up=\E[1A:\
- :vs=\E[>4h:ve=\E[>4l:kb=^h:ku=\E[1A:kd=\E[1B:kl=\E[1D:kr=\E[1C:\
- :kh=\E[H:kn#8:k1=\EOS:k2=\EOT:k3=\EOU:k4=\EOV:k5=\EOW:l6=blue:\
- :l7=red:l8=white:k6=\EOP:k7=\EOQ:k8=\EOR:\
- :sr=\EM:is=\E<\E[>1;2;3;4;5;6;7;8;9l\E[0m\E[11m\E[?7h:
-kB|h19bs|heathkit w/keypad shifted:ks=\Et:ke=\Eu:tc=h19b:
-kU|h19us|heathkit w/keypad shifted/underscore cursor:ks=\Et:ke=\Eu:tc=h19u:
-kb|h19|heath|h19b|heathkit|heath-19|z19|zenith|heathkit h19:\
- :al=1*\EL:am:bs:cd=\EJ:ce=\EK:cl=\EE:cm=\EY%+ %+ :co#80:dc=\EN:\
- :dl=1*\EM:do=\EB:ei=\EO:ho=\EH:im=\E@:li#24:mi:nd=\EC:as=\EF:ae=\EG:\
- :ms:pt:sr=\EI:se=\Eq:so=\Ep:up=\EA:vs=\Ex4:ve=\Ey4:\
- :kb=^h:ku=\EA:kd=\EB:kl=\ED:kr=\EC:kh=\EH:kn#8:\
- :k1=\ES:k2=\ET:k3=\EU:k4=\EV:k5=\EW:\
- :l6=blue:l7=red:l8=white:k6=\EP:k7=\EQ:k8=\ER:
-ke|e19|winston edmond special:vb=\Eg\Eh:tc=h19:
-ku|h19u|heathkit with underscore cursor:vs@:ve@:tc=h19b:
-Ma|aa|annarbor|ann arbor:\
- :cm=^O%r%B%.%>^S^L%+@:co#80:li#40:bs:cl=2^L:up=^N:nd=^_:ho=^K:am:\
- :kb=^^:kd=^J:ku=^N:kl=^H:kr=^_:kh=^K:ma=^_ ^N^P:
-# The A manufacturer represents Diablo, DTC, Xerox, Qume, and other Daisy
-# wheel terminals until such time as termcap distinguishes between them
-# enough to justify separate codes.
-# 1620 uses all 132 columns, 1640 sets left margin to 8 and uses snazzy
-# binary tabset file. Both should work on both terminals.
-A6|1620|450|diablo 1620:\
- :if=/usr/lib/tabset/std:\
- :kb=^H:bs:co#132:ff=^L:hc:hu=\EU:hd=\ED:os:pt:up=\E\n:
-A7|1640|diablo 1640:\
- :co#124:if=/usr/lib/tabset/diablo:tc=1620:
-Ad|dtc300s|300|300s|gsi|dtc|dtc 300s:\
- :if=/usr/lib/tabset/std:\
- :kb=^h:bs:co#132:ff=^L:hc:hu=\EH:hd=\Eh:os:pt:up=^Z:
-Ag|gsi:bs:co#132:hc:hd=\Eh:hu=\EH:os:pt:up=^Z:
-Aj|aj830|aj832|aj|anderson jacobson:\
- :bs:hc:hd=\E9:hu=\E8:os:pl:up=\E7:
-Aq|qume5|qume|Qume Sprint 5:\
- :if=/usr/lib/tabset/std:\
- :kb=^h:bs:co#80:ff=^L:hc:hu=\EH:hd=\Eh:os:pt:up=^Z:
-Ax|x1720|xerox 1720:co#132:bs:ff=^L:hc:os:pt:if=/usr/lib/tabset/xerox1720
-Ca|cdc456|cdc:\
- :li#24:co#80:cl=^Y^X:nd=^L:up=^Z:bs:\
- :cm=\E1%+ %+ :ho=^Y:al=\E\114:dl=\E\112:ce=^V:cd=^X:am:
-Cc|cdc456tst:\
- :li#24:co#80:cl=^y^x:bs:cm=\E1%+ %+ :am:
-D0|dm1520|1520|datamedia 1520:\
- :am:bs:cd=^K:ce=^]:cl=^L:cm=^^%r%+ %.:co#80:ho=^Y:\
- :ku=^_:kd=^J:kl=^H:kr=^\:kh=^Y:\
- :li#24:nd=^\:up=^_:xn:ma=^\ ^_^P^YH:pt:
-D1|dm1521|1521|datamedia 1521:\
- :am:bs:cd=^K:ce=^]:cl=^L:cm=^^%r%+ %.:co#80:ho=^Y:\
- :ku=^_:kd=^J:kl=^H:kr=^\:kh=^Y:\
- :li#24:nd=^\:up=^_:xn:ma=^\ ^_^P^YH:pt:
-D2|dm2500|datamedia2500|2500|datamedia 2500:\
- :al=15^P\n^X^]^X^]:bs:ce=^W:cl=^^^^\177:cm=^L%r%n%.%.:co#80:\
- :dc=10*\b:dl=10*^P^Z^X^]:dm=^P:ed=^X^]:ei=10\377\377^X^]:ho=^B:ic10*^\:\
- :im=^P:li#24:nc:nd=^\:pc=\377:so=^N:se=^X^]:up=^Z:
-D3|dm3025|datamedia 3025a:is=\EQ\EU\EV:\
- :al=130\EP\n\EQ:bs:cd=2\EJ:ce=\EK:cl=2\EM:cm=\EY%r%+ %+ :\
- :co#80:dc=6\b:dl=130\EP\EA\EQ:dm=\EP:ed=\EQ:ei=\EQ:ho=\EH:\
- :im=\EP:ip=6:li#24:nd=\EC:pt:so=\EOA:se=\EO@:up=\EA:
-D4|3045|dm3045|datamedia 3045a:is=\EU\EV:\
- :am:bs:cd=2\EJ:ce=\EK:cl=2\EM:cm=\EY%r%+ %+ :co#80:\
- :dc=6\EB:dm=:ed=:ei=\EP:ho=\EH:ic=:im=\EP:ip=6:\
- :k0=\Ey\r:k1=\Ep\r:k2=\Eq\r:k3=\Er\r:k4=\Es\r:\
- :k5=\Et\r:k6=\Eu\r:k7=\Ev\r:k8=\Ew\r:k9=\Ex\r:\
- :kh=\EH:ku=\EA:kr=\EC:li#24:nd=\EC:pc=\177:pt:eo:ul:up=\EA:xn:
-D5|dt80|dmdt80|dm80|datamedia dt80/1:\
- :is=\E<\E[2J\E[H\E[?1;3;5;6;9l\E[?7;8h:\
- :am:bs:cd=\E[J:co#80:li#24:ce=\E[K:cl=\E[2J\E[H:\
- :cm=%i\E[%d;%dH:ho=\E[H:nd=\E[C:\
- :so=\E[7m:se=\E[m:\
- :up=\E[A:us=\E[4m:ue=\E[m:\
- :vb=\E[?5h\E[?5l:\
- :vs=\E[1;2;3;4q\E[?4l:ve=\E[0q\E?4h:\
- :kd=\E[B:kl=\E[D:kr=\E[C:ku=\E[A:\
- :sr=\EM:\
- :k1=\EOP:k2=\EOQ:k3=\EOR:k4=\EOS:
-D6|dt80132|dmdt80132|datamedia dt80/1 in 132 char mode:\
- :bs:cd=20^[[0J:co#132:ce=20^[[0K:kd=^[[B:kl=^[[D:kr=^[[C:ku=^[[A:\
- :li#24:cm=5^[[%i%d;%dH:cl=50^[[H^[[2J:nd=^[[C:up=5^[[A:
-ED|delta|dd5000|delta data 5000:\
- :am:bs:cl=^NR:cm=^O%D%+9%D%+9:co#80:li#27:ho=^NQ:nc:nd=^Y:\
- :up=^Z:ce=^NU:dc=^NV:ma=^K^J^Z^P^Y :xr:
-# Note: the h1552 appears to be the first Hazeltine terminal which
-# is not braindamaged. It has tildes and backprimes and everything!
-# Be sure the auto lf/cr switch is set to cr.
-H2|h1552|hazeltine 1552:\
- :al=\EE:dl=\EO:f1=\EP:l1=blue:f2=\EQ:l2=red:f3=\ER:l3=green:tc=vt52:
-H3|h1552rv|hazeltine 1552 reverse video:\
- :so=\ES:se=\ET:tc=h1552:
-H5|h1500|hazeltine 1500:\
- :al=40~^Z:am:bs:cd=10~^X:ce=~^O:cl=~^\:cm=~^Q%r%.%.:co#80:\
- :dl=40~^S:do=~^K:hz:li#24:nd=^P:.se=~^_:.so=~^Y:up=~^L:
-H6|h1510|hazeltine 1510:\
- :al=\E^Z:am:bs:cd=\E^X:ce=\E^O:cl=\E^\:cm=\E^Q%r%.%.:co#80:\
- :dl=\E^S:do=\E^K:hz:li#24:nd=^P:.se=\E^_:.so=\E^Y:up=\E^L:
-H8|h1520|hazeltine 1520:\
- :al=~^Z:am:bs:cd=~^X:ce=~^O:cl=~\034:cm=~^Q%r%.%.\200:co#80:\
- :dl=~^S:do=~^K:hz:li#24:nd=^P:se=~^Y:so=~\037:up=~^L:ho=~^R:
-# Note: h2000 won't work because of a clash between upper case and ~'s.
-H7|h2000|hazeltine 2000:\
- :al=6~^z:am:bs:cl=6~^\:cm=~^q%r%.%.:co#74:\
- :dl=6~^s:ho=~^r:li#27:nc:pc=\177:
-# One of these should go in the misc category, IBM and ISC can't
-# both have I. I will wait to see who comes out with more terminals.
-I8|8001|ISC8001:al=\EU:am:bc=^Z:cl=3*^L:cm=^C%r%.%.:co#80:\
- :cd=\EQ:dm=\EQ:ed=\EF:\
- :dc=\177:dl=\EV:ei=\EF:im=\EQ:li#40:nd=1^Y:ta=8\t:\
- :up=^\:ho=1^H:pc=^@:
-It|intext|ISC modified owl 1200:\
- :al=5.5*\020:am:bc=\037:bs:cd=5.5*\026J:cl=132\014:\
- :cm=\017%+ %+ :co#80:dc=5.5*\022:dl=5.5*\021:\
- :ei=\026\074:im=\026\073:ip=5.5*:in:li#24:nd=\036:up=\034:\
- :ma=^K^P^R^L^L :kl=^H:kd=^J:kr=^L:ku=^K:
-I9|ibm|ibm3101|3101|i3101|IBM 3101-10:\
- :if=/usr/lib/tabset/3101:\
- :am:bs:cl=^[K:li#24:co#80:nd=^[C:up=^[A:cd=^[J:ce=^[I:\
- :kd=\EB:kl=\ED:kr=\EC:ku=\EA:ho=^[H:cm=\EY%+\40%+\40:
-L3|digilog|333|digilog 333:bs:co#80:ce=\030:ho=^n:li#16:nd=^i:up=^o:
-MA|ampex|d80|dialogue|dialogue80|ampex dialogue 80:\
- :am:bs:pt:if=/usr/lib/tabset/stdcrt:cl=\E*:cm=\E=%+ %+ :\
- :al=\EE:bt=\EI:ic=\EQ:im=:ei=:dl=\ER:dc=\EW:\
- :ce=\Et:cd=\Ey:so=\Ej:se=\Ek:li#24:co#80:nd=^L:up=^K:
-MB|aaadb|ann arbor ambassador 48/destructive backspace:\
- :is=\E[48;0;0;48p\E[H\E[J\E[>30h\E[1Q\E[m:bs@:\
- :vs=\E[>30l:ve=\E[>30h:tc=aaa:
-MC|compucolor|compucolorII:\
- :pt:am:cm=%r^C%.%.:bc=^Z:li#32:co#64:\
- :cl=^L:ho=^H:nd=^Y:up=^\:
-MD|d132|datagraphix|datagraphix 132a:\
- :co#80:li#30:cl=^l:ho=\Et:da:db:sf=\Ev:sr=\Ew:\
- :up=\Ek:nd=\El:vs=\ex:ve=\Em\En:\
- :al=\E3:ic=\E5:dc=\E6:in:ic=\E5:
-MS|soroc|Soroc 120:\
- :cd=\EY:ce=\ET:cl=2\E*:ma=^K^P^R^L^L :\
- :kl=^H:ku=^K:kr=^L:kd=^J:tc=adm3a:
-# Needs function keys added. Also can't use 60 line mode because it needs
-# too much nl delay - can fix for nl but not out of vi.
-# The cl delay is sufficient, but a smaller one could do.
-# This entry is merged from Mike O'Brien@Rand and Howard Katseff at
-# Bell Labs, and is untested.
-Mb|aaa|ambas|ambassador|ann arbor ambassador/48 lines:\
- :al=\E[L:am:bs:\
- :cd=\E[0J:ce=\E[0K:cl=400\E[;H\E[0J:cm=\E[%i%d;%dH:co#80:\
- :da:db:dc=\E[4h\E[1Q\E[P\E[4l\E[0Q:dc=\E[P:dl=\E[M:dm=\E[1Q:\
- :ed=\E[0Q:ei=\E[0Q:ho=\E[;H:ic=\E[@:if=/usr/lib/tabset/aa:im=\E[1Q:\
- :is=\E[48;0;0;48p\E[H\E[J\E[1Q\E[m:li#48:mi:\
- :nd=\E[C:nl=\ED:pt:sf=\E[S:sr=\E[T:se=\E[m:so=\E[7m:up=\E[A:
-Md|datapoint|dp3|dp3360|datapoint 3360:\
- :am:bs:cd^_:ce=^^:cl=^]^_:co#82:ho=^]:li#25:nd=^x:up=^z:
-Mg|dg|dg6053|data general 6053:\
- ca:am:bs:cm=^P%r%.%.:cl=^L:ho=^H:nd=^S\
- up=^W:ce=^K:co#80:li#24:
-Mi|cdi|cdi1203:am:bs:hc:os:co#80:cD#200:
-Mk|teletec|tec|Teletec Datascreen:\
- :am:bs:co#80:cl=^l:ho=^^:li#24:nd=^_:up=^k:
-# ^S is an arrow key! Boy is this guy in for a surprise on v7!
-Ml|sol:\
- :am:bs:cm=\E^1%.\E^2%.:cl=^K:ho=^N:co#64:li#16:nd=^S:up=^W:\
- :kl=^A:kr=^S:ku=^W:kd=^Z:ma=^A^H^S ^W^P^Z^N:
-Mo|omron|Omron 8025AG:\
- :al=\EL:am:bs:cd=\ER:co#80:ce=\EK:cl=\EJ:da:db:dc=\EP:dl=\EM:\
- :ho=\EH:li#24:nd=\EC:se=\E4:sf=\ES:so=\Ef:sr=\ET:up=\EA:ve=:vs=\EN:
-Mp|plasma|plasma panel:am:bs:cl=^L:co#85:ho=^^:li#45:nd=\030:up=\026:
-Ms|swtp|ct82|southwest technical products ct82:\
- :am:bs:bc=^d:al=^\^y:cd=^v:ce=^F:cl=^L:cm=%r^k%.%.:co#82:li#20:\
- :dl=^z:nd=^s:up=^a:so=^^^v:se=^^^F:dc=^\^h:ic=^\^x:ho=^p:\
- :ei=:sf=^n:sr=^o:ll=^c:im=:\
- :is=^\^r^^^s^^^d^]^w^i^s^^^]^^^o^]^w^r^i:
-Mt|terak|Terak emulating Datamedia 1520:tc=dm1520:
-My|mdl110|cybernex mdl-110:cm=^P%+ %+ :co#80:li#24:am:cl=70^X:bs:\
- :nd=^U:up=^Z:ho=^Y:ce=145^N@^V:cd=145^NA^W:al=65^NA^N^]:\
- :dl=40^NA^N^^:im=:\
- :ei=:ic=3.5^NA^]:dm:ed:dc=3.5^NA^^:so=^NF:se=^NG:ta=43\t:\
- :ma=^Z^P:cd=6^N@^V
-Mz|zen30|z30|zentec 30:\
- :mi:co#80:li#24:ma=^L ^R^L^K^P:ul:\
- :al=1.5*\EE:bs:ce=1.0*\ET:cm=\E=%+ %+ :cl=\E*:\
- :ho=^^:nd=^L:se=\EG0;so=\EG6:up=^K:im=\Eq:ei=\Er:\
- :am:dc=\EW:dl=1.5*\ER:cd=\EY:
-T3|33|tty33|tty|model 33 teletype:\
- :co#72:hc:os:
-T4|43|tty43|model 43 teletype:\
- :kb=^h:am:bs:hc:os:co#132:
-T7|37|tty37|model 37 teletype:\
- :bs:hc:hu=\E8:hd=\E9:up=\E7:os:
-# The Visual 200 beeps when you type a character in insert mode.
-# This is a horribly obnoxious misfeature, and some of the entries
-# below try to get around the problem by ignoring the feature or
-# turning it off when inputting a character. They are said not to
-# work well at 300 baud. (You could always cut the wire to the bell!)
-V2|vi200|v200|visual 200 with function keys:\
- :al=\EL:am:bs:cd=\Ey:ce=4*\Ex:cl=\Ev:\
- :cm=\EY%+ %+ :co#80:dc=4*\EO:dl=4*\EM:ho=\EH:\
- :im=:ei=:ic=\Ei \b\Ej:\
- :is=\E3\Eb\Ej\E\\\El\EG\Ed\Ek:\
- :k0=\EP:k1=\EQ:k2=\ER:k3=\E :k4=\E!:k5=\E":k6=\E#:\
- :k7=\E$:k8=\E%:k9=\E&:kl=\ED:kr=\EC:ku=\EA:kd=\EB:kh=\EH:\
- :li#24:nd=\EC:pt:sr=\EI:up=\EA:vs=\Ed:ve=\Ec:
-VR|vi200rvic|visual 200 reverse video using insert char:\
- :ei=\Ej:im=\Ei:ic@:tc=vi200rv:
-# The older Visuals didn't come with function keys. This entry uses
-# ks and ke so that the keypad keys can be used as function keys.
-# If your version of vi doesn't support function keys you may want
-# to use V2.
-Vf|vi200f|visual|visual 200 no function keys:\
- :al=\EL:am:bs:cd=\Ey:ce=4*\Ex:cl=\Ev:\
- :cm=\EY%+ %+ :co#80:dc=4*\EO:dl=4*\EM:ho=\EH:\
- :im=:ei=:ic=\Ei \b\Ej:\
- :is=\E3\Eb\Ej\E\\\El\EG\Ed\Ek:ks=\E=:ke=\E>:\
- :k0=\E?p:k1=\E?q:k2=\E?r:k3=\E?s:k4=\E?t:k5=\E?u:k6=\E?v:\
- :k7=\E?w:k8=\E?x:k9=\E?y:kl=\ED:kr=\EC:ku=\EA:kd=\EB:kh=\EH:\
- :li#24:nd=\EC:pt:sr=\EI:up=\EA:vs=\Ed:ve=\Ec:
-Vr|vi200rv|visual 200 reverse video:\
- :so=\E4:se=\E3:sr@:vs@:ve@:tc=vi200:
-Vt|vi200ic|visual 200 using insert char:\
- :ei=\Ej:im=\Ei:ic@:tc=vi200:
-Xa|tek4012|4012|tektronix 4012:\
- :is=\E^O:bs:cl=1000\E^L:co#75:ns:li#35:os:
-Xb|tek4013|4013|tektronix 4013:\
- :as=\E^N:ae=\E^O:tc=4012:
-Xc|tek4014|4014|tektronix 4014:\
- :is=\E^O\E9:co#81:li#38:dF#1000:tc=tek4012:
-Xd|tek4015|4015|tektronix 4015:\
- :as=\E^N:ae=\E^O:tc=4014:
-Xe|tek4014sm|4014sm|tektronix 4014 in small font:\
- :is=\E^O\E\072:co#121:li#58:tc=tek4014:
-Xf|tek4015sm|4015sm|tektronix 4015 in small font:\
- :as=\E^N:ae=\E^O:tc=4014sm:
-# I think the 1000UP is supposed to be so expensive it never happens.
-X4|tek4023|4023|tektronix 4023:\
- :so=^_P:se=^_@:cm=\034%r%+ %+ :nd=\t:bs:cl=4\E^L:co#80:li#24:am:\
- :up=1000UP:
-# Can't use cursor motion because it's memory relative, and because
-# it only works in the workspace, not the monitor. Same for home.
-# Likewise, standout only works in the workspace.
-X5|tek|4025|4027|4024|tek4025|tek4027|tek4024|4025cu|4027cu|tektronix 4024/4025/4027:\
- :is=\41com 31\r\n^_sto 9,17,25,33,41,49,57,65,73\r:\
- :ks=^_lea p4 /h/\r^_lea p8 /k/\r^_lea p6 / /\r^_lea p2 /j/\r^_lea f5 /H/\r:\
- :ke=^_lea p2\r^_lea p4\r^_lea p6\r^_lea p8\r^_lea f5\r:\
- :am:bs:da:db:pt:li#34:co#80:cl=^_era\r\n\n:up=^K:nd=^_rig\r:\
- :al=145^_up\r^_ili\r:dl=^_dli\r:\
- :dc=^_dch\r:im=^_ich\r:ei=^F\n^K:nl=^F\n:\
- :ce=^_dch 80\r:cd=^_dli 50\r:CC=^_:
-X7|4025-17|4027-17|tek 4025 17 line window:li#17:tc=4025:
-X8|4025-17ws|4027-17ws|tek 4025 17 line window in workspace:\
- :is=\41com 31\r\n^_sto 9,17,25,33,41,49,57,65,73\r^_wor 17\r^_mon 17\r:\
- :ti=^_wor h\r:te=^_mon h\r:so=^_att e\r:se=^_att s\r:tc=4025-17:
-Xe|4025ex|4027ex|tek 4025 w/!:ti=\41com 31\r:te=^_com 33\r:\
- :is=^_com 33\r\n\41sto 9,17,25,33,41,49,57,65,73\r:tc=4025:
-# Regent: lowest common denominator, works on all regents.
-a0|regent|adds regent series:\
- :am:bs:cl=^L:cm=^K%+ ^P%B%.:co#80:ho=^A:li#24:ll=^A^Z:nd=^F:up=^Z:
-# Regent 100 has a bug where if computer sends escape when user is holding
-# down shift key it gets confused, so we avoid escape.
-a1|regent100|adds regent 100:\
- :cm=^K%+ ^P%B%.:k1=^B1\r:k2=^B2\r:k3=^B3\r:k4=^B4\r:\
- :k5=^B5\r:k6=^B6\r:k7=^B7\r:k8=^B8\r:\
- :kh=^A:kl=^U:kr=^F:ku=^Z:kd=^J:tc=regent:
-# Regent 20, untested
-a2|regent20|adds regent 20:\
- :cd=\Ek:ce=\EK:cm=\EY%+ %+ :tc=regent:
-a3|regent25|adds regent 25:\
- :k0=^B0\r:k1=^B1\r:k2=^B2\r:k3=^B3\r:k4=^B4\r:\
- :k5=^B5\r:k6=^B6\r:k7=^B7\r:k8=^B8\r:k9=^B9\r:\
- :kh=^A:kl=^U:kr=^F:ku=^Z:kd=^J:tc=regent20:
-# Regent 40: untested
-a4|regent40|adds regent 40:\
- :al=\EM:dl=\El:is=\EB:se=\E0@:so=\EOP:ue=\EO@:us=\E0`:vb=\ED\Ed:\
- :tc=regent25:
-# If you have standout problem with regent 200, try so=\ER\EOP:se=\E0@\EV:
-a6|regent60|regent200|adds Regent 60:\
- :dc=\EE:ei=\EF:im=\EF:is=\EV\EB:ko=dc,im,ei:tc=regent40:
-a7|regent60na|regent 60 w/no arrow keys:\
- kl@:kr@:ku@:kd@:tc=regent60:
-# Note: if return acts weird on a980, check internal switch #2
-# on the top chip on the CONTROL pc board.
-ac|a980|adds consul 980:\
- :al=13\E^N:am:bs:cl=^L\200^K@:cm=^K%+@\E^E%2:co#80:dl=13\E^O:\
- :k0=\E0:k1=\E1:k2=\E2:k3=\E3:k4=\E4:k5=\E5:k6=\E6:k7=\E7:k8=\E8:k9=\E9:\
- :li#24:nd=\E^E01:so=^Y^^^N:se=^O:up=9:
-b2|sb2|sb3|fixed superbee:xb@:tc=superbee:
-bh|bh3m|beehiveIIIm:if=/usr/lib/tabset/beehive:\
- :al=160^S:am:bs:cd=^R:ce=^P:cl=^E^R:co#80:dl=300^Q:ho=^E:li#20:ll=^E^K:\
- :nd=^L:pt:se= ^_:so=^] :up=^K:
-# This loses on lines > 80 chars long, use at your own risk
-bi|superbeeic|super bee with insert char:\
- :ic=:im=\EQ:ei=\ER:tc=superbee:
-bm|microb|microbee|micro bee series:\
- :am:bs:cd=\EJ:ce=\EK:cl=\EE:co#80:cm=\EF%+ %+ :\
- :k1=\Ep:k2=\Eq:k3=\Er:k4=\Es:k5=\Et:k6=\Eu:k7=\Ev:k8=\Ew:k9=\Ex:\
- :kd=\EB:kh=\EH:kl=\ED:kr=\EC:ku=\EA:\
- :li#24:nd=\EC:pt:se=\Ed@ :so= \EdP:ue=\Ed@:up=\EA:us=\Ed`:
-# Superbee - f1=escape, f2=^C.
-# Note: there are at least 3 kinds of superbees in the world. The sb1
-# holds onto escapes and botches ^C's. The sb2 is the best of the 3.
-# The sb3 puts garbage on the bottom of the screen when you scroll with
-# the switch in the back set to CRLF instead of AEP. This description
-# is tested on the sb2 but should work on all with either switch setting.
-# The f1/f2 business is for the sb1 and the :xb: can be taken out for
-# the other two if you want to try to hit that tiny escape key.
-# This description is tricky: being able to use cm depends on there being
-# 2048 bytes of memory and the hairy nl string.
-bs|sb1|superbee|superb|beehive super bee:if=/usr/lib/tabset/stdcrt:is=\EE:\
- :am:bs:cd=3\EJ:ce=3\EK:cl=3\EH\EJ:co#80:cm=\EF%r%3%3:cr=1000\r:\
- :dC#10:da:db:xb:dc=3\EP:dl=100\EM:so=\E_1:se=\E_0:\
- :li#25:nl=\n\200\200\200\n\200\200\200\EA\EK\200\200\200\ET\ET:\
- :nd=\EC:pt:up=\EA:ho=\EH:ve=\n:\
- :k1=\Ep:k2=\Eq:k3=\Er:k4=\Es:k5=\Et:k6=\Eu:k7=\Ev:k8=\Ew:\
- :kd=\EB:kh=\EH:kl=\ED:kr=\EC:ku=\EA:
-d2|gt42|dec gt42:\
- :bs:co#72:ns:li#40:os:
-d4|gt40|dec gt40:\
- :bs:co#72:ns:li#30:os:
-d5|vt50|dec vt50:\
- :bs:cd=\EJ:ce=\EK:cl=\EH\EJ:co#80:li#12:nd=\EC:pt:up=\EA:
-dI|dw1|decwriter I:\
- :bs:co#72:hc:os:
-dh|vt50h|dec vt50h:\
- :bs:cd=\EJ:ce=\EK:cl=\EH\EJ:cm=\EY%+ %+ :co#80:li#12:nd=\EC:\
- :pt:sr=\EI:up=\EA:
-#
-# ds|vt100s|vt-100s|pt100s|pt-100s|dec vt100 132 cols 14 lines:\
-# :li#14:tc=vt100w:
-#
-dt|vt100w|vt-100w|pt100w|pt-100w|dec vt100 132 cols:\
- :co#128:li#24:is=\E>\E[?3h\E[?4l\E[?5l\E[?7h\E[?8h:tc=vt100:
-dv|vt52|dec vt52:\
- :bs:cd=\EJ:ce=\EK:cl=\EH\EJ:cm=\EY%+ %+ :co#80:li#24:nd=\EC:\
- :pt:sr=\EI:up=\EA:ku=\EA:kd=\EB:kr=\EC:kl=\ED:
-dw|dw2|dw3|dw4|decwriter II:\
- :kb=^h:bs:co#132:hc:os:
-e1|ep48|ep4080|execuport 4080:am:bs:os:co#80:hu=\036:hd=\034:
-e2|ep40|ep4000|execuport 4000:am:bs:os:co#136:hu=\036:hd=\034:
-g2|1200|tn1200|terminet 1200:\
- :co#120:hc:os:
-g3|300|tn300|terminet 300:\
- :co#120:hc:os:
-# Note: no "ho" on HP's since that homes to top of memory, not screen.
-# Due to severe braindamage, the only way to get the arrow keys to
-# transmit anything at all is to turn on the function key labels
-# (f1-f8) with ks, and even then the poor user has to hold down shift!
-# The default 2621 turns off the labels except when it has to to enable
-# the function keys. If your installation prefers labels on all the time,
-# or off all the time (at the "expense" of the function keys) move the
-# 2621nl or 2621wl labels to the front using reorder.
-# 2621k45: untested
-h2|2621|hp2621|hp2621a|hp2621p|2621|2621a|2621p|hp 2621:\
- :is=\E&j@\r\E3\r:bt=\Ei:cm=\E&a%r%dc%dY:dc=2\EP:ip=2:\
- :kh=\Ep\r:ku=\Et\r:kl=\Eu\r:kr=\Ev\r:kd=\Ew\r:\
- :kn#8:k1=\Ep\r:k2=\Eq\r:k3=\Er\r:k4=\Es\r:k5=\Et\r:k6=\Eu\r:k7=\Ev\r:\
- :k8=\Ew\r:ks=\E&jB:ke=\E&j@:ta=2^I:tc=hp:
-h3|2621k45|hp2621k45|k45|hp 2621 with 45 keyboard:\
- :kb=^H:ku=\EA:kd=\EB:kl=\ED:kr=\EC:kh=\Eh:ks=\E&s1A:ke=\E&s0A:tc=2621:
-h4|hp|hp2645|2645|hp 264x series:\
- :if=/usr/lib/tabset/stdcrt:\
- :al=\EL:am:bs:cd=\EJ:ce=\EK:ch=\E&a%dC:cl=\EH\EJ:cm=6\E&a%r%dc%dY:\
- :co#80:cv=\E&a%dY:da:db:dc=\EP:dl=\EM:ei=\ER:im=\EQ:\
- :kb=^H:ku=\EA:kd=\EB:kl=\ED:kr=\EC:kh=\Eh:ks=\E&s1A:ke=\E&s0A:\
- :li#24:mi:ml=\El:mu=\Em:nd=\EC:pt:se=\E&d@:so=\E&dJ:\
- :us=\E&dD:ue=\E&d@:up=\EA:xs:
-h6|hp2626|hp2626a|hp2626p|2626|2626a|2626p|hp 2626:\
- :is=\E&j@\r\E3\r:if=/usr/lib/tabset/stdcrt:\
- :al=\EL:am:bs:bt=\Ei:cd=\EJ:ce=\EK:cl=\EH\EJ:\
- :cm=\E&a%r%dc%dY:co#80:da:db:dc=2\EP:dl=\EM:ei=\ER:\
- :im=\EQ:ip=2:li#24:mi:nd=\EC:pt:se=\E&d@:so=\E&dB:up=\EA:\
- :kh=\Eh:ku=\EA:kl=\ED:kr=\EC:kd=\EB:\
- :ma=j^Jk^P^K^Pl :sf=\ES:\
- :ta=2^I:xs:
-# cD a pain - only screw up at 9600 baud.
-h8|hp2648|hp2648a|2648a|2648|HP 2648a graphics terminal:\
- :cl=50\EH\EJ:cm=20\E&a%r%dc%dY:dc=7\EP:ip#5:is=130\Eg:tc=2645:
-# 2640a doesn't have the Y cursor addressing feature, and C is memory relative
-# instead of screen relative, as we need .
-ha|2640|hp2640a|2640a|hp 2640a:cm@:ks@:ke@:tc=2645:
-hb|2640b|hp2640b|2644a|hp2644a|hp 264x series:ks@:ke@:tc=2645:
-# 2621 using all 48 lines of memory, only 24 visible at any time. Untested.
-hb|big2621|48 line 2621:li#48:ho=\EH:cm=\E&a%r%dc%dR:tc=2621:
-hn|2621nl|hp2621nl|2621|hp 2621 with no labels:ks@:ke@:kh@:ku@:kl@:kr@:kd@:tc=hp2621:
-hw|2621wl|hp2621wl|2621|hp 2621 with labels:is=\E&jA\r\E3\r:ke=\E&jA:tc=hp2621:
-# Infoton is now called General Terminal Corp. or some such thing.
-# gt100 sounds like something DEC would come out with. Lets hope they don't.
-i1|i100|gt100|gt100a|General Terminal 100A (formerly Infoton 100):\
- :cl=^L:cd=\EJ:ce=\EK:li#24:co#80:\
- :al=\EL:dl=\EM:up=\EA:nd=\EC:ho=\EH:cm=\Ef%r%+ %+ :vb=\Eb\Ea:am:bs:\
- :so=\Eb:se=\Ea:
-i4|i400|400|infoton 400:\
- :if=/usr/lib/tabset/infoton_tabs:\
- :al=\E[L:am:bs:ce=\E[N:cl=\E[2J:cm=%i\E[%3;%3H:co#80:dl=\E[M:li#25:\
- :nd=\E[C:up=\E[A:im=\E[4h\E[2Q:ei=\E[4l\E[0Q:\
- :dc=\E[4h\E[2Q\E[P\E[4l\E[0Q:
-ia|addrinfo:\
- :li#24:co#80:cl=^L:ho=^H:nd=^Y:cd=^K:\
- :up=^\:am:bc=^Z:cm=\037%+\377%+\377:ll=^H^\:
-ik|infotonKAS:\
- :am:bc=^Z:cd=^K:cl=^L:co#80:li#24:nd=^Y:up=^\:ll=^H^\:
-l1|adm31|31|lsi adm31:is=\Eu\E0:\
- :al=\EE:am:bs:ce=\ET:cm=\E=%+ %+ :cl=\E*:co#80:dc=\EW:dl=\ER:\
- :ei=\Er:ho=^^:im=\Eq:li#24:mi:nd=^L:se=\EG0:so=\EG4:up=^K:\
- :kl=^H:kd=^J:ku=^K:kr=^L:ma=^K^P^L :
-l2|adm2|lsi adm2:\
- :al=\EE:am:bs:cd=\EY:ce=\ET:cl=\E;:cm=\E=%+ %+ :co#80:dc=\EW:dl=\ER:\
- :ei=:ho=^^:ic=\EQ:im=:kd=^J:kh=^^:kl=^H:kr=^L:ku=^K:li#24:nd=^L:up=^K:
-l3|adm3|3|lsi adm3:\
- :am:bs:cl=^Z:li#24:ma=^K^P:co#80:
-l4|adm42|42|lsi adm42:vs=\EC\E3 \E3(:\
- :al=270\EE:am:bs:cd=\EY:ce=\ET:cl=\E;:cm=\E=%+ %+ :co#80:\
- :dc=\EW:dl=\ER:ei=\Er:im=\Eq:ip=6*:li#24:\
- :bt=\EI:nd=^L:se=\EG0:so=\EG4:ta=\t:up=^k:\
- :ma=^K^P:pc=\177:
-la|adm3a|3a|lsi adm3a:\
- :am:bs:cm=\E=%+ %+ :cl=1^Z:co#80:ho=^^:li#24:ma=^K^P:nd=^L:up=^K:
-lb|adm3a+|3a+:kl=^H:kd=^J:ku=^K:kr=^L:tc=adm3a:
-# These mime1 entries refer to the Microterm Mime I or Mime II.
-# The default mime is assumed to be in enhanced act iv mode.
-m3|mime3a|mime1 emulating 3a:\
- :am@:ma=^X ^K^J^Z^P:ku=^Z:kd=^K:kl=^H:kr=^X:tc=adm3a:
-m4|microterm|act4|microterm act iv:\
- :am:bs:cd=^_:ce=^^:cl=^L:cm=^T%.%.:co#80:li#24:nd=^X:up=^Z:ho=^]:
-# The padding on sr and ta for act5 and mime is a guess and not final.
-m5|microterm5|act5|microterm act v:\
- :uc=\EA:pt:ta=2^I:sr=3\EH:ku=^Z:kd=^K:kl=^H:kr=^X:ma=^Z^P^Xl^Kj:tc=act4:
-# act5s is not tested and said not to work.
-mS|act5s|skinny act5:ti=\EP:te=\EQ:li#48:co#39:tc=act5:
-# Mimes using brightness for standout. Half bright is really dim unless
-# you turn up the brightness so far that lines show up on the screen.
-# uc is disabled to get around a curses bug, and should be put back in someday.
-mf|mimefb|full bright mime1:so=^Y:se=^S:uc@:is=^S\E:tc=mime:
-mh|mimehb|half bright mime1:so=^S:se=^Y:uc@:is=^Y\E:tc=mime:
-mm|mime|mime1|mime2|mimei|mimeii|microterm mime1:\
- :al=80^A:am:bs:cd=^_:ce=^^:cl=\035^C:cm=^T%+^X%> 0%+P:co#80:\
- :dl=80^W:ta=2^I:li#24:nd=^X:pt:uc=^U:up=^z:ho=\035:do=^K:is=^S\E:\
- :ma=^X ^K^J^Z^P:ku=^Z:kd=^K:kl=^H:kr=^X:sr=3^R:
-# These termcaps (for mime 2a) put the terminal in low intensity mode
-# since high intensity mode is so obnoxious.
-ms|mime2as|microterm mime2a (emulating an enhanced soroc iq120):\
- :al=20*^A:am:bs:cd=20*\EJ:ce=\EK:cl=\EL:cm=\E=%+ %+ :co#80:dc=\ED:\
- :dl=20*^W:kl=^H:kr=^L:ku=^K:kd=^J:ho=^^:is=\E):sr=\EI\
- :im=\EE:ei=^Z:ip=2:li#24:nd=^L:so=\E\072:se=\E;:up=\EI:\
- :us=\E6:ue=\E7:
-# This is the preferred mode (but ^X can't be used as a kill character)
-mv|mime2a|mime2av|microterm mime2a (emulating an enhanced vt52):\
- :al=20*^A:bs:cd=20*\EQ:co#80:ce=\EP:cl=\EL:cm=\EY%+ %+ :is=^Y\
- :dc=^N:dl=20*^W:ip=2:ei=^Z:ho=\EH:im=^O:kd=\EB:kl=\ED:kr=\EC:ku=\EA:\
- :li#24:nd=\EC:pt:se=\E9:so=\E8:up=\EA:sr=\EA:us=\E4:ue=\E5:
-mx|mime3ax|mime1 emulating enhanced 3a:\
- :al=80^A:dl=80^W:pt:ce=^X:cd=^_:tc=mime3a:
-n2|spin|nec spinwriter 5525|spinwriter:\
- :bs:co#136:hc:hd=\EU:hu=\ED:os:pt:so=\EA:se=\EB:\
- :if=/usr/lib/tabset/spinwriter:
-pf|fox|perkin elmer 1100:if=/usr/lib/tabset/stdcrt:\
- :am:bs:cd=5.5*\EJ:ce=\EI:cl=132\EH\EJ:co#80:ho=\EH:li#24:\
- :ll=\EH\EA:nd=\EC:cm=\EX%+ \EY%+ :up=\EA:vb=^P^B^P^C:
-po|owl|perkin elmer 1200:if=/usr/lib/tabset/stdcrt:\
- :al=5.5*\EL:am:bs:cd=5.5*\EJ:ce=5.5\EI:cl=132\EH\EJ:ho=\EH:ll=\EH\EA:\
- :cm=\EX%+ \EY%+ :co#80:dc=5.5*\EO:dl=5.5*\EM:ei=:ic=\EN:im=:ip=5.5*:\
- :kb=^h:in:li#24:nd=\EC:up=\EA:se?=\E!\200:so?=\E!^H:vb=^P^B^P^C:\
- :k1=\ERA:k2=\ERB:k3=\ERC:k4=\ERD:k5=\ERE:k6=\ERF:\
- :k7=\ERG:k8=\ERH:k9=\ERI:k0=\ERJ:
-#
-# qB|bc|bill croft homebrew:\
-# :am:bs:cm=\E=%+ %+ :cl=^Z:co#96:ho=^^:li#72:\
-# :nd=^L:up=^K:vb=:
-#
-#NOTE: bg can scroll, it just would rather not (ns) - rwells 3/13/81.
-qB|bg|bg2.0|bgn|BBN BitGraph Terminal (no init):\
- :al=2*\E[L:bs:cd=150\E[J:ce=2\E[K:cl=150\E[H\E[J:cm=%i\E[%d;%dH:\
- :co#85:cs=\E[%i%d;%dr:dl=2*\E[M:\
- :k1=\EOP:k2=\EOQ:k3=\EOR:k4=\EOS:\
- :kd=\E[B:ke=\E>:kl=\E[D:kr=\E[C:ks=\E=:ku=\E[A:\
- :l1=PF1:l2=PF2:l3=PF3:l4=PF4:\
- :li#64:nd=\E[C:ns:pt:se=\E[0m:so=\E[7m:up=\E[A:\
- :sc=\E7:rc=\E8:xn:
-qB|bg|bg2.0nv|bgnv:BBN BitGraph Terminal (normal video):\
- :is=\E>\E[?5l\E[?7h:\
- :if=/usr/lib/tabset/vt100:tc=bgn:
-qB|bg|bg2.0rv|bgrv:BBN BitGraph Terminal (reverse video):\
- :is=\E>\E[?5h\E[?7h:\
- :if=/usr/lib/tabset/vt100:tc=bgn:
-qB|bg|bg1.25|BBN BitGraph terminal:\
- :al=2*\E[L:bs:cd=150\E[J:ce=2\E[K:cl=150\E[H\E[J:cm=%i\E[%d;%dH:\
- :co#85:dl=2*\E[M:\
- :is=\E<:\
- :k1=\EOP:k2=\EOQ:k3=\EOR:k4=\EOS:\
- :kd=\E[B:ke=\E>:kl=\E[D:kr=\E[C:ks=\E=:ku=\E[A:\
- :l1=PF1:l2=PF2:l3=PF3:l4=PF4:\
- :li#64:nd=\E[C:ns:pt:se=\E[0m:so=\E[7m:up=\E[A:
-qB|bg|bg1.25nv|:BBN BitGraph Terminal (normal video):\
- :is=\E<\E>\E[?5l\E[?7h:tc=bg1.25:
-qB|bg|bg1.25rv|:BBN BitGraph Terminal (reverse video):\
- :is=\E<\E>\E[?5h\E[?7h:tc=bg1.25:
-qN|nucterm|rayterm|NUC homebrew:\
- :am:bs:cl=1^L:li#24:co#80:nd=^C:up=^N:ho=^B:ll=^K:ce=^A:cd=^E:
-qb|ex3000:\
- :li#24:co#80:ho=^Q:
-qc|carlock|klc:\
- :al=^E:am:bs:ce=^U:cl=100^Z:cm=\E=%+ %+ :co#80:dc=\177:dl=^D:dm=:\
- :ed=:ei=^T:ho=^^:im=^T:li#24:nd=^L:se=^V:so=^V:up=^K:vb=\EV\EV:
-qe|exidy|exidy2500|exidy sorcerer as dm2500:\
- :al=^P^J^X:am:bs:ce=^W:cl=^^:cm=^L%r%n%.%.:co#64:\
- :dc=\b:dl=^P^Z^X:dm=^P:ed=^X:ei=^X:ho=^B:ic=^\:\
- :im=^P:li#30:nd=^\:pt:so=^N:se=^X:up=^Z:
-qn|netx|netronics:\
- :bs:cd=2000^F^E:ce=1600^E:cl=466^L:cm=\E=%+@%+@:co#64:ho=^D:\
- :li#16:ma=j^Jk^Pl :nd=\E+@A:pc=\200:sr=\E=@@^K:up=^K:
-# This came from the comp ctr who got it from some user. Smart indeed!
-qs|sexidy|exidy smart:\
- :li#24:co#64:cl=^l:ho=^q:nd=^s:up=^w:bs:bc=^a:ma=^x^J:kd=^S:
-qu|ubell|ubellchar:if=/usr/staff/michael/term/startup:\
- :am:bs:pt:ce=\Ed:cl=^Z:cm=\E=%+ %+ :co#80:li#24:nd=^L:up=^K:\
- :ma=j^Jk^P^K^Pl :ho=^^:
-qw|ttyWilliams:\
- :co#80:li#12:bc=^Y:do=^K:up=^Z:cl=^^:ce=^_:am:ho=^]:nd=^X:
-qx|xitex|xitex sct-100:\
- :bs:cd=2000^F^E:ce=1600^E:cl=400^L:cm=\E=%+@%+@:co#64:ho=^D:\
- :li#16:ma=j^Jk^Pl :nd=\E+@A:pc=\200:sr=\E=@@^K:up=^K:
-t3|ti|ti700|ti733|735|ti735|ti silent 700:\
- :bs:co#80:hc:os:dC#162:
-t4|ti745|745|743|ti silent 745:\
- :bs:co#80:hc:os:
-# There are some tvi's that require incredible amounts of padding and
-# some that don't. I'm assuming 912 and 920 are the old slow ones,
-# and 912b, 912c, 920b, 920c are the new ones that don't need padding.
-v1|tvi912|912|920|tvi920|old televideo:if=/usr/lib/tabset/stdcrt:\
- :al=33*\EE:am:bs:ce=\ET:cm=\E=%+ %+ :cl=^Z:co#80:dc=\EW:dl=33*\ER:ei=:\
- :kb=^h:ku=^K:kd=^J:kl=^H:kr=^L:k0=^A@\r:k1=^AA\r:k2=^AB\r:k3=^AC\r:\
- :k4=^AD\r:k5=^AE\r:k6=^AF\r:k7=^AG\r:k8=^AH\r:k9=^AI\r:\
- :ho=^^:im=:ic=\EQ:li#24:nd=^L:pt:se=\Ek:so=\Ej:up=^K:us=\El:ue=\Em:\
- :ma=^K^P^L :sg=1:ug=1:
-v2|912b|912c|920b|920c|tvi|new televideo:\
- :al=5*\EE:dl=5*\ER:tc=912:
-# Note two things called "teleray". Reorder should move the common one
-# to the front if you have either. A dumb teleray with the cursor stuck
-# on the bottom and no obvious model number is probably a 3700.
-y1|t3700|teleray|dumb teleray 3700:\
- :bs:cl=^L:co#80:li#24:
-y3|t3800|teleray 3800 series: \
- :bs:cd=\EJ:ce=\EK:cl=^L:cm=\EY%+ %+ :co#80: \
- :do=\n:ho=\EH:li#24:ll=\EY7 :nd=\EC:pt:up=^K:
-y6|t1061|t10|teleray|teleray 1061:if=/usr/lib/tabset/teleray:\
- :al=2*\EL:am:bs:cd=1\EJ:ce=\EK:cl=1^L:cm=\EY%+ %+ :co#80:\
- :dc=\EQ:dl=2*\EM:ei=:ho=\EH:ic=\EP:im=:ip=0.4*:\
- :k1=^Z1:k2=^Z2:k3=^Z3:k4=^Z4:k5=^Z5:k6=^Z6:k7=^Z7:k8=^Z8:\
- :li#24:nd=\EC:pt:se=\ER@:so= \ERD:\
- :is=\Ee\EU01^Z1\EV\EU02^Z2\EV\EU03^Z3\EV\EU04^Z4\EV\EU05^Z5\EV\EU06^Z6\EV\EU07^Z7\EV\EU08^Z8\EV\Ef:\
- :up=\EA:us=\ERH:ue=\ER@:xs:xt:sg=2:ug=1:
-yf|t1061f|teleray 1061 with fast PROMs:\
- al=\EL:ip@:dl=\EM:tc=t1061:
-rv|vidtx|Radio Shack VIDEOTEX:\
- :cd=\EJ:ce=\EK:cl=\EH\EJ:cm=\EY%+ %+ :co#32:li#16:nd=\EC:up=\EA:
-ae|apple2e|Apple ][e with 80 column card:\
- :am:bs:cd=^K:ce=^]:cl=^L:cm=^^%r%+ %.:co#80:ho=^Y:\
- :ku=^_:kd=^J:kl=^H:kr=^\:kh=^Y:\
- :li#24:nd=^\:up=^_:xn:ma=^\ ^_^P^YH:pt:
-#
-# ----
-# Convention: First entry is two chars, first char is manufacturer,
-# second char is canonical abbreviation for model or mode.
-# Second entry is canonical abbreviation.
-# Third entry is the one the editor will print with "set" command.
-# Last entry is verbose description.
-# Others are mnemonic synonyms for the terminal.
-#
-# If you absolutely MUST check for a specific terminal (this is discouraged)
-# check for the 2nd entry (the canonical form) since all other codes are
-# subject to change. The two letter codes are there for version 6 and are
-# EXTREMELY subject to change, or even to go away if version 6 becomes for
-# all practical purposes obsolete.
-#
-# Special manufacturer codes:
-# M: Misc. (with only a few terminals)
-# q: Homemade
-# s: special (dialup, etc.)
-#
-# This file is to be installed with an editor script that moves the most
-# common terminals to the front of the file. If the source is not available,
-# it can be constructed by sorting
-# the above entries by the 2 char initial code.
+++ /dev/null
-/* env - manipulate environment and execute a program in that environment
- Copyright (C) 1986, 1994 Free Software Foundation, Inc.
-
- 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 2, 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. */
-
-/* Mly 861126 */
-
-/* If first argument is "-", then a new environment is constructed
- from scratch; otherwise the environment is inherited from the parent
- process, except as modified by other options.
-
- So, "env - foo" will invoke the "foo" program in a null environment,
- whereas "env foo" would invoke "foo" in the same environment as that
- passed to "env" itself.
-
- Subsequent arguments are interpreted as follows:
-
- * "variable=value" (i.e., an arg containing a "=" character)
- means to set the specified environment variable to that value.
- `value' may be of zero length ("variable="). Note that setting
- a variable to a zero-length value is different from unsetting it.
-
- * "-u variable" or "-unset variable"
- means to unset that variable.
- If that variable isn't set, does nothing.
-
- * "-s variable value" or "-set variable value"
- same as "variable=value".
-
- * "-" or "--"
- are used to indicate that the following argument is the program
- to invoke. This is only necessary when the program's name
- begins with "-" or contains a "=".
-
- * anything else
- The first remaining argument specifies a program to invoke
- (it is searched for according to the specification of the PATH
- environment variable) and any arguments following that are
- passed as arguments to that program.
-
- If no program-name is specified following the environment
- specifications, the resulting environment is printed.
- This is like specifying a program-name of "printenv".
-
- Examples:
- If the environment passed to "env" is
- { USER=rms EDITOR=emacs PATH=.:/gnubin:/hacks }
-
- * "env DISPLAY=gnu:0 nemacs"
- calls "nemacs" in the environment
- { USER=rms EDITOR=emacs PATH=.:/gnubin:/hacks DISPLAY=gnu:0 }
-
- * "env - USER=foo /hacks/hack bar baz"
- calls the "hack" program on arguments "bar" and "baz"
- in an environment in which the only variable is "USER".
- Note that the "-" option clears out the PATH variable,
- so one should be careful to specify in which directory
- to find the program to call.
-
- * "env -u EDITOR USER=foo PATH=/energy -- e=mc2 bar baz"
- The program "/energy/e=mc2" is called with environment
- { USER=foo PATH=/energy }
-*/
-
-#ifdef EMACS
-#define NO_SHORTNAMES
-#include "../src/config.h"
-#endif /* EMACS */
-
-#include <stdio.h>
-
-extern int execvp ();
-
-char *xmalloc (), *xrealloc ();
-char *concat ();
-
-extern char **environ;
-
-char **nenv;
-int nenv_size;
-
-char *progname;
-void setenv ();
-void fatal ();
-char *myindex ();
-
-extern char *strerror ();
-
-
-main (argc, argv, envp)
- register int argc;
- register char **argv;
- char **envp;
-{
- register char *tem;
-
- progname = argv[0];
- argc--;
- argv++;
-
- nenv_size = 100;
- nenv = (char **) xmalloc (nenv_size * sizeof (char *));
- *nenv = (char *) 0;
-
- /* "-" flag means to not inherit parent's environment */
- if (argc && !strcmp (*argv, "-"))
- {
- argc--;
- argv++;
- }
- else
- /* Else pass on existing env vars. */
- for (; *envp; envp++)
- {
- tem = myindex (*envp, '=');
- if (tem)
- {
- *tem = '\000';
- setenv (*envp, tem + 1);
- }
- }
-
- while (argc > 0)
- {
- tem = myindex (*argv, '=');
- if (tem)
- /* If arg contains a "=" it specifies to set a variable */
- {
- *tem = '\000';
- setenv (*argv, tem + 1);
- argc--;
- argv++;
- continue;
- }
-
- if (**argv != '-')
- /* Remaining args are program name and args to pass it */
- break;
-
- if (argc < 2)
- fatal ("no argument for `%s' option", *argv);
- if (!strcmp (*argv, "-u")
- || !strcmp (*argv, "-unset"))
- /* Unset a variable */
- {
- argc--;
- argv++;
- setenv (*argv, (char *) 0);
- argc--;
- argv++;
- }
- else if (!strcmp (*argv, "-s") ||
- !strcmp (*argv, "-set"))
- /* Set a variable */
- {
- argc--;
- argv++;
- tem = *argv;
- if (argc < 2)
- fatal ("no value specified for variable \"%s\"", tem);
- argc--;
- argv++;
- setenv (tem, *argv);
- argc--;
- argv++;
- }
- else if (!strcmp (*argv, "-") || !strcmp (*argv, "--"))
- {
- argc--;
- argv++;
- break;
- }
- else
- {
- fatal ("unrecognized option `%s'", *argv);
- }
- }
-
- /* If no program specified print the environment and exit */
- if (argc <= 0)
- {
- while (*nenv)
- printf ("%s\n", *nenv++);
- exit (0);
- }
- else
- {
- extern int errno;
- extern char *strerror ();
-
- environ = nenv;
- (void) execvp (*argv, argv);
-
- fprintf (stderr, "%s: cannot execute `%s': %s\n",
- progname, *argv, strerror (errno));
- exit (errno != 0 ? errno : 1);
- }
-}
-
-void
-setenv (var, val)
- register char *var, *val;
-{
- register char **e;
- int len = strlen (var);
-
- {
- register char *tem = myindex (var, '=');
- if (tem)
- fatal ("environment variable names can not contain `=': %s", var);
- else if (*var == '\000')
- fatal ("zero-length environment variable name specified");
- }
-
- for (e = nenv; *e; e++)
- if (!strncmp (var, *e, len) && (*e)[len] == '=')
- {
- if (val)
- goto set;
- else
- do
- {
- *e = *(e + 1);
- } while (*e++);
- return;
- }
-
- if (!val)
- return; /* Nothing to unset */
-
- len = e - nenv;
- if (len + 1 >= nenv_size)
- {
- nenv_size += 100;
- nenv = (char **) xrealloc (nenv, nenv_size * sizeof (char *));
- e = nenv + len;
- }
-
-set:
- val = concat (var, "=", val);
- if (*e)
- free (*e);
- else
- *(e + 1) = (char *) 0;
- *e = val;
- return;
-}
-
-void
-fatal (msg, arg1, arg2)
- char *msg, *arg1, *arg2;
-{
- fprintf (stderr, "%s: ", progname);
- fprintf (stderr, msg, arg1, arg2);
- putc ('\n', stderr);
- exit (1);
-}
-\f
-
-extern char *malloc (), *realloc ();
-
-void
-memory_fatal ()
-{
- fatal ("virtual memory exhausted");
-}
-
-char *
-xmalloc (size)
- int size;
-{
- register char *value;
- value = (char *) malloc (size);
- if (!value)
- memory_fatal ();
- return (value);
-}
-
-char *
-xrealloc (ptr, size)
- char *ptr;
- int size;
-{
- register char *value;
- value = (char *) realloc (ptr, size);
- if (!value)
- memory_fatal ();
- return (value);
-}
-
-/* Return a newly-allocated string whose contents concatenate
- those of S1, S2, S3. */
-
-char *
-concat (s1, s2, s3)
- char *s1, *s2, *s3;
-{
- int len1 = strlen (s1), len2 = strlen (s2), len3 = strlen (s3);
- char *result = (char *) xmalloc (len1 + len2 + len3 + 1);
-
- strcpy (result, s1);
- strcpy (result + len1, s2);
- strcpy (result + len1 + len2, s3);
- result[len1 + len2 + len3] = 0;
-
- return result;
-}
-
-/* Return a pointer to the first occurrence in STR of C,
- or 0 if C does not occur. */
-
-char *
-myindex (str, c)
- char *str;
- char c;
-{
- char *s = str;
-
- while (*s)
- {
- if (*s == c)
- return s;
- s++;
- }
- return 0;
-}
-\f
-#ifndef HAVE_STRERROR
-char *
-strerror (errnum)
- int errnum;
-{
- extern char *sys_errlist[];
- extern int sys_nerr;
-
- if (errnum >= 0 && errnum < sys_nerr)
- return sys_errlist[errnum];
- return (char *) "Unknown error";
-}
-
-#endif /* ! HAVE_STRERROR */
+++ /dev/null
-/* File name wild card expansion for VMS.
- This file is part of the etags program.
- Copyright (C) 1987 Free Software Foundation, Inc.
-
- 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 2, 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. */
-
-#include <stdio.h>
-typedef char tbool;
-
-/* This is a BUG! ANY arbitrary limit is a BUG!
- Won't someone please fix this? */
-#define MAX_FILE_SPEC_LEN 255
-typedef struct {
- short curlen;
- char body[MAX_FILE_SPEC_LEN + 1];
-} vspec;
-#define EOS '\0'
-#define NO 0
-#define YES 1
-#define NULL 0
-
-/* gfnames - return in successive calls the
- name of each file specified by all the remaining args in the command-line
- expanding wild cards and
- stepping over arguments when they have been processed completely
-*/
-char*
-gfnames(pac, pav, p_error)
- int *pac;
- char **pav[];
- tbool *p_error;
-{
- static vspec filename = {MAX_FILE_SPEC_LEN, "\0"};
- short fn_exp();
-
- while (1)
- if (*pac == 0)
- {
- *p_error = NO;
- return(NULL);
- }
- else switch(fn_exp(&filename, **pav))
- {
- case 1:
- *p_error = NO;
- return(filename.body);
- break;
- case 0:
- --*pac;
- ++*pav;
- break;
- default:
- *p_error = YES;
- return(filename.body);
- break;
- }
-
-}
-
-/* fn_exp - expand specification of list of file names
- returning in each successive call the next filename matching the input
- spec. The function expects that each in_spec passed
- to it will be processed to completion; in particular, up to and
- including the call following that in which the last matching name
- is returned, the function ignores the value of in_spec, and will
- only start processing a new spec with the following call.
- If an error occurs, on return out_spec contains the value
- of in_spec when the error occurred.
-
- With each successive filename returned in out_spec, the
- function's return value is one. When there are no more matching
- names the function returns zero. If on the first call no file
- matches in_spec, or there is any other error, -1 is returned.
-*/
-
-#include <rmsdef.h>
-#include <descrip.h>
-#define OUTSIZE MAX_FILE_SPEC_LEN
-short
-fn_exp(out, in)
- vspec *out;
- char *in;
-{
- static long context = 0;
- static struct dsc$descriptor_s o;
- static struct dsc$descriptor_s i;
- static tbool pass1 = YES;
- long status;
- short retval;
-
- if (pass1)
- {
- pass1 = NO;
- o.dsc$a_pointer = (char *) out;
- o.dsc$w_length = (short)OUTSIZE;
- i.dsc$a_pointer = in;
- i.dsc$w_length = (short)strlen(in);
- i.dsc$b_dtype = DSC$K_DTYPE_T;
- i.dsc$b_class = DSC$K_CLASS_S;
- o.dsc$b_dtype = DSC$K_DTYPE_VT;
- o.dsc$b_class = DSC$K_CLASS_VS;
- }
- if ( (status = lib$find_file(&i, &o, &context, 0, 0)) == RMS$_NORMAL)
- {
- out->body[out->curlen] = EOS;
- return(1);
- }
- else if (status == RMS$_NMF)
- retval = 0;
- else
- {
- strcpy(out->body, in);
- retval = -1;
- }
- lib$find_file_end(&context);
- pass1 = YES;
- return(retval);
-}
-
-#ifndef OLD /* Newer versions of VMS do provide `system'. */
-system(cmd)
- char *cmd;
-{
- fprintf(stderr, "system() function not implemented under VMS\n");
-}
-#endif
-
-#define VERSION_DELIM ';'
-char *massage_name(s)
- char *s;
-{
- char *start = s;
-
- for ( ; *s; s++)
- if (*s == VERSION_DELIM)
- {
- *s = EOS;
- break;
- }
- else
- *s = tolower(*s);
- return(start);
-}
+++ /dev/null
-/* Make all the directories along a path.
- Copyright (C) 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 2, or (at your option)
-any later version.
-
-GNU Emacs is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Emacs; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-/* This program works like mkdir, except that it generates
- intermediate directories if they don't exist. This is just like
- the `mkdir -p' command on most systems; unfortunately, the mkdir
- command on some of the purer BSD systems (like Mt. Xinu) don't have
- that option. */
-
-#include <sys/types.h>
-#include <sys/stat.h>
-#include <stdio.h>
-#include <errno.h>
-
-extern int errno;
-
-char *prog_name;
-
-/* Create directory DIRNAME if it does not exist already.
- Then give permission for everyone to read and search it.
- Return 0 if successful, 1 if not. */
-
-int
-touchy_mkdir (dirname)
- char *dirname;
-{
- struct stat buf;
-
- /* If DIRNAME already exists and is a directory, don't create. */
- if (! (stat (dirname, &buf) >= 0
- && (buf.st_mode & S_IFMT) == S_IFDIR))
- {
- /* Otherwise, try to make it. If DIRNAME exists but isn't a directory,
- this will signal an error. */
- if (mkdir (dirname, 0777) < 0)
- {
- fprintf (stderr, "%s: ", prog_name);
- perror (dirname);
- return 1;
- }
- }
-
- /* Make sure everyone can look at this directory. */
- if (stat (dirname, &buf) < 0)
- {
- fprintf (stderr, "%s: ", prog_name);
- perror (dirname);
- return 1;
- }
- if (chmod (dirname, 0555 | (buf.st_mode & 0777)) < 0)
- {
- fprintf (stderr, "%s: ", prog_name);
- perror (dirname);
- }
-
- return 0;
-}
-
-int
-main (argc, argv)
- int argc;
- char **argv;
-{
- prog_name = *argv;
-
- for (argc--, argv++; argc > 0; argc--, argv++)
- {
- char *dirname = *argv;
- int i;
-
- /* Stop at each slash in dirname and try to create the directory.
- Skip any initial slash. */
- for (i = (dirname[0] == '/') ? 1 : 0; dirname[i]; i++)
- if (dirname[i] == '/')
- {
- dirname[i] = '\0';
- if (touchy_mkdir (dirname) < 0)
- goto next_dirname;
- dirname[i] = '/';
- }
-
- touchy_mkdir (dirname);
-
- next_dirname:
- ;
- }
-
- return 0;
-}
+++ /dev/null
-#! /bin/sh
-
-# RCS to ChangeLog generator
-
-# Generate a change log prefix from RCS files (perhaps in the CVS repository)
-# and the ChangeLog (if any).
-# Output the new prefix to standard output.
-# You can edit this prefix by hand, and then prepend it to ChangeLog.
-
-# Ignore log entries that start with `#'.
-# Clump together log entries that start with `{topic} ',
-# where `topic' contains neither white space nor `}'.
-
-Help='The default FILEs are the files registered under the working directory.
-Options:
-
- -c CHANGELOG Output a change log prefix to CHANGELOG (default ChangeLog).
- -h HOSTNAME Use HOSTNAME in change log entries (default current host).
- -i INDENT Indent change log lines by INDENT spaces (default 8).
- -l LENGTH Try to limit log lines to LENGTH characters (default 79).
- -R If no FILEs are given and RCS is used, recurse through working directory.
- -r OPTION Pass OPTION to subsidiary log command.
- -t TABWIDTH Tab stops are every TABWIDTH characters (default 8).
- -u "LOGIN<tab>FULLNAME<tab>MAILADDR" Assume LOGIN has FULLNAME and MAILADDR.
- -v Append RCS revision to file names in log lines.
- --help Output help.
- --version Output version number.
-
-Report bugs to <bug-gnu-emacs@gnu.org>.'
-
-Id='$Id: rcs2log,v 1.46 2001/01/02 18:50:14 eggert Exp $'
-
-# Copyright 1992, 93, 94, 95, 96, 97, 1998 Free Software Foundation, Inc.
-
-# 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 2, 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; see the file COPYING. If not, write to the
-# Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-# Boston, MA 02111-1307, USA.
-
-Copyright='Copyright 1998 Free Software Foundation, Inc.
-This program comes with NO WARRANTY, to the extent permitted by law.
-You may redistribute copies of this program
-under the terms of the GNU General Public License.
-For more information about these matters, see the files named COPYING.
-Author: Paul Eggert <eggert@twinsun.com>'
-
-tab=' '
-nl='
-'
-
-# Parse options.
-
-# defaults
-: ${AWK=awk}
-: ${TMPDIR=/tmp}
-changelog=ChangeLog # change log file name
-datearg= # rlog date option
-hostname= # name of local host (if empty, will deduce it later)
-indent=8 # indent of log line
-length=79 # suggested max width of log line
-logins= # login names for people we know fullnames and mailaddrs of
-loginFullnameMailaddrs= # login<tab>fullname<tab>mailaddr triplets
-logTZ= # time zone for log dates (if empty, use local time)
-recursive= # t if we want recursive rlog
-revision= # t if we want revision numbers
-rlog_options= # options to pass to rlog
-tabwidth=8 # width of horizontal tab
-
-while :
-do
- case $1 in
- -c) changelog=${2?}; shift;;
- -i) indent=${2?}; shift;;
- -h) hostname=${2?}; shift;;
- -l) length=${2?}; shift;;
- -[nu]) # -n is obsolescent; it is replaced by -u.
- case $1 in
- -n) case ${2?}${3?}${4?} in
- *"$tab"* | *"$nl"*)
- echo >&2 "$0: -n '$2' '$3' '$4': tabs, newlines not allowed"
- exit 1
- esac
- case $loginFullnameMailaddrs in
- '') loginFullnameMailaddrs=$2$tab$3$tab$4;;
- ?*) loginFullnameMailaddrs=$loginFullnameMailaddrs$nl$2$tab$3$tab$4
- esac
- shift; shift; shift;;
- -u)
- # If $2 is not tab-separated, use colon for separator.
- case ${2?} in
- *"$nl"*)
- echo >&2 "$0: -u '$2': newlines not allowed"
- exit 1;;
- *"$tab"*)
- t=$tab;;
- *)
- t=:
- esac
- case $2 in
- *"$t"*"$t"*"$t"*)
- echo >&2 "$0: -u '$2': too many fields"
- exit 1;;
- *"$t"*"$t"*)
- ;;
- *)
- echo >&2 "$0: -u '$2': not enough fields"
- exit 1
- esac
- case $loginFullnameMailaddrs in
- '') loginFullnameMailaddrs=$2;;
- ?*) loginFullnameMailaddrs=$loginFullnameMailaddrs$nl$2
- esac
- shift
- esac
- case $logins in
- '') logins=$login;;
- ?*) logins=$logins$nl$login
- esac
- ;;
- -r)
- case $rlog_options in
- '') rlog_options=${2?};;
- ?*) rlog_options=$rlog_options$nl${2?}
- esac
- shift;;
- -R) recursive=t;;
- -t) tabwidth=${2?}; shift;;
- -v) revision=t;;
- --version)
- set $Id
- rcs2logVersion=$3
- echo >&2 "rcs2log (GNU Emacs) $rcs2logVersion$nl$Copyright"
- exit 0;;
- -*) echo >&2 "Usage: $0 [OPTION]... [FILE ...]$nl$Help"
- case $1 in
- --help) exit 0;;
- *) exit 1
- esac;;
- *) break
- esac
- shift
-done
-
-month_data='
- m[0]="Jan"; m[1]="Feb"; m[2]="Mar"
- m[3]="Apr"; m[4]="May"; m[5]="Jun"
- m[6]="Jul"; m[7]="Aug"; m[8]="Sep"
- m[9]="Oct"; m[10]="Nov"; m[11]="Dec"
-'
-
-
-# Put rlog output into $rlogout.
-
-# If no rlog options are given,
-# log the revisions checked in since the first ChangeLog entry.
-# Since ChangeLog is only by date, some of these revisions may be duplicates of
-# what's already in ChangeLog; it's the user's responsibility to remove them.
-case $rlog_options in
-'')
- if test -s "$changelog"
- then
- e='
- /^[0-9]+-[0-9][0-9]-[0-9][0-9]/{
- # ISO 8601 date
- print $1
- exit
- }
- /^... ... [ 0-9][0-9] [ 0-9][0-9]:[0-9][0-9]:[0-9][0-9] [0-9]+ /{
- # old-fashioned date and time (Emacs 19.31 and earlier)
- '"$month_data"'
- year = $5
- for (i=0; i<=11; i++) if (m[i] == $2) break
- dd = $3
- printf "%d-%02d-%02d\n", year, i+1, dd
- exit
- }
- '
- d=`$AWK "$e" <"$changelog"` || exit
- case $d in
- ?*) datearg="-d>$d"
- esac
- fi
-esac
-
-# Use TZ specified by ChangeLog local variable, if any.
-if test -s "$changelog"
-then
- extractTZ='
- /^.*change-log-time-zone-rule['"$tab"' ]*:['"$tab"' ]*"\([^"]*\)".*/{
- s//\1/; p; q
- }
- /^.*change-log-time-zone-rule['"$tab"' ]*:['"$tab"' ]*t.*/{
- s//UTC0/; p; q
- }
- '
- logTZ=`tail "$changelog" | sed -n "$extractTZ"`
- case $logTZ in
- ?*) TZ=$logTZ; export TZ
- esac
-fi
-
-# If CVS is in use, examine its repository, not the normal RCS files.
-if test ! -f CVS/Repository
-then
- rlog=rlog
- repository=
-else
- rlog='cvs -q log'
- repository=`sed 1q <CVS/Repository` || exit
- test ! -f CVS/Root || CVSROOT=`cat <CVS/Root` || exit
- case $CVSROOT in
- *:/*)
- # remote repository
- ;;
- *)
- # local repository
- case $repository in
- /*) ;;
- *) repository=${CVSROOT?}/$repository
- esac
- if test ! -d "$repository"
- then
- echo >&2 "$0: $repository: bad repository (see CVS/Repository)"
- exit 1
- fi
- esac
-fi
-
-# Use $rlog's -zLT option, if $rlog supports it.
-case `$rlog -zLT 2>&1` in
-*' option'*) ;;
-*)
- case $rlog_options in
- '') rlog_options=-zLT;;
- ?*) rlog_options=-zLT$nl$rlog_options
- esac
-esac
-
-# With no arguments, examine all files under the RCS directory.
-case $# in
-0)
- case $repository in
- '')
- oldIFS=$IFS
- IFS=$nl
- case $recursive in
- t)
- RCSdirs=`find . -name RCS -type d -print`
- filesFromRCSfiles='s|,v$||; s|/RCS/|/|; s|^\./||'
- files=`
- {
- case $RCSdirs in
- ?*) find $RCSdirs \
- -type f \
- ! -name '*_' \
- ! -name ',*,' \
- ! -name '.*_' \
- ! -name .rcsfreeze.log \
- ! -name .rcsfreeze.ver \
- -print
- esac
- find . -name '*,v' -print
- } |
- sort -u |
- sed "$filesFromRCSfiles"
- `;;
- *)
- files=
- for file in RCS/.* RCS/* .*,v *,v
- do
- case $file in
- RCS/. | RCS/.. | RCS/,*, | RCS/*_) continue;;
- RCS/.rcsfreeze.log | RCS/.rcsfreeze.ver) continue;;
- RCS/.\* | RCS/\* | .\*,v | \*,v) test -f "$file" || continue;;
- RCS/*,v | RCS/.*,v) ;;
- RCS/* | RCS/.*) test -f "$file" || continue
- esac
- case $files in
- '') files=$file;;
- ?*) files=$files$nl$file
- esac
- done
- case $files in
- '') exit 0
- esac
- esac
- set x $files
- shift
- IFS=$oldIFS
- esac
-esac
-
-logdir=$TMPDIR/rcs2log$$
-llogout=$logdir/l
-rlogout=$logdir/r
-trap exit 1 2 13 15
-trap "rm -fr $logdir 2>/dev/null" 0
-(umask 077 && exec mkdir $logdir) || exit
-
-case $datearg in
-?*) $rlog $rlog_options "$datearg" ${1+"$@"} >$rlogout;;
-'') $rlog $rlog_options ${1+"$@"} >$rlogout
-esac || exit
-
-
-# Get the full name of each author the logs mention, and set initialize_fullname
-# to awk code that initializes the `fullname' awk associative array.
-# Warning: foreign authors (i.e. not known in the passwd file) are mishandled;
-# you have to fix the resulting output by hand.
-
-initialize_fullname=
-initialize_mailaddr=
-
-case $loginFullnameMailaddrs in
-?*)
- case $loginFullnameMailaddrs in
- *\"* | *\\*)
- sed 's/["\\]/\\&/g' >$llogout <<EOF || exit
-$loginFullnameMailaddrs
-EOF
- loginFullnameMailaddrs=`cat $llogout`
- esac
-
- oldIFS=$IFS
- IFS=$nl
- for loginFullnameMailaddr in $loginFullnameMailaddrs
- do
- case $loginFullnameMailaddr in
- *"$tab"*) IFS=$tab;;
- *) IFS=:
- esac
- set x $loginFullnameMailaddr
- login=$2
- fullname=$3
- mailaddr=$4
- initialize_fullname="$initialize_fullname
- fullname[\"$login\"] = \"$fullname\""
- initialize_mailaddr="$initialize_mailaddr
- mailaddr[\"$login\"] = \"$mailaddr\""
- done
- IFS=$oldIFS
-esac
-
-case $llogout in
-?*) sort -u -o $llogout <<EOF || exit
-$logins
-EOF
-esac
-output_authors='/^date: / {
- if ($2 ~ /^[0-9]*[-\/][0-9][0-9][-\/][0-9][0-9]$/ && $3 ~ /^[0-9][0-9]:[0-9][0-9]:[0-9][0-9][-+0-9:]*;$/ && $4 == "author:" && $5 ~ /^[^;]*;$/) {
- print substr($5, 1, length($5)-1)
- }
-}'
-authors=`
- $AWK "$output_authors" <$rlogout |
- case $llogout in
- '') sort -u;;
- ?*) sort -u | comm -23 - $llogout
- esac
-`
-case $authors in
-?*)
- cat >$llogout <<EOF || exit
-$authors
-EOF
- initialize_author_script='s/["\\]/\\&/g; s/.*/author[\"&\"] = 1/'
- initialize_author=`sed -e "$initialize_author_script" <$llogout`
- awkscript='
- BEGIN {
- alphabet = "abcdefghijklmnopqrstuvwxyz"
- ALPHABET = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
- '"$initialize_author"'
- }
- {
- if (author[$1]) {
- fullname = $5
- if (fullname ~ /[0-9]+-[^(]*\([0-9]+\)$/) {
- # Remove the junk from fullnames like "0000-Admin(0000)".
- fullname = substr(fullname, index(fullname, "-") + 1)
- fullname = substr(fullname, 1, index(fullname, "(") - 1)
- }
- if (fullname ~ /,[^ ]/) {
- # Some sites put comma-separated junk after the fullname.
- # Remove it, but leave "Bill Gates, Jr" alone.
- fullname = substr(fullname, 1, index(fullname, ",") - 1)
- }
- abbr = index(fullname, "&")
- if (abbr) {
- a = substr($1, 1, 1)
- A = a
- i = index(alphabet, a)
- if (i) A = substr(ALPHABET, i, 1)
- fullname = substr(fullname, 1, abbr-1) A substr($1, 2) substr(fullname, abbr+1)
- }
-
- # Quote quotes and backslashes properly in full names.
- # Do not use gsub; traditional awk lacks it.
- quoted = ""
- rest = fullname
- for (;;) {
- p = index(rest, "\\")
- q = index(rest, "\"")
- if (p) {
- if (q && q<p) p = q
- } else {
- if (!q) break
- p = q
- }
- quoted = quoted substr(rest, 1, p-1) "\\" substr(rest, p, 1)
- rest = substr(rest, p+1)
- }
-
- printf "fullname[\"%s\"] = \"%s%s\"\n", $1, quoted, rest
- author[$1] = 0
- }
- }
- '
-
- initialize_fullname=`
- {
- (getent passwd $authors) ||
- (
- cat /etc/passwd
- for author in $authors
- do NIS_PATH= nismatch $author passwd.org_dir
- done
- ypmatch $authors passwd
- )
- } 2>/dev/null |
- $AWK -F: "$awkscript"
- `$initialize_fullname
-esac
-
-
-# Function to print a single log line.
-# We don't use awk functions, to stay compatible with old awk versions.
-# `Log' is the log message (with \n replaced by \001).
-# `files' contains the affected files.
-printlogline='{
-
- # Following the GNU coding standards, rewrite
- # * file: (function): comment
- # to
- # * file (function): comment
- if (Log ~ /^\([^)]*\): /) {
- i = index(Log, ")")
- files = files " " substr(Log, 1, i)
- Log = substr(Log, i+3)
- }
-
- # If "label: comment" is too long, break the line after the ":".
- sep = " "
- if ('"$length"' <= '"$indent"' + 1 + length(files) + index(Log, SOH)) sep = "\n" indent_string
-
- # Print the label.
- printf "%s*%s:", indent_string, files
-
- # Print each line of the log, transliterating \001 to \n.
- while ((i = index(Log, SOH)) != 0) {
- logline = substr(Log, 1, i-1)
- if (logline ~ /[^'"$tab"' ]/) {
- printf "%s%s\n", sep, logline
- } else {
- print ""
- }
- sep = indent_string
- Log = substr(Log, i+1)
- }
-}'
-
-# Pattern to match the `revision' line of rlog output.
-rlog_revision_pattern='^revision [0-9]+\.[0-9]+(\.[0-9]+\.[0-9]+)*(['"$tab"' ]+locked by: [^'"$tab"' $,.0-9:;@]*[^'"$tab"' $,:;@][^'"$tab"' $,.0-9:;@]*;)?['"$tab"' ]*$'
-
-case $hostname in
-'')
- hostname=`(
- hostname || uname -n || uuname -l || cat /etc/whoami
- ) 2>/dev/null` || {
- echo >&2 "$0: cannot deduce hostname"
- exit 1
- }
-
- case $hostname in
- *.*) ;;
- *)
- domainname=`(domainname) 2>/dev/null` &&
- case $domainname in
- *.*) hostname=$hostname.$domainname
- esac
- esac
-esac
-
-
-# Process the rlog output, generating ChangeLog style entries.
-
-# First, reformat the rlog output so that each line contains one log entry.
-# Transliterate \n to \001 so that multiline entries fit on a single line.
-# Discard irrelevant rlog output.
-$AWK <$rlogout '
- BEGIN { repository = "'"$repository"'" }
- /^RCS file:/ {
- if (repository != "") {
- filename = $3
- if (substr(filename, 1, length(repository) + 1) == repository "/") {
- filename = substr(filename, length(repository) + 2)
- }
- if (filename ~ /,v$/) {
- filename = substr(filename, 1, length(filename) - 2)
- }
- if (filename ~ /(^|\/)Attic\/[^\/]*$/) {
- i = length(filename)
- while (substr(filename, i, 1) != "/") i--
- filename = substr(filename, 1, i - 6) substr(filename, i + 1)
- }
- }
- rev = "?"
- }
- /^Working file:/ { if (repository == "") filename = $3 }
- /'"$rlog_revision_pattern"'/, /^(-----------*|===========*)$/ {
- line = $0
- if (line ~ /'"$rlog_revision_pattern"'/) {
- rev = $2
- next
- }
- if (line ~ /^date: [0-9][- +\/0-9:]*;/) {
- date = $2
- if (date ~ /\//) {
- # This is a traditional RCS format date YYYY/MM/DD.
- # Replace "/"s with "-"s to get ISO format.
- newdate = ""
- while ((i = index(date, "/")) != 0) {
- newdate = newdate substr(date, 1, i-1) "-"
- date = substr(date, i+1)
- }
- date = newdate date
- }
- time = substr($3, 1, length($3) - 1)
- author = substr($5, 1, length($5)-1)
- printf "%s %s %s %s %s %c", filename, rev, date, time, author, 1
- rev = "?"
- next
- }
- if (line ~ /^branches: /) { next }
- if (line ~ /^(-----------*|===========*)$/) { print ""; next }
- if (line == "Initial revision" || line ~ /^file .+ was initially added on branch .+\.$/) {
- line = "New file."
- }
- printf "%s%c", line, 1
- }
-' |
-
-# Now each line is of the form
-# FILENAME REVISION YYYY-MM-DD HH:MM:SS[+-TIMEZONE] AUTHOR \001LOG
-# where \001 stands for a carriage return,
-# and each line of the log is terminated by \001 instead of \n.
-# Sort the log entries, first by date+time (in reverse order),
-# then by author, then by log entry, and finally by file name and revision
-# (just in case).
-sort +2 -4r +4 +0 |
-
-# Finally, reformat the sorted log entries.
-$AWK '
- BEGIN {
- logTZ = "'"$logTZ"'"
- revision = "'"$revision"'"
-
- # Some awk variants do not understand "\001", so we have to
- # put the char directly in the file.
- SOH="\ 1" # <-- There is a single SOH (octal code 001) here.
-
- # Initialize the fullname and mailaddr associative arrays.
- '"$initialize_fullname"'
- '"$initialize_mailaddr"'
-
- # Initialize indent string.
- indent_string = ""
- i = '"$indent"'
- if (0 < '"$tabwidth"')
- for (; '"$tabwidth"' <= i; i -= '"$tabwidth"')
- indent_string = indent_string "\t"
- while (1 <= i--)
- indent_string = indent_string " "
- }
-
- {
- newlog = substr($0, 1 + index($0, SOH))
-
- # Ignore log entries prefixed by "#".
- if (newlog ~ /^#/) { next }
-
- if (Log != newlog || date != $3 || author != $5) {
-
- # The previous log and this log differ.
-
- # Print the old log.
- if (date != "") '"$printlogline"'
-
- # Logs that begin with "{clumpname} " should be grouped together,
- # and the clumpname should be removed.
- # Extract the new clumpname from the log header,
- # and use it to decide whether to output a blank line.
- newclumpname = ""
- sep = "\n"
- if (date == "") sep = ""
- if (newlog ~ /^\{[^'"$tab"' }]*}['"$tab"' ]/) {
- i = index(newlog, "}")
- newclumpname = substr(newlog, 1, i)
- while (substr(newlog, i+1) ~ /^['"$tab"' ]/) i++
- newlog = substr(newlog, i+1)
- if (clumpname == newclumpname) sep = ""
- }
- printf sep
- clumpname = newclumpname
-
- # Get ready for the next log.
- Log = newlog
- if (files != "")
- for (i in filesknown)
- filesknown[i] = 0
- files = ""
- }
- if (date != $3 || author != $5) {
- # The previous date+author and this date+author differ.
- # Print the new one.
- date = $3
- time = $4
- author = $5
-
- zone = ""
- if (logTZ && ((i = index(time, "-")) || (i = index(time, "+"))))
- zone = " " substr(time, i)
-
- # Print "date[ timezone] fullname <email address>".
- # Get fullname and email address from associative arrays;
- # default to author and author@hostname if not in arrays.
- if (fullname[author])
- auth = fullname[author]
- else
- auth = author
- printf "%s%s %s ", date, zone, auth
- if (mailaddr[author])
- printf "<%s>\n\n", mailaddr[author]
- else
- printf "<%s@%s>\n\n", author, "'"$hostname"'"
- }
- if (! filesknown[$1]) {
- filesknown[$1] = 1
- if (files == "") files = " " $1
- else files = files ", " $1
- if (revision && $2 != "?") files = files " " $2
- }
- }
- END {
- # Print the last log.
- if (date != "") {
- '"$printlogline"'
- printf "\n"
- }
- }
-' &&
-
-
-# Exit successfully.
-
-exec rm -fr $logdir
-
-# Local Variables:
-# tab-width:4
-# End:
+++ /dev/null
-/* timer.c --- daemon to provide a tagged interval timer service
-
- This little daemon runs forever waiting for commands to schedule events.
- SIGALRM causes
- it to check its queue for events attached to the current second; if
- one is found, its label is written to stdout. SIGTERM causes it to
- terminate, printing a list of pending events.
-
- This program is intended to be used with the lisp package called
- timer.el. The first such program was written anonymously in 1990.
- This version was documented and rewritten for portability by
- esr@snark.thyrsus.com, Aug 7 1992. */
-
-#include <stdio.h>
-#include <signal.h>
-#include <errno.h>
-#include <sys/types.h> /* time_t */
-
-#include <../src/config.h>
-#undef read
-
-#ifdef LINUX
-/* Perhaps this is correct unconditionally. */
-#undef signal
-#endif
-#ifdef _CX_UX
-/* I agree with the comment above, this probably should be unconditional (it
- * is already unconditional in a couple of other files in this directory),
- * but in the spirit of minimizing the effects of my port, I am making it
- * conditional on _CX_UX.
- */
-#undef signal
-#endif
-
-
-extern int errno;
-extern char *strerror ();
-extern time_t time ();
-
-/*
- * The field separator for input. This character shouldn't occur in dates,
- * and should be printable so event strings are readable by people.
- */
-#define FS '@'
-
-struct event
- {
- char *token;
- time_t reply_at;
- };
-int events_size; /* How many slots have we allocated? */
-int num_events; /* How many are actually scheduled? */
-struct event *events; /* events[0 .. num_events-1] are the
- valid events. */
-
-char *pname; /* program name for error messages */
-
-/* This buffer is used for reading commands.
- We make it longer when necessary, but we never free it. */
-char *buf;
-/* This is the allocated size of buf. */
-int buf_size;
-
-/* Non-zero means don't handle an alarm now;
- instead, just set alarm_deferred if an alarm happens.
- We set this around parts of the program that call malloc and free. */
-int defer_alarms;
-
-/* Non-zero if an alarm came in during the reading of a command. */
-int alarm_deferred;
-\f
-/* Schedule one event, and arrange an alarm for it.
- STR is a string of two fields separated by FS.
- First field is string for get_date, saying when to wake-up.
- Second field is a token to identify the request. */
-
-void
-schedule (str)
- char *str;
-{
- extern time_t get_date ();
- extern char *strcpy ();
- time_t now;
- register char *p;
- static struct event *ep;
-
- /* check entry format */
- for (p = str; *p && *p != FS; p++)
- continue;
- if (!*p)
- {
- fprintf (stderr, "%s: bad input format: %s\n", pname, str);
- return;
- }
- *p++ = 0;
-
- /* allocate an event slot */
- ep = events + num_events;
-
- /* If the event array is full, stretch it. After stretching, we know
- that ep will be pointing to an available event spot. */
- if (ep == events + events_size)
- {
- int old_size = events_size;
-
- events_size *= 2;
- events = ((struct event *)
- realloc (events, events_size * sizeof (struct event)));
- if (! events)
- {
- fprintf (stderr, "%s: virtual memory exhausted.\n", pname);
- /* Since there is so much virtual memory, and running out
- almost surely means something is very very wrong,
- it is best to exit rather than continue. */
- exit (1);
- }
-
- while (old_size < events_size)
- events[old_size++].token = NULL;
- }
-
- /* Don't allow users to schedule events in past time. */
- ep->reply_at = get_date (str, NULL);
- if (ep->reply_at - time (&now) < 0)
- {
- fprintf (stderr, "%s: bad time spec: %s%c%s\n", pname, str, FS, p);
- return;
- }
-
- /* save the event description */
- ep->token = (char *) malloc ((unsigned) strlen (p) + 1);
- if (! ep->token)
- {
- fprintf (stderr, "%s: malloc %s: %s%c%s\n",
- pname, strerror (errno), str, FS, p);
- return;
- }
-
- strcpy (ep->token, p);
- num_events++;
-}
-\f
-/* Print the notification for the alarmed event just arrived if any,
- and schedule an alarm for the next event if any. */
-
-void
-notify ()
-{
- time_t now, tdiff, waitfor = -1;
- register struct event *ep;
-
- /* Inhibit interference with alarms while changing global vars. */
- defer_alarms = 1;
- alarm_deferred = 0;
-
- now = time ((time_t *) NULL);
-
- for (ep = events; ep < events + num_events; ep++)
- /* Are any events ready to fire? */
- if (ep->reply_at <= now)
- {
- fputs (ep->token, stdout);
- putc ('\n', stdout);
- fflush (stdout);
- free (ep->token);
-
- /* We now have a hole in the event array; fill it with the last
- event. */
- ep->token = events[num_events - 1].token;
- ep->reply_at = events[num_events - 1].reply_at;
- num_events--;
-
- /* We ought to scan this event again. */
- ep--;
- }
- else
- {
- /* next timeout should be the soonest of any remaining */
- if ((tdiff = ep->reply_at - now) < waitfor || waitfor < 0)
- waitfor = (long)tdiff;
- }
-
- /* If there are no more events, we needn't bother setting an alarm. */
- if (num_events > 0)
- alarm (waitfor);
-
- /* Now check if there was another alarm
- while we were handling an explicit request. */
- defer_alarms = 0;
- if (alarm_deferred)
- notify ();
- alarm_deferred = 0;
-}
-\f
-/* Read one command from command from standard input
- and schedule the event for it. */
-
-void
-getevent ()
-{
- int i;
-
- /* In principle the itimer should be disabled on entry to this
- function, but it really doesn't make any important difference
- if it isn't. */
-
- if (buf == 0)
- {
- buf_size = 80;
- buf = (char *) malloc (buf_size);
- }
-
- /* Read a line from standard input, expanding buf if it is too short
- to hold the line. */
- for (i = 0; ; i++)
- {
- char c;
- int nread;
-
- if (i >= buf_size)
- {
- buf_size *= 2;
- alarm_deferred = 0;
- defer_alarms = 1;
- buf = (char *) realloc (buf, buf_size);
- defer_alarms = 0;
- if (alarm_deferred)
- notify ();
- alarm_deferred = 0;
- }
-
- /* Read one character into c. */
- while (1)
- {
- nread = read (fileno (stdin), &c, 1);
-
- /* Retry after transient error. */
- if (nread < 0
- && (1
-#ifdef EINTR
- || errno == EINTR
-#endif
-#ifdef EAGAIN
- || errno == EAGAIN
-#endif
- ))
- continue;
-
- /* Report serious errors. */
- if (nread < 0)
- {
- perror ("read");
- exit (1);
- }
-
- /* On eof, exit. */
- if (nread == 0)
- exit (0);
-
- break;
- }
-
- if (c == '\n')
- {
- buf[i] = '\0';
- break;
- }
-
- buf[i] = c;
- }
-
- /* Register the event. */
- alarm_deferred = 0;
- defer_alarms = 1;
- schedule (buf);
- defer_alarms = 0;
- notify ();
- alarm_deferred = 0;
-}
-
-/* Handle incoming signal SIG. */
-
-SIGTYPE
-sigcatch (sig)
- int sig;
-{
- struct event *ep;
-
- /* required on older UNIXes; harmless on newer ones */
- signal (sig, sigcatch);
-
- switch (sig)
- {
- case SIGALRM:
- if (defer_alarms)
- alarm_deferred = 1;
- else
- notify ();
- break;
- case SIGTERM:
- fprintf (stderr, "Events still queued:\n");
- for (ep = events; ep < events + num_events; ep++)
- fprintf (stderr, "%d = %ld @ %s\n",
- ep - events, ep->reply_at, ep->token);
- exit (0);
- break;
- }
-}
-
-/*ARGSUSED*/
-int
-main (argc, argv)
- int argc;
- char **argv;
-{
- for (pname = argv[0] + strlen (argv[0]);
- *pname != '/' && pname != argv[0];
- pname--);
- if (*pname == '/')
- pname++;
-
- events_size = 16;
- events = ((struct event *) malloc (events_size * sizeof (*events)));
- num_events = 0;
-
- signal (SIGALRM, sigcatch);
- signal (SIGTERM, sigcatch);
-
- /* Loop reading commands from standard input
- and scheduling alarms accordingly.
- The alarms are handled asynchronously, while we wait for commands. */
- while (1)
- getevent ();
-}
-\f
-#ifndef HAVE_STRERROR
-char *
-strerror (errnum)
- int errnum;
-{
- extern char *sys_errlist[];
- extern int sys_nerr;
-
- if (errnum >= 0 && errnum < sys_nerr)
- return sys_errlist[errnum];
- return (char *) "Unknown error";
-}
-
-#endif /* ! HAVE_STRERROR */
-
-long *
-xmalloc (size)
- int size;
-{
- register long *val;
-
- val = (long *) malloc (size);
-
- if (!val && size)
- {
- fprintf (stderr, "timer: virtual memory exceeded\n");
- exit (1);
- }
-
- return val;
-}
-
-/* timer.c ends here */
+++ /dev/null
-/* Program to produce output at regular intervals. */
-
-#ifdef HAVE_CONFIG_H
-#include <config.h>
-#endif
-
-#include <stdio.h>
-#include <sys/types.h>
-
-#ifdef TIME_WITH_SYS_TIME
-#include <sys/time.h>
-#include <time.h>
-#else
-#ifdef HAVE_SYS_TIME_H
-#include <sys/time.h>
-#else
-#include <time.h>
-#endif
-#endif
-
-struct tm *localtime ();
-
-void
-main (argc, argv)
- int argc;
- char **argv;
-{
- int period = 60;
- time_t when;
- struct tm *tp;
-
- if (argc > 1)
- period = atoi (argv[1]);
-
- while (1)
- {
- /* Make sure wakeup stops when Emacs goes away. */
- if (getppid () == 1)
- exit (0);
- printf ("Wake up!\n");
- fflush (stdout);
- /* If using a period of 60, produce the output when the minute
- changes. */
- if (period == 60)
- {
- time (&when);
- tp = localtime (&when);
- sleep (60 - tp->tm_sec);
- }
- else
- sleep (period);
- }
-}
+++ /dev/null
-;;; ada.el --- Ada editing support package in GNUlisp. v1.0
-
-;; Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc.
-
-;; Author: Vincent Broman <broman@bugs.nosc.mil>
-;; Keywords: languages
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to
-;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;;; Commentary:
-
-;; Created May 1987.
-;; (borrows heavily from Mick Jordan's Modula-2 package for GNU,
-;; as modified by Peter Robinson, Michael Schmidt, and Tom Perrine.)
-
-;;; Code:
-
-(defvar ada-mode-syntax-table nil
- "Syntax table in use in Ada-mode buffers.")
-
-(let ((table (make-syntax-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 ?- ". 12" table)
- (modify-syntax-entry ?= "." table)
- (modify-syntax-entry ?\& "." table)
- (modify-syntax-entry ?\| "." table)
- (modify-syntax-entry ?< "." table)
- (modify-syntax-entry ?> "." table)
- (modify-syntax-entry ?\[ "." table)
- (modify-syntax-entry ?\] "." table)
- (modify-syntax-entry ?\{ "." table)
- (modify-syntax-entry ?\} "." table)
- (modify-syntax-entry ?. "." table)
- (modify-syntax-entry ?\\ "." table)
- (modify-syntax-entry ?: "." table)
- (modify-syntax-entry ?\; "." table)
- (modify-syntax-entry ?\' "." table)
- (modify-syntax-entry ?\" "\"" table)
- (modify-syntax-entry ?\n ">" table)
- (setq ada-mode-syntax-table table))
-
-;; Strings are a real pain in Ada because both ' and " can appear in a
-;; non-string quote context (the former as an operator, the latter as a
-;; character string). We follow the least losing solution, in which only " is
-;; a string quote. Therefore a character string of the form '"' will throw
-;; fontification off on the wrong track.
-
-(defconst ada-font-lock-keywords-1
- (list
- ;;
- ;; Function, package (body), pragma, procedure, task (body) plus name.
- (list (concat "\\<\\("
- "function\\|"
- "p\\(ackage\\(\\|[ \t]+body\\)\\|r\\(agma\\|ocedure\\)\\)\\|"
- "task\\(\\|[ \t]+body\\)"
- "\\)\\>[ \t]*\\(\\sw+\\(\\.\\sw*\\)*\\)?")
- '(1 font-lock-keyword-face) '(6 font-lock-function-name-face nil t)))
- "For consideration as a value of `ada-font-lock-keywords'.
-This does fairly subdued highlighting.")
-
-(defconst ada-font-lock-keywords-2
- (append ada-font-lock-keywords-1
- (list
- ;;
- ;; Main keywords, except those treated specially below.
- (concat "\\<\\("
-; ("abort" "abs" "abstract" "accept" "access" "aliased" "all"
-; "and" "array" "at" "begin" "case" "declare" "delay" "delta"
-; "digits" "do" "else" "elsif" "entry" "exception" "exit" "for"
-; "generic" "if" "in" "is" "limited" "loop" "mod" "not"
-; "null" "or" "others" "private" "protected"
-; "range" "record" "rem" "renames" "requeue" "return" "reverse"
-; "select" "separate" "tagged" "task" "terminate" "then" "until"
-; "while" "xor")
- "a\\(b\\(ort\\|s\\(\\|tract\\)\\)\\|cce\\(pt\\|ss\\)\\|"
- "l\\(iased\\|l\\)\\|nd\\|rray\\|t\\)\\|begin\\|case\\|"
- "d\\(e\\(clare\\|l\\(ay\\|ta\\)\\)\\|igits\\|o\\)\\|"
- "e\\(ls\\(e\\|if\\)\\|ntry\\|x\\(ception\\|it\\)\\)\\|for\\|"
- "generic\\|i[fns]\\|l\\(imited\\|oop\\)\\|mod\\|n\\(ot\\|ull\\)\\|"
- "o\\(r\\|thers\\)\\|pr\\(ivate\\|otected\\)\\|"
- "r\\(ange\\|e\\(cord\\|m\\|names\\|queue\\|turn\\|verse\\)\\)\\|"
- "se\\(lect\\|parate\\)\\|"
- "t\\(a\\(gged\\|sk\\)\\|erminate\\|hen\\)\\|until\\|while\\|xor"
- "\\)\\>")
- ;;
- ;; Anything following end and not already fontified is a body name.
- '("\\<\\(end\\)\\>[ \t]*\\(\\sw+\\)?"
- (1 font-lock-keyword-face) (2 font-lock-function-name-face nil t))
-; ;;
-; ;; Variable name plus optional keywords followed by a type name. Slow.
-; (list (concat "\\<\\(\\sw+\\)\\>[ \t]*:"
-; "[ \t]*\\(constant\\|in\\|in[ \t]+out\\|out\\)?[ \t]*"
-; "\\(\\sw+\\(\\.\\sw*\\)*\\)?")
-; '(1 font-lock-variable-name-face)
-; '(2 font-lock-keyword-face nil t) '(3 font-lock-type-face nil t))
- ;;
- ;; Optional keywords followed by a type name.
- (list (concat ":[ \t]*\\<\\(constant\\|in\\|in[ \t]+out\\|out\\)\\>?[ \t]*"
- "\\(\\sw+\\(\\.\\sw*\\)*\\)?")
- '(1 font-lock-keyword-face nil t) '(2 font-lock-type-face nil t))
- ;;
- ;; Keywords followed by a type or function name.
- (list (concat "\\<\\("
- "new\\|of\\|subtype\\|type"
- "\\)\\>[ \t]*\\(\\sw+\\(\\.\\sw*\\)*\\)?[ \t]*\\((\\)?")
- '(1 font-lock-keyword-face)
- '(2 (if (match-beginning 4)
- font-lock-function-name-face
- font-lock-type-face) nil t))
- ;;
- ;; Keywords followed by a reference.
- (list (concat "\\<\\(goto\\|raise\\|use\\|when\\|with\\)\\>"
- "[ \t]*\\(\\sw+\\(\\.\\sw*\\)*\\)?")
- '(1 font-lock-keyword-face) '(2 font-lock-reference-face nil t))
- ;;
- ;; Goto tags.
- '("<<\\(\\sw+\\(\\.\\sw*\\)*\\)>>" 1 font-lock-reference-face)
- ))
- "For consideration as a value of `ada-font-lock-keywords'.
-This does a lot more highlighting.")
-
-(defvar ada-font-lock-keywords (if font-lock-maximum-decoration
- ada-font-lock-keywords-2
- ada-font-lock-keywords-1)
- "Additional expressions to highlight in Ada mode.")
-
-(defvar ada-mode-map nil
- "Keymap used in Ada mode.")
-
-(let ((map (make-sparse-keymap)))
- (define-key map "\C-m" 'ada-newline)
- (define-key map "\C-?" 'backward-delete-char-untabify)
- (define-key map "\C-i" 'ada-tab)
- (define-key map "\C-c\C-i" 'ada-untab)
- (define-key map "\C-c<" 'ada-backward-to-same-indent)
- (define-key map "\C-c>" 'ada-forward-to-same-indent)
- (define-key map "\C-ch" 'ada-header)
- (define-key map "\C-c(" 'ada-paired-parens)
- (define-key map "\C-c-" 'ada-inline-comment)
- (define-key map "\C-c\C-a" 'ada-array)
- (define-key map "\C-cb" 'ada-exception-block)
- (define-key map "\C-cd" 'ada-declare-block)
- (define-key map "\C-c\C-e" 'ada-exception)
- (define-key map "\C-cc" 'ada-case)
- (define-key map "\C-c\C-k" 'ada-package-spec)
- (define-key map "\C-ck" 'ada-package-body)
- (define-key map "\C-c\C-p" 'ada-procedure-spec)
- (define-key map "\C-cp" 'ada-subprogram-body)
- (define-key map "\C-c\C-f" 'ada-function-spec)
- (define-key map "\C-cf" 'ada-for-loop)
- (define-key map "\C-cl" 'ada-loop)
- (define-key map "\C-ci" 'ada-if)
- (define-key map "\C-cI" 'ada-elsif)
- (define-key map "\C-ce" 'ada-else)
- (define-key map "\C-c\C-v" 'ada-private)
- (define-key map "\C-c\C-r" 'ada-record)
- (define-key map "\C-c\C-s" 'ada-subtype)
- (define-key map "\C-cs" 'ada-separate)
- (define-key map "\C-c\C-t" 'ada-type)
- (define-key map "\C-ct" 'ada-tabsize)
-;; (define-key map "\C-c\C-u" 'ada-use)
-;; (define-key map "\C-c\C-w" 'ada-with)
- (define-key map "\C-cw" 'ada-while-loop)
- (define-key map "\C-c\C-w" 'ada-when)
- (define-key map "\C-cx" 'ada-exit)
- (define-key map "\C-cC" 'ada-compile)
- (define-key map "\C-cB" 'ada-bind)
- (define-key map "\C-cE" 'ada-find-listing)
- (define-key map "\C-cL" 'ada-library-name)
- (define-key map "\C-cO" 'ada-options-for-bind)
- (setq ada-mode-map map))
-
-(defvar ada-indent 4 "*Value is the number of columns to indent in Ada-Mode.")
-
-(defvar ada-comment-end-column)
-
-(defun ada-mode ()
-"This is a mode intended to support program development in Ada.
-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
-having the same (or lesser) level of indentation.
-
-Variable `ada-indent' controls the number of spaces for indent/undent."
- (interactive)
- (kill-all-local-variables)
- (use-local-map ada-mode-map)
- (setq major-mode 'ada-mode)
- (setq mode-name "Ada")
- (make-local-variable 'comment-column)
- (setq comment-column 41)
- (make-local-variable 'ada-comment-end-column)
- (setq ada-comment-end-column 72)
- (set-syntax-table ada-mode-syntax-table)
- (make-local-variable 'paragraph-start)
- (setq paragraph-start (concat "$\\|" page-delimiter))
- (make-local-variable 'paragraph-separate)
- (setq paragraph-separate paragraph-start)
- (make-local-variable 'paragraph-ignore-fill-prefix)
- (setq paragraph-ignore-fill-prefix t)
-; (make-local-variable 'indent-line-function)
-; (setq indent-line-function 'c-indent-line)
- (make-local-variable 'require-final-newline)
- (setq require-final-newline t)
- (make-local-variable 'comment-start)
- (setq comment-start "--")
- (make-local-variable 'comment-end)
- (setq comment-end "")
- (make-local-variable 'comment-column)
- (setq comment-column 41)
- (make-local-variable 'comment-start-skip)
- (setq comment-start-skip "--+ *")
- (make-local-variable 'comment-indent-function)
- (setq comment-indent-function 'c-comment-indent)
- (make-local-variable 'parse-sexp-ignore-comments)
- (setq parse-sexp-ignore-comments t)
- (make-local-variable 'font-lock-defaults)
- (setq font-lock-defaults '(ada-font-lock-keywords nil t ((?\_ . "w"))))
- (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")
- (setq ada-indent s))
-
-(defun ada-newline ()
- "Start new line and indent to current tab stop."
- (interactive)
- (let ((ada-cc (current-indentation)))
- (newline)
- (indent-to ada-cc)))
-
-(defun ada-tab ()
- "Indent to next tab stop."
- (interactive)
- (indent-to (* (1+ (/ (current-indentation) ada-indent)) ada-indent)))
-
-(defun ada-untab ()
- "Delete backwards to previous tab stop."
- (interactive)
- (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."
- (while (and
- (zerop (forward-line step))
- (or (looking-at "^[ ]*$")
- (looking-at "^[ ]*--")
- (looking-at "^<<[A-Za-z0-9_]+>>")
- (looking-at "^[A-Za-z0-9_]+:")
- (> (current-indentation) indent-level)))
- nil))
-
-(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."
- (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."
- (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."
- (interactive)
- (insert "array ()")
- (backward-char)
- (insert (read-string "index subtype[s]: "))
- (end-of-line)
- (insert " of ;")
- (backward-char)
- (insert (read-string "component-type: "))
- (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."
- (interactive)
- (insert "case ")
- (insert (read-string "selector expression: ") " is")
- (ada-newline)
- (ada-newline)
- (insert "end case;")
- (end-of-line 0)
- (ada-tab)
- (ada-tab)
- (ada-when))
-
-(defun ada-declare-block ()
- "Insert a block with a declare part.
-Indent for the first 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)))
- (ada-newline)
- (ada-newline)
- (insert "begin")
- (ada-newline)
- (ada-newline)
- (if (string-equal ada-block-name "")
- (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."
- (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)))
- (ada-newline)
- (ada-newline)
- (insert "exception")
- (ada-newline)
- (ada-newline)
- (cond
- ( (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."
- (interactive)
- (ada-untab)
- (insert "exception")
- (ada-newline)
- (ada-tab))
-
-(defun ada-else ()
- "Add an else clause inside an if-then-end-if clause."
- (interactive)
- (ada-untab)
- (insert "else")
- (ada-newline)
- (ada-tab))
-
-(defun ada-exit ()
- "Insert an exit statement, prompting for loop name and condition."
- (interactive)
- (insert "exit")
- (let ((ada-loop-name (read-string "[name of loop to exit]: ")))
- (if (not (string-equal ada-loop-name "")) (insert " " ada-loop-name)))
- (let ((ada-exit-condition (read-string "[exit condition]: ")))
- (if (not (string-equal ada-exit-condition ""))
- (if (string-match "^ *[Ww][Hh][Ee][Nn] +" ada-exit-condition)
- (insert " " ada-exit-condition)
- (insert " when " ada-exit-condition))))
- (insert ";"))
-
-(defun ada-when ()
- "Start a case statement alternative with a when clause."
- (interactive)
- (ada-untab) ; we were indented in code for the last alternative.
- (insert "when ")
- (insert (read-string "'|'-delimited choice list: ") " =>")
- (ada-newline)
- (ada-tab))
-
-(defun ada-for-loop ()
- "Build a skeleton for-loop statement, prompting for the loop parameters."
- (interactive)
- (insert "for ")
- (let* ((ada-loop-name (read-string "[loop name]: "))
- (ada-loop-is-named (not (string-equal ada-loop-name ""))))
- (if ada-loop-is-named
- (progn
- (beginning-of-line)
- (open-line 1)
- (insert ada-loop-name ":")
- (next-line 1)
- (end-of-line 1)))
- (insert (read-string "loop variable: ") " in ")
- (insert (read-string "range: ") " loop")
- (ada-newline)
- (ada-newline)
- (insert "end loop")
- (if ada-loop-is-named (insert " " ada-loop-name))
- (insert ";"))
- (end-of-line 0)
- (ada-tab))
-
-(defun ada-header ()
- "Insert a comment block containing the module title, author, etc."
- (interactive)
- (insert "--\n-- Title: \t")
- (insert (read-string "Title: "))
- (insert "\n-- Created:\t" (current-time-string))
- (insert "\n-- Author: \t" (user-full-name))
- (insert "\n--\t\t<" (user-login-name) "@" (system-name) ">\n--\n"))
-
-(defun ada-if ()
- "Insert skeleton if statment, prompting for a boolean-expression."
- (interactive)
- (insert "if ")
- (insert (read-string "condition: ") " then")
- (ada-newline)
- (ada-newline)
- (insert "end if;")
- (end-of-line 0)
- (ada-tab))
-
-(defun ada-elsif ()
- "Add an elsif clause to an if statement, prompting for the boolean-expression."
- (interactive)
- (ada-untab)
- (insert "elsif ")
- (insert (read-string "condition: ") " then")
- (ada-newline)
- (ada-tab))
-
-(defun ada-loop ()
- "Insert a skeleton loop statement. The exit statement is added by hand."
- (interactive)
- (insert "loop ")
- (let* ((ada-loop-name (read-string "[loop name]: "))
- (ada-loop-is-named (not (string-equal ada-loop-name ""))))
- (if ada-loop-is-named
- (progn
- (beginning-of-line)
- (open-line 1)
- (insert ada-loop-name ":")
- (forward-line 1)
- (end-of-line 1)))
- (ada-newline)
- (ada-newline)
- (insert "end loop")
- (if ada-loop-is-named (insert " " ada-loop-name))
- (insert ";"))
- (end-of-line 0)
- (ada-tab))
-
-(defun ada-package-spec ()
- "Insert a skeleton package specification."
- (interactive)
- (insert "package ")
- (let ((ada-package-name (read-string "package name: " )))
- (insert ada-package-name " is")
- (ada-newline)
- (ada-newline)
- (insert "end " ada-package-name ";")
- (end-of-line 0)
- (ada-tab)))
-
-(defun ada-package-body ()
- "Insert a skeleton package body -- includes a begin statement."
- (interactive)
- (insert "package body ")
- (let ((ada-package-name (read-string "package name: " )))
- (insert ada-package-name " is")
- (ada-newline)
- (ada-newline)
- (insert "begin")
- (ada-newline)
- (insert "end " ada-package-name ";")
- (end-of-line -1)
- (ada-tab)))
-
-(defun ada-private ()
- "Undent and start a private section of a package spec. Reindent."
- (interactive)
- (ada-untab)
- (insert "private")
- (ada-newline)
- (ada-tab))
-
-(defun ada-get-arg-list ()
- "Read from the 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."
- (insert " (")
- (let ((ada-arg-indent (current-column))
- (ada-args (read-string "[arguments]: ")))
- (if (string-equal ada-args "")
- (backward-delete-char 2)
- (progn
- (while (string-match ";$" ada-args)
- (insert ada-args)
- (newline)
- (indent-to ada-arg-indent)
- (setq ada-args (read-string "next argument: ")))
- (insert ada-args ")")))))
-
-(defun ada-function-spec ()
- "Insert a function specification. Prompts for name and arguments."
- (interactive)
- (insert "function ")
- (insert (read-string "function name: "))
- (ada-get-arg-list)
- (insert " return ")
- (insert (read-string "result type: ")))
-
-(defun ada-procedure-spec ()
- "Insert a procedure specification, prompting for its name and arguments."
- (interactive)
- (insert "procedure ")
- (insert (read-string "procedure name: " ))
- (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."
- (save-excursion
- (let ((ada-proc-indent 0))
- (if (re-search-backward
- ;;;; Unfortunately, comments are not ignored in this string search.
- "[PpFf][RrUu][OoNn][Cc][EeTt][DdIi][UuOo][RrNn]" nil t)
- (if (or (looking-at "\\<[Pp][Rr][Oo][Cc][Ee][Dd][Uu][Rr][Ee]\\>")
- (looking-at "\\<[Ff][Uu][Nn][Cc][Tt][Ii][Oo][Nn]\\>"))
- (progn
- (setq ada-proc-indent (current-column))
- (forward-word 2)
- (let ((p2 (point)))
- (forward-word -1)
- (cons (buffer-substring (point) p2) ada-proc-indent)))
- (get-ada-subprogram-name))
- (cons "NAME?" ada-proc-indent)))))
-
-(defun ada-subprogram-body ()
- "Insert frame for subprogram body.
-Invoke right after `ada-function-spec' or `ada-procedure-spec'."
- (interactive)
- (insert " is")
- (let ((ada-subprogram-name-col (get-ada-subprogram-name)))
- (newline)
- (indent-to (cdr ada-subprogram-name-col))
- (ada-newline)
- (insert "begin")
- (ada-newline)
- (ada-newline)
- (insert "end " (car ada-subprogram-name-col) ";"))
- (end-of-line -2)
- (ada-tab))
-
-(defun ada-separate ()
- "Finish a body stub with `is separate'."
- (interactive)
- (insert " is")
- (ada-newline)
- (ada-tab)
- (insert "separate;")
- (ada-newline)
- (ada-untab))
-
-;(defun ada-with ()
-; "Inserts a with clause, prompting for the list of units depended upon."
-; (interactive)
-; (insert "with ")
-; (insert (read-string "list of units depended upon: ") ";"))
-;
-;(defun ada-use ()
-; "Inserts a use clause, prompting for the list of packages used."
-; (interactive)
-; (insert "use ")
-; (insert (read-string "list of packages to use: ") ";"))
-
-(defun ada-record ()
- "Insert a skeleton record type declaration."
- (interactive)
- (insert "record")
- (ada-newline)
- (ada-newline)
- (insert "end record;")
- (end-of-line 0)
- (ada-tab))
-
-(defun ada-subtype ()
- "Start insertion of a subtype declaration, prompting for the subtype name."
- (interactive)
- (insert "subtype " (read-string "subtype name: ") " is ;")
- (backward-char)
- (message "insert subtype indication."))
-
-(defun ada-type ()
- "Start insertion of a type declaration, prompting for the type name."
- (interactive)
- (insert "type " (read-string "type name: "))
- (let ((disc-part (read-string "discriminant specs: ")))
- (if (not (string-equal disc-part ""))
- (insert "(" disc-part ")")))
- (insert " is ")
- (message "insert type definition."))
-
-(defun ada-while-loop ()
- (interactive)
- (insert "while ")
- (let* ((ada-loop-name (read-string "loop name: "))
- (ada-loop-is-named (not (string-equal ada-loop-name ""))))
- (if ada-loop-is-named
- (progn
- (beginning-of-line)
- (open-line 1)
- (insert ada-loop-name ":")
- (next-line 1)
- (end-of-line 1)))
- (insert (read-string "entry condition: ") " loop")
- (ada-newline)
- (ada-newline)
- (insert "end loop")
- (if ada-loop-is-named (insert " " ada-loop-name))
- (insert ";"))
- (end-of-line 0)
- (ada-tab))
-
-(defun ada-paired-parens ()
- "Insert a pair of round parentheses, placing point between them."
- (interactive)
- (insert "()")
- (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."
- (interactive)
- (end-of-line)
- (if (> (current-column) ada-comment-end-column) (newline))
- (if (< (current-column) comment-column) (indent-to comment-column))
- (insert " -- "))
-
-(defun ada-display-comment ()
-"Inserts three 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-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: ")
- (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': ")))
-
-(defun ada-compile (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 "))
- (ada-source-file (buffer-name)))
- (compile
- (concat "adacomp " ada-init "-l " ada-lib-dir-name " " ada-source-file))))
-
-(defun ada-find-listing ()
- "Find listing file for ada source in current buffer, using other window."
- (interactive)
- (find-file-other-window (concat (substring (buffer-name) 0 -4) ".lis"))
- (search-forward "*** ERROR"))
-
-(defun ada-bind ()
- "Bind the current program library, using the current binding options."
- (interactive)
- (compile (concat "adabind " ada-bind-opts " " ada-lib-dir-name)))
-
-;;; ada.el ends here
+++ /dev/null
-;;; batmode.el --- Simple mode for Windows BAT files
-
-;; Copyright (C) 1996 Free Software Foundation, Inc.
-
-;; Author: Peter Breton <pbreton@i-kinetics.com>
-;; Created: Thu Jul 25 1996
-;; Keywords: BAT, DOS, Windows
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;;; Commentary:
-;;
-;; USAGE: Byte-compile this file, and add the following lines to your
-;; emacs initialization file (.emacs/_emacs):
-;;
-;; (setq auto-mode-alist
-;; (append
-;; (list (cons "\\.[bB][aA][tT]$" 'bat-mode))
-;; ;; For DOS init files
-;; (list (cons "CONFIG\\." 'bat-mode))
-;; (list (cons "AUTOEXEC\\." 'bat-mode))
-;; auto-mode-alist))
-;;
-;; (autoload 'bat-mode "batmode"
-;; "DOS and WIndows BAT files" t)
-
-;; TODO:
-;;
-;; Support "compiles" ?
-;; Imenu? Don't have real functions.....
-
-;;; Change log:
-;; $Log: batmode.el,v $
-;; Revision 1.3 1996/08/22 02:31:47 peter
-;; Added Usage message, credit to folks from NTEmacs mailing list,
-;; Syntax table, New font-lock keywords
-;;
-;; Revision 1.2 1996/08/18 16:27:13 peter
-;; Added preliminary global-font-lock support
-;;
-;; Revision 1.1 1996/08/18 16:14:18 peter
-;; Initial revision
-;;
-
-;; Credit for suggestions, patches and bug-fixes:
-;; Robert Brodersen <rbrodersen@siebel.com>
-;; ACorreir@pervasive-sw.com (Alfred Correira)
-
-;;; Code:
-
-(defvar bat-mode-map nil "Local keymap for bat-mode buffers.")
-
-;; Make this lowercase if you like
-(defvar bat-mode-comment-start "REM "
- "Comment string to use in BAT mode")
-
-(defvar bat-mode-syntax-table nil
- "Syntax table in use in Bat-mode buffers.")
-
-(if bat-mode-map
- nil
- (setq bat-mode-map (copy-keymap global-map))
-)
-
-;; Make underscores count as words
-(if bat-mode-syntax-table
- ()
- (setq bat-mode-syntax-table (make-syntax-table))
- (modify-syntax-entry ?_ "w" bat-mode-syntax-table)
-)
-
-(defun bat-mode ()
- "Mode for DOS and Windows BAT files"
- (interactive)
- (kill-all-local-variables)
- (use-local-map bat-mode-map)
- (set-syntax-table bat-mode-syntax-table)
-
- (make-local-variable 'parse-sexp-ignore-comments)
- (make-local-variable 'comment-start)
- (make-local-variable 'comment-start-skip)
- (make-local-variable 'comment-end)
- (make-local-variable 'executable-command)
- (make-local-variable 'font-lock-defaults)
-
- (setq major-mode 'bat-mode
- mode-name "bat"
-
- comment-end ""
-
- comment-start bat-mode-comment-start
- comment-start-skip "[Rr][Ee][Mm] *"
-
- parse-sexp-ignore-comments t
-
- )
-
- ;; Global font-lock support
- ;; (setq font-lock-defaults (list 'bat-font-lock-keywords nil t nil nil))
- (setq font-lock-defaults (list 'bat-font-lock-keywords nil))
-
- (run-hooks 'bat-mode-hook))
-
-(defvar bat-font-lock-keywords
- (list
- ;; Make this one first in the list, otherwise comments will
- ;; be over-written by other variables
- (list "^[@ \t]*\\([rR][eE][mM].*\\)" 1 'font-lock-comment-face t)
- (list "^[ \t]*\\(::-.*\\)" 1 'font-lock-comment-face t)
- (list
- (concat "\\(\\<"
- (mapconcat 'identity
- '(
- "call"
- "echo"
- "exist"
- "errorlevel"
- "for"
- "goto"
- "if"
- "not"
- "path"
- "pause"
- "prompt"
- "set"
- "start"
- )
- "\\>\\|\\<")
- "\\>\\)") 1 'font-lock-keyword-face)
- (list "^[ \t]*\\(:\\sw+\\)" 1 'font-lock-function-name-face t)
- (list "\\(%\\sw+%\\)" 1 'font-lock-reference-face)
- (list "\\(%[0-9]\\)" 1 'font-lock-reference-face)
- (list "\\(/[^/ \t\n]+\\)" 1 'font-lock-type-face)
- (list "\\<\\(goto\\)\\>[ \t]*\\(\\sw+\\)?"
- '(1 font-lock-keyword-face)
- '(2 font-lock-function-name-face nil t))
-
- )
- "Keywords to hilight in BAT mode")
-
-;;; don't do it in Win-Emacs
-(if (boundp 'font-lock-defaults-alist)
- (add-to-list
- 'font-lock-defaults-alist
- (cons 'bat-mode
- (list 'bat-font-lock-keywords nil t nil nil))))
-
-(provide 'bat-mode)
-
-;;; batmode.el ends here
+++ /dev/null
-;;; bytecpat.el --- do recompilation for Emacs patch files.
-;;; This function is used by the patch files to update Emacs releases.
-
-(defun batch-byte-recompile-emacs ()
- "Recompile the Emacs `lisp' directory.
-This is used after installing the patches for a new version."
- (let ((load-path (list (expand-file-name "lisp"))))
- (byte-recompile-directory "lisp")))
-
-(defun batch-byte-compile-emacs ()
- "Compile new files installed in the Emacs `lisp' directory.
-This is used after installing the patches for a new version.
-It uses the command line arguments to specify the files to compile."
- (let ((load-path (list (expand-file-name "lisp"))))
- (batch-byte-compile)))
+++ /dev/null
-;;; cl.el --- Common-Lisp extensions for GNU Emacs Lisp.
-
-;; Copyright (C) 1987, 1988, 1989, 1992 Free Software Foundation, Inc.
-
-;; Author: Cesar Quiroz <quiroz@cs.rochester.edu>
-;; Keywords: extensions
-
-(defvar cl-version "3.0 07-February-1993")
-
-;; 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.
-
-;;; Commentary:
-
-;;; Notes from Rob Austein on his mods
-;; yaya:/usr/u/sra/cl/cl.el, 5-May-1991 16:01:34, sra
-;;
-;; Slightly hacked copy of cl.el 2.0 beta 27.
-;;
-;; Various minor performance improvements:
-;; a) Don't use MAPCAR when we're going to discard its results.
-;; b) Make various macros a little more clever about optimizing
-;; generated code in common cases.
-;; c) Fix DEFSETF to expand to the right code at compile-time.
-;; d) Make various macros cleverer about generating reasonable
-;; code when compiled, particularly forms like DEFSTRUCT which
-;; are usually used at top-level and thus are only compiled if
-;; you use Hallvard Furuseth's hacked bytecomp.el.
-;;
-;; New features: GETF, REMF, and REMPROP.
-;;
-;; Notes:
-;; 1) I'm sceptical about the FBOUNDP checks in SETF. Why should
-;; the SETF expansion fail because the SETF method isn't defined
-;; at compile time? Lisp is going to check for a binding at run-time
-;; anyway, so maybe we should just assume the user's right here.
-
-;;;; These are extensions to Emacs Lisp that provide some form of
-;;;; Common Lisp compatibility, beyond what is already built-in
-;;;; in Emacs Lisp.
-;;;;
-;;;; When developing them, I had the code spread among several files.
-;;;; This file 'cl.el' is a concatenation of those original files,
-;;;; minus some declarations that became redundant. The marks between
-;;;; the original files can be found easily, as they are lines that
-;;;; begin with four semicolons (as this does). The names of the
-;;;; original parts follow the four semicolons in uppercase, those
-;;;; names are GLOBAL, SYMBOLS, LISTS, SEQUENCES, CONDITIONALS,
-;;;; ITERATIONS, MULTIPLE VALUES, ARITH, SETF and DEFSTRUCT. If you
-;;;; add functions to this file, you might want to put them in a place
-;;;; that is compatible with the division above (or invent your own
-;;;; categories).
-;;;;
-;;;; To compile this file, make sure you load it first. This is
-;;;; because many things are implemented as macros and now that all
-;;;; the files are concatenated together one cannot ensure that
-;;;; declaration always precedes use.
-;;;;
-;;;; Bug reports, suggestions and comments,
-;;;; to quiroz@cs.rochester.edu
-
-\f
-;;;; GLOBAL
-;;;; This file provides utilities and declarations that are global
-;;;; to Common Lisp and so might be used by more than one of the
-;;;; other libraries. Especially, I intend to keep here some
-;;;; utilities that help parsing/destructuring some difficult calls.
-;;;;
-;;;;
-;;;; 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.
-
-;;; Code:
-
-;;; This version is due to Hallvard Furuseth (hallvard@ifi.uio.no, 6 Jul 91)
-(defmacro psetq (&rest args)
- "(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'."
- ;; check there is a reasonable number of forms
- (if (/= (% (length args) 2) 0)
- (error "Odd number of arguments to `psetq'"))
- (setq args (copy-sequence args)) ;for safety below
- (prog1 (cons 'setq args)
- (while (progn (if (not (symbolp (car args)))
- (error "`psetq' expected a symbol, found '%s'."
- (prin1-to-string (car args))))
- (cdr (cdr args)))
- (setcdr args (list (list 'prog1 (nth 1 args)
- (cons 'setq
- (setq args (cdr (cdr args))))))))))
-\f
-;;; utilities
-;;;
-;;; pair-with-newsyms takes a list and returns a list of lists of the
-;;; form (newsym form), such that a let* can then bind the evaluation
-;;; of the forms to the newsyms. The idea is to guarantee correct
-;;; order of evaluation of the subforms of a setf. It also returns a
-;;; list of the newsyms generated, in the corresponding order.
-
-(defun pair-with-newsyms (oldforms)
- "PAIR-WITH-NEWSYMS OLDFORMS
-The top-level components of the list oldforms are paired with fresh
-symbols, the pairings list and the newsyms list are returned."
- (do ((ptr oldforms (cdr ptr))
- (bindings '())
- (newsyms '()))
- ((endp ptr) (values (nreverse bindings) (nreverse newsyms)))
- (let ((newsym (gentemp)))
- (setq bindings (cons (list newsym (car ptr)) bindings))
- (setq newsyms (cons newsym newsyms)))))
-
-(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.
-The construction stops when the shorter list is exhausted."
- (do* ((p0 evens (cdr p0))
- (p1 odds (cdr p1))
- (even (car p0) (car p0))
- (odd (car p1) (car p1))
- (result '()))
- ((or (endp p0) (endp p1))
- (nreverse result))
- (setq result
- (cons odd (cons even result)))))
-
-(defun unzip-list (list)
- "Extract even and odd elements of LIST into two separate lists.
-The argument LIST is separated in two strands, the even and the odd
-numbered elements. Numbering starts with 0, so the first element
-belongs in EVENS. No check is made that there is an even number of
-elements to start with."
- (do* ((ptr list (cddr ptr))
- (this (car ptr) (car ptr))
- (next (cadr ptr) (cadr ptr))
- (evens '())
- (odds '()))
- ((endp ptr)
- (values (nreverse evens) (nreverse odds)))
- (setq evens (cons this evens))
- (setq odds (cons next odds))))
-\f
-(defun reassemble-argslists (argslists)
- "(reassemble-argslists ARGSLISTS) => a list of lists
-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
-shortest list is exhausted."
- (let* ((minlen (apply 'min (mapcar 'length argslists)))
- (result '()))
- (dotimes (i minlen (nreverse result))
- ;; capture all the elements at index i
- (setq result
- (cons (mapcar (function (lambda (sublist) (elt sublist i)))
- argslists)
- result)))))
-
-\f
-;;; Checking that a list of symbols contains no duplicates is a common
-;;; task when checking the legality of some macros. The check for 'eq
-;;; pairs can be too expensive, as it is quadratic on the length of
-;;; the list. I use a 4-pass, linear, counting approach. It surely
-;;; loses on small lists (less than 5 elements?), but should win for
-;;; larger lists. The fourth pass could be eliminated.
-;;; 10 dec 1986. Emacs Lisp has no REMPROP, so I just eliminated the
-;;; 4th pass.
-;;;
-;;; [22 April 1991, sra] REMPROP now in library, so restored 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."
- (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"))
- ;; pass 1: mark
- (dolist (x list)
- (put x propname 0))
- ;; pass 2: count
- (dolist (x list)
- (put x propname (1+ (get x propname))))
- ;; pass 3: collect
- (dolist (x list)
- (if (> (get x propname) 1)
- (setq duplicates (cons x duplicates))))
- ;; pass 4: unmark.
- (dolist (x list)
- (remprop x propname))
- ;; return result
- duplicates))
-
-;;;; end of cl-global.el
-\f
-;;;; SYMBOLS
-;;;; This file provides the gentemp function, which generates fresh
-;;;; symbols, plus some other minor Common Lisp symbol tools.
-;;;;
-;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986
-;;;; (quiroz@cs.rochester.edu)
-
-;;; Keywords. There are no packages in Emacs Lisp, so this is only a
-;;; kludge around to let things be "as if" a keyword package was around.
-
-(defmacro defkeyword (x &optional docstring)
- "Make symbol X a keyword (symbol whose value is itself).
-Optional second argument 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)))))
-
-(defun keywordp (sym)
- "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))
-
-(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)))))
-\f
-;;; Temporary symbols.
-;;;
-
-(defvar *gentemp-index* 0
- "Integer used by gentemp to produce new names.")
-
-(defvar *gentemp-prefix* "T$$_"
- "Names generated by gentemp begin with this string by default.")
-
-(defun gentemp (&optional prefix oblist)
- "Generate a fresh interned symbol.
-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)
- (setq oblist obarray)) ;default for the intern functions
- (let ((newsymbol nil)
- (newname))
- (while (not newsymbol)
- (setq newname (concat prefix *gentemp-index*))
- (setq *gentemp-index* (+ *gentemp-index* 1))
- (if (not (intern-soft newname oblist))
- (setq newsymbol (intern newname oblist))))
- newsymbol))
-\f
-(defvar *gensym-index* 0
- "Integer used by gensym to produce new names.")
-
-(defvar *gensym-prefix* "G$$_"
- "Names generated by gensym begin with this string by default.")
-
-(defun gensym (&optional prefix)
- "Generate a fresh uninterned symbol.
-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)
- (newname ""))
- (while (not newsymbol)
- (setq newname (concat prefix *gensym-index*))
- (setq *gensym-index* (+ *gensym-index* 1))
- (if (not (intern-soft newname))
- (setq newsymbol (make-symbol newname))))
- newsymbol))
-
-;;;; end of cl-symbols.el
-\f
-;;;; CONDITIONALS
-;;;; This file provides some of the conditional constructs of
-;;;; Common Lisp. Total compatibility is again impossible, as the
-;;;; 'if' form is different in both languages, so only a good
-;;;; approximation is desired.
-;;;;
-;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986
-;;;; (quiroz@cs.rochester.edu)
-
-;;; indentation info
-(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.
-
-(defmacro when (condition &rest body)
- "(when CONDITION . BODY) => evaluate BODY if CONDITION is true."
- (list* 'if (list 'not condition) '() body))
-
-(defmacro unless (condition &rest body)
- "(unless CONDITION . BODY) => evaluate BODY if CONDITION is false."
- (list* 'if condition '() body))
-\f
-;;; CASE and ECASE
-;;; CASE selects among several clauses, based on the value (evaluated)
-;;; of a expression and a list of (unevaluated) key values. ECASE is
-;;; the same, but signals an error if no clause is activated.
-
-(defmacro case (expr &rest cases)
- "(case EXPR . CASES) => evals EXPR, chooses from CASES on that value.
-EXPR -> any form
-CASES -> list of clauses, non empty
-CLAUSE -> HEAD . BODY
-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)
-BODY -> list of forms, implicit PROGN is built around it.
-EXPR is evaluated only once."
- (let* ((newsym (gentemp))
- (clauses (case-clausify cases newsym)))
- ;; convert case into a cond inside a let
- (list 'let
- (list (list newsym expr))
- (list* 'cond (nreverse clauses)))))
-
-(defmacro ecase (expr &rest cases)
- "(ecase EXPR . CASES) => like `case', but error if no case fits.
-`t'-clauses are not allowed."
- (let* ((newsym (gentemp))
- (clauses (case-clausify cases newsym)))
- ;; 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'"))
- ;; insert error-catching clause
- (setq clauses
- (cons
- (list 't (list 'error
- "ecase on %s = %s failed to take any branch"
- (list 'quote expr)
- (list 'prin1-to-string newsym)))
- clauses))
- ;; generate code as usual
- (list 'let
- (list (list newsym expr))
- (list* 'cond (nreverse clauses)))))
-
-\f
-(defun case-clausify (cases newsym)
- "CASE-CLAUSIFY CASES NEWSYM => clauses for a 'cond'
-Converts the CASES of a [e]case macro into cond clauses to be
-evaluated inside a let that binds NEWSYM. Returns the clauses in
-reverse order."
- (do* ((currentpos cases (cdr currentpos))
- (nextpos (cdr cases) (cdr nextpos))
- (curclause (car cases) (car currentpos))
- (result '()))
- ((endp currentpos) result)
- (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)))))))
-
-;;;; end of cl-conditionals.el
-\f
-;;;; ITERATIONS
-;;;; This file provides simple iterative macros (a la Common Lisp)
-;;;; constructed on the basis of let, let* and while, which are the
-;;;; primitive binding/iteration constructs of Emacs Lisp
-;;;;
-;;;; The Common Lisp iterations use to have a block named nil
-;;;; wrapped around them, and allow declarations at the beginning
-;;;; of their bodies and you can return a value using (return ...).
-;;;; Nothing of the sort exists in Emacs Lisp, so I haven't tried
-;;;; to imitate these behaviors.
-;;;;
-;;;; Other than the above, the semantics of Common Lisp are
-;;;; correctly reproduced to the extent this was reasonable.
-;;;;
-;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986
-;;;; (quiroz@cs.rochester.edu)
-
-;;; some lisp-indentation information
-(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)
-
-\f
-(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 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."
- ;; check the syntax of the macro
- (and (check-do-stepforms stepforms)
- (check-do-endforms endforms))
- ;; construct emacs-lisp equivalent
- (let ((initlist (extract-do-inits stepforms))
- (steplist (extract-do-steps stepforms))
- (endcond (car endforms))
- (endbody (cdr endforms)))
- (cons 'let (cons initlist
- (cons (cons 'while (cons (list 'not endcond)
- (append body steplist)))
- (append endbody))))))
-
-\f
-(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 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 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))
- ;; construct emacs-lisp equivalent
- (let ((initlist (extract-do-inits stepforms))
- (steplist (extract-do*-steps stepforms))
- (endcond (car endforms))
- (endbody (cdr endforms)))
- (cons 'let* (cons initlist
- (cons (cons 'while (cons (list 'not endcond)
- (append body steplist)))
- (append endbody))))))
-
-\f
-;;; DO and DO* share the syntax checking functions that follow.
-
-(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))
- (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)))
-
-(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))))
-
-(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."
- (mapcar
- (function
- (lambda (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."
- (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."
- (list (cons 'setq (select-stepping-forms forms))))
-
-(defun select-stepping-forms (forms)
- "Separate only the forms that cause stepping."
- (let ((result '()) ;ends up being (... var form ...)
- (ptr forms) ;to traverse the forms
- entry ;to explore each form in turn
- )
- (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))))
- (setq ptr (cdr ptr))) ;step in the list of forms
- (nreverse result)))
-\f
-;;; 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
-RESULTFORM is evaluated."
- ;; check sanity
- (cond
- ((nlistp stepform)
- (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'"
- (prin1-to-string (car stepform))))
- ((> (length stepform) 3)
- (error "too many components in stepform `%s'"
- (prin1-to-string stepform))))
- ;; generate code
- (let* ((var (car stepform))
- (listform (cadr stepform))
- (resultform (caddr stepform))
- (listsym (gentemp)))
- (nconc
- (list 'let (list var (list listsym listform))
- (nconc
- (list 'while listsym
- (list 'setq
- var (list 'car listsym)
- listsym (list 'cdr listsym)))
- body))
- (and resultform
- (cons (list 'setq var nil)
- (list resultform))))))
-
-(defmacro dotimes (stepform &rest body)
- "(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
-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
-defaults to nil."
- ;; check sanity
- (cond
- ((nlistp stepform)
- (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'"
- (prin1-to-string (car stepform))))
- ((> (length stepform) 3)
- (error "too many components in stepform `%s'"
- (prin1-to-string stepform))))
- ;; generate code
- (let* ((var (car stepform))
- (countform (cadr stepform))
- (resultform (caddr stepform))
- (testsym (if (consp countform) (gentemp) countform)))
- (nconc
- (list
- 'let (cons (list var -1)
- (and (not (eq countform testsym))
- (list (list testsym countform))))
- (nconc
- (list 'while (list '< (list 'setq var (list '1+ var)) testsym))
- body))
- (and resultform (list resultform)))))
-\f
-(defmacro do-symbols (stepform &rest body)
- "(do_symbols (VAR [OBARRAY [RESULTFORM]]) . BODY)
-The VAR is bound to each of the symbols in OBARRAY (def. obarray) and
-the BODY is repeatedly performed for each of those bindings. At the
-end, RESULTFORM (def. nil) is evaluated and its value returned.
-During this last evaluation, the VAR is still bound and its value is nil.
-See also the function `mapatoms'."
- ;; check sanity
- (cond
- ((nlistp stepform)
- (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'"
- (prin1-to-string (car stepform))))
- ((> (length stepform) 3)
- (error "too many components in stepform `%s'"
- (prin1-to-string stepform))))
- ;; generate code
- (let* ((var (car stepform))
- (oblist (cadr stepform))
- (resultform (caddr stepform)))
- (list 'progn
- (list 'mapatoms
- (list 'function
- (cons 'lambda (cons (list var) body)))
- oblist)
- (list 'let
- (list (list var nil))
- resultform))))
-
-
-(defmacro do-all-symbols (stepform &rest body)
- "(do-all-symbols (VAR [RESULTFORM]) . BODY)
-Is the same as (do-symbols (VAR obarray RESULTFORM) . BODY)."
- (list*
- 'do-symbols
- (list (car stepform) 'obarray (cadr stepform))
- body))
-\f
-(defmacro loop (&rest body)
- "(loop . BODY) repeats BODY indefinitely and does not return.
-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")
- ;; ok, it is a list, check for atomic components
- (mapcar
- (function (lambda (component)
- (if (nlistp component)
- (error "components of `loop' should be lists"))))
- body)
- ;; build the infinite loop
- (cons 'while (cons 't body))))
-
-;;;; end of cl-iterations.el
-\f
-;;;; LISTS
-;;;; This file provides some of the lists machinery of Common-Lisp
-;;;; in a way compatible with Emacs Lisp. Especially, see the the
-;;;; typical c[ad]*r functions.
-;;;;
-;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986
-;;;; (quiroz@cs.rochester.edu)
-
-;;; Synonyms for list functions
-(defsubst first (x)
- "Synonym for `car'"
- (car x))
-
-(defsubst second (x)
- "Return the second element of the list LIST."
- (nth 1 x))
-
-(defsubst third (x)
- "Return the third element of the list LIST."
- (nth 2 x))
-
-(defsubst fourth (x)
- "Return the fourth element of the list LIST."
- (nth 3 x))
-
-(defsubst fifth (x)
- "Return the fifth element of the list LIST."
- (nth 4 x))
-
-(defsubst sixth (x)
- "Return the sixth element of the list LIST."
- (nth 5 x))
-
-(defsubst seventh (x)
- "Return the seventh element of the list LIST."
- (nth 6 x))
-
-(defsubst eighth (x)
- "Return the eighth element of the list LIST."
- (nth 7 x))
-
-(defsubst ninth (x)
- "Return the ninth element of the list LIST."
- (nth 8 x))
-
-(defsubst tenth (x)
- "Return the tenth element of the list LIST."
- (nth 9 x))
-
-(defsubst rest (x)
- "Synonym for `cdr'"
- (cdr x))
-\f
-(defsubst endp (x)
- "t if X is nil, nil if X is a cons; error otherwise."
- (if (listp x)
- (null x)
- (error "endp received a non-cons, non-null argument `%s'"
- (prin1-to-string x))))
-
-(defun last (x)
- "Returns the last link in the list LIST."
- (if (nlistp x)
- (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)))
-
-(defun list-length (x) ;taken from CLtL sect. 15.2
- "Returns the length of a non-circular list, or `nil' for a circular one."
- (do ((n 0) ;counter
- (fast x (cddr fast)) ;fast pointer, leaps by 2
- (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
-\f
-(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."
- (if (null n) (setq n 1))
- (nreverse (nthcdr n (reverse list)))) ;optim. due to macrakis@osf.org
-
-;;; This version due to Aaron Larson (alarson@src.honeywell.com, 26 Jul 91)
-(defun list* (arg &rest others)
- "Return a new list containing the first arguments consed onto the last arg.
-Thus, (list* 1 2 3 '(a b)) returns (1 2 3 a b)."
- (if (null others)
- arg
- (let* ((others (cons arg (copy-sequence others)))
- (a others))
- (while (cdr (cdr a))
- (setq a (cdr a)))
- (setcdr a (car (cdr a)))
- others)))
-
-(defun adjoin (item list)
- "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)))
-
-(defun ldiff (list sublist)
- "Return a new list like LIST but sans SUBLIST.
-SUBLIST must be one of the links in LIST; otherwise the value is LIST itself."
- (do ((result '())
- (curcons list (cdr curcons)))
- ((or (endp curcons) (eq curcons sublist))
- (reverse result))
- (setq result (cons (car curcons) result))))
-\f
-;;; 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.
-
-(defsubst caar (X)
- "Return the car of the car of X."
- (car (car X)))
-
-(defsubst cadr (X)
- "Return the car of the cdr of X."
- (car (cdr X)))
-
-(defsubst cdar (X)
- "Return the cdr of the car of X."
- (cdr (car X)))
-
-(defsubst cddr (X)
- "Return the cdr of the cdr of X."
- (cdr (cdr X)))
-
-(defsubst caaar (X)
- "Return the car of the car of the car of X."
- (car (car (car X))))
-
-(defsubst caadr (X)
- "Return the car of the car of the cdr of X."
- (car (car (cdr X))))
-
-(defsubst cadar (X)
- "Return the car of the cdr of the car of X."
- (car (cdr (car X))))
-
-(defsubst cdaar (X)
- "Return the cdr of the car of the car of X."
- (cdr (car (car X))))
-
-(defsubst caddr (X)
- "Return the car of the cdr of the cdr of X."
- (car (cdr (cdr X))))
-
-(defsubst cdadr (X)
- "Return the cdr of the car of the cdr of X."
- (cdr (car (cdr X))))
-
-(defsubst cddar (X)
- "Return the cdr of the cdr of the car of X."
- (cdr (cdr (car X))))
-
-(defsubst cdddr (X)
- "Return the cdr of the cdr of the cdr of X."
- (cdr (cdr (cdr X))))
-
-(defsubst caaaar (X)
- "Return the car of the car of the car of the car of X."
- (car (car (car (car X)))))
-
-(defsubst caaadr (X)
- "Return the car of the car of the car of the cdr of X."
- (car (car (car (cdr X)))))
-
-(defsubst caadar (X)
- "Return the car of the car of the cdr of the car of X."
- (car (car (cdr (car X)))))
-
-(defsubst cadaar (X)
- "Return the car of the cdr of the car of the car of X."
- (car (cdr (car (car X)))))
-
-(defsubst cdaaar (X)
- "Return the cdr of the car of the car of the car of X."
- (cdr (car (car (car X)))))
-
-(defsubst caaddr (X)
- "Return the car of the car of the cdr of the cdr of X."
- (car (car (cdr (cdr X)))))
-
-(defsubst cadadr (X)
- "Return the car of the cdr of the car of the cdr of X."
- (car (cdr (car (cdr X)))))
-
-(defsubst cdaadr (X)
- "Return the cdr of the car of the car of the cdr of X."
- (cdr (car (car (cdr X)))))
-
-(defsubst caddar (X)
- "Return the car of the cdr of the cdr of the car of X."
- (car (cdr (cdr (car X)))))
-
-(defsubst cdadar (X)
- "Return the cdr of the car of the cdr of the car of X."
- (cdr (car (cdr (car X)))))
-
-(defsubst cddaar (X)
- "Return the cdr of the cdr of the car of the car of X."
- (cdr (cdr (car (car X)))))
-
-(defsubst cadddr (X)
- "Return the car of the cdr of the cdr of the cdr of X."
- (car (cdr (cdr (cdr X)))))
-
-(defsubst cddadr (X)
- "Return the cdr of the cdr of the car of the cdr of X."
- (cdr (cdr (car (cdr X)))))
-
-(defsubst cdaddr (X)
- "Return the cdr of the car of the cdr of the cdr of X."
- (cdr (car (cdr (cdr X)))))
-
-(defsubst cdddar (X)
- "Return the cdr of the cdr of the cdr of the car of X."
- (cdr (cdr (cdr (car X)))))
-
-(defsubst cddddr (X)
- "Return the cdr of the cdr of the cdr of the cdr of X."
- (cdr (cdr (cdr (cdr X)))))
-\f
-;;; some inverses of the accessors are needed for setf purposes
-
-(defsubst setnth (n list newval)
- "Set (nth N LIST) to NEWVAL. Returns NEWVAL."
- (rplaca (nthcdr n list) newval))
-
-(defun setnthcdr (n list newval)
- "(setnthcdr N LIST NEWVAL) => NEWVAL
-As a side effect, sets the Nth cdr of LIST to NEWVAL."
- (when (< n 0)
- (error "N must be 0 or greater, not %d" n))
- (while (> n 0)
- (setq list (cdr list)
- n (- n 1)))
- ;; here only if (zerop n)
- (rplaca list (car newval))
- (rplacd list (cdr newval))
- newval)
-\f
-;;; A-lists machinery
-
-(defsubst acons (key item alist)
- "Return a new alist with KEY paired with ITEM; otherwise like ALIST.
-Does not copy ALIST."
- (cons (cons key item) alist))
-
-(defun pairlis (keys data &optional alist)
- "Return a new alist with each elt of KEYS paired with an elt of DATA;
-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"))
- (do* ;;collect keys and data in front of alist
- ((kptr keys (cdr kptr)) ;traverses the keys
- (dptr data (cdr dptr)) ;traverses the data
- (key (car kptr) (car kptr)) ;current key
- (item (car dptr) (car dptr)) ;current data item
- (result alist))
- ((endp kptr) result)
- (setq result (acons key item result))))
-
-;;;; end of cl-lists.el
-\f
-;;;; SEQUENCES
-;;;; Emacs Lisp provides many of the 'sequences' functionality of
-;;;; Common Lisp. This file provides a few things that were left out.
-;;;;
-
-
-(defkeyword :test "Used to designate positive (selection) tests.")
-(defkeyword :test-not "Used to designate negative (rejection) tests.")
-(defkeyword :key "Used to designate component extractions.")
-(defkeyword :predicate "Used to define matching of sequence components.")
-(defkeyword :start "Inclusive low index in sequence")
-(defkeyword :end "Exclusive high index in sequence")
-(defkeyword :start1 "Inclusive low index in first of two sequences.")
-(defkeyword :start2 "Inclusive low index in second of two sequences.")
-(defkeyword :end1 "Exclusive high index in first of two sequences.")
-(defkeyword :end2 "Exclusive high index in second of two sequences.")
-(defkeyword :count "Number of elements to affect.")
-(defkeyword :from-end "T when counting backwards.")
-(defkeyword :initial-value "For the syntax of #'reduce")
-\f
-(defun some (pred seq &rest moreseqs)
- "Test PREDICATE on each element of SEQUENCE; is it ever non-nil?
-Extra args are additional sequences; PREDICATE gets one arg from each
-sequence and we advance down all the sequences together in lock-step.
-A sequence means either a list or a vector."
- (let ((args (reassemble-argslists (list* seq moreseqs))))
- (do* ((ready nil) ;flag: return when t
- (result nil) ;resulting value
- (applyval nil) ;result of applying pred once
- (remaining args
- (cdr remaining)) ;remaining argument sets
- (current (car remaining) ;current argument set
- (car remaining)))
- ((or ready (endp remaining)) result)
- (setq applyval (apply pred current))
- (when applyval
- (setq ready t)
- (setq result applyval)))))
-
-(defun every (pred seq &rest moreseqs)
- "Test PREDICATE on each element of SEQUENCE; is it always non-nil?
-Extra args are additional sequences; PREDICATE gets one arg from each
-sequence and we advance down all the sequences together in lock-step.
-A sequence means either a list or a vector."
- (let ((args (reassemble-argslists (list* seq moreseqs))))
- (do* ((ready nil) ;flag: return when t
- (result t) ;resulting value
- (applyval nil) ;result of applying pred once
- (remaining args
- (cdr remaining)) ;remaining argument sets
- (current (car remaining) ;current argument set
- (car remaining)))
- ((or ready (endp remaining)) result)
- (setq applyval (apply pred current))
- (unless applyval
- (setq ready t)
- (setq result nil)))))
-\f
-(defun notany (pred seq &rest moreseqs)
- "Test PREDICATE on each element of SEQUENCE; is it always nil?
-Extra args are additional sequences; PREDICATE gets one arg from each
-sequence and we advance down all the sequences together in lock-step.
-A sequence means either a list or a vector."
- (let ((args (reassemble-argslists (list* seq moreseqs))))
- (do* ((ready nil) ;flag: return when t
- (result t) ;resulting value
- (applyval nil) ;result of applying pred once
- (remaining args
- (cdr remaining)) ;remaining argument sets
- (current (car remaining) ;current argument set
- (car remaining)))
- ((or ready (endp remaining)) result)
- (setq applyval (apply pred current))
- (when applyval
- (setq ready t)
- (setq result nil)))))
-
-(defun notevery (pred seq &rest moreseqs)
- "Test PREDICATE on each element of SEQUENCE; is it sometimes nil?
-Extra args are additional sequences; PREDICATE gets one arg from each
-sequence and we advance down all the sequences together in lock-step.
-A sequence means either a list or a vector."
- (let ((args (reassemble-argslists (list* seq moreseqs))))
- (do* ((ready nil) ;flag: return when t
- (result nil) ;resulting value
- (applyval nil) ;result of applying pred once
- (remaining args
- (cdr remaining)) ;remaining argument sets
- (current (car remaining) ;current argument set
- (car remaining)))
- ((or ready (endp remaining)) result)
- (setq applyval (apply pred current))
- (unless applyval
- (setq ready t)
- (setq result t)))))
-\f
-;;; 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))))))
-\f
-;;; an inverse of elt is needed for setf purposes
-
-(defun setelt (seq n newval)
- "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)))))))
-\f
-;;; Testing with keyword arguments.
-;;;
-;;; Many of the sequence functions use keywords to denote some stylized
-;;; form of selecting entries in a sequence. The involved arguments
-;;; are collected with a &rest marker (as Emacs Lisp doesn't have a &key
-;;; marker), then they are passed to build-klist, who
-;;; 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
-Extract value associated with KEY in KLIST (return DEFAULT if nil)."
- (let ((retrieved (cdr (assq 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 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
-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))))))
-
-(defun elt-satisfies-if-p (item klist)
- "(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)))
- (funcall predicate (funcall keyfn item))))
-
-(defun elt-satisfies-if-not-p (item klist)
- "(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)))
- (not (funcall predicate (funcall keyfn item)))))
-
-(defun elts-match-under-klist-p (e1 e2 klist)
- "(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))))))
-\f
-;;; 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-hook 1)
-
-\f
-;;; 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 successive 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)))))
-
-;;;; end of cl-sequences.el
-\f
-;;;; 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 cl-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 allegedly for speed, BLAH
- (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)))))
-\f
-;;;; MULTIPLE VALUES
-;;;; This package approximates the behavior of the multiple-values
-;;;; forms of Common Lisp.
-;;;;
-;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986
-;;;; (quiroz@cs.rochester.edu)
-
-;;; Lisp indentation information
-(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
- "Most recently returned multiple-values")
-(defvar *mvalues-count* nil
- "Count of multiple-values returned, or nil if the mechanism was not used")
-\f
-;;; values is the standard multiple-value-return form. Must be the
-;;; last thing evaluated inside a function. If the caller is not
-;;; expecting multiple values, only the first one is passed. (values)
-;;; is the same as no-values returned (unaware callers see nil). The
-;;; alternative (values-list <list>) is just a convenient shorthand
-;;; and complements multiple-value-list.
-
-(defun values (&rest val-forms)
- "Produce multiple values (zero or more). Each arg is one value.
-See also `multiple-value-bind', which is one way to examine the
-multiple values produced by a form. If the containing form or caller
-does not check specially to see multiple values, it will see only
-the first value."
- (setq *mvalues-values* val-forms)
- (setq *mvalues-count* (length *mvalues-values*))
- (car *mvalues-values*))
-
-(defun values-list (&optional val-forms)
- "Produce multiple values (zero or more). Each element of LIST is one value.
-This is equivalent to (apply 'values LIST)."
- (cond ((nlistp val-forms)
- (error "Argument to values-list must be a list, not `%s'"
- (prin1-to-string val-forms))))
- (setq *mvalues-values* val-forms)
- (setq *mvalues-count* (length *mvalues-values*))
- (car *mvalues-values*))
-\f
-;;; Callers that want to see the multiple values use these macros.
-
-(defmacro multiple-value-list (form)
- "Execute FORM and return a list of all the (multiple) values FORM produces.
-See `values' and `multiple-value-bind'."
- (list 'progn
- (list 'setq '*mvalues-count* nil)
- (list 'let (list (list 'it '(gensym)))
- (list 'set 'it form)
- (list 'if '*mvalues-count*
- (list 'copy-sequence '*mvalues-values*)
- (list 'progn
- (list 'setq '*mvalues-count* 1)
- (list 'setq '*mvalues-values*
- (list 'list (list 'symbol-value 'it)))
- (list 'copy-sequence '*mvalues-values*))))))
-
-(defmacro multiple-value-call (function &rest args)
- "Call FUNCTION on all the values produced by the remaining arguments.
-(multiple-value-call '+ (values 1 2) (values 3 4)) is 10."
- (let* ((result (gentemp))
- (arg (gentemp)))
- (list 'apply (list 'function (eval function))
- (list 'let* (list (list result '()))
- (list 'dolist (list arg (list 'quote args) result)
- (list 'setq result
- (list 'append
- result
- (list 'multiple-value-list
- (list 'eval arg)))))))))
-
-(defmacro multiple-value-bind (vars form &rest body)
- "Bind VARS to the (multiple) values produced by FORM, then do BODY.
-VARS is a list of variables; each is bound to one of FORM's values.
-If FORM doesn't make enough values, the extra variables are bound to nil.
-(Ordinary forms produce only one value; to produce more, use `values'.)
-Extra values are ignored.
-BODY (zero or more forms) is executed with the variables bound,
-then the bindings are unwound."
- (let* ((vals (gentemp)) ;name for intermediate values
- (clauses (mv-bind-clausify ;convert into clauses usable
- vars vals))) ; in a let form
- (list* 'let*
- (cons (list vals (list 'multiple-value-list form))
- clauses)
- body)))
-\f
-(defmacro multiple-value-setq (vars form)
- "Set VARS to the (multiple) values produced by FORM.
-VARS is a list of variables; each is set to one of FORM's values.
-If FORM doesn't make enough values, the extra variables are set to nil.
-(Ordinary forms produce only one value; to produce more, use `values'.)
-Extra values are ignored."
- (let* ((vals (gentemp)) ;name for intermediate values
- (clauses (mv-bind-clausify ;convert into clauses usable
- vars vals))) ; in a setq (after append).
- (list 'let*
- (list (list vals (list 'multiple-value-list form)))
- (cons 'setq (apply (function append) clauses)))))
-
-(defmacro multiple-value-prog1 (form &rest body)
- "Evaluate FORM, then BODY, then produce the same values FORM produced.
-Thus, (multiple-value-prog1 (values 1 2) (foobar)) produces values 1 and 2.
-This is like `prog1' except that `prog1' would produce only one value,
-which would be the first of FORM's values."
- (let* ((heldvalues (gentemp)))
- (cons 'let*
- (cons (list (list heldvalues (list 'multiple-value-list form)))
- (append body (list (list 'values-list heldvalues)))))))
-
-;;; utility functions
-;;;
-;;; mv-bind-clausify makes the pairs needed to have the variables in
-;;; the variable list correspond with the values returned by the form.
-;;; vals is a fresh symbol that intervenes in all the bindings.
-
-(defun mv-bind-clausify (vars vals)
- "MV-BIND-CLAUSIFY VARS VALS => Auxiliary list
-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'"
- (prin1-to-string vars)))
- (let* ((nvars (length vars))
- (clauses '()))
- (dotimes (n nvars clauses)
- (setq clauses (cons (list (nth n vars)
- (list 'nth n vals)) clauses)))))
-
-;;;; end of cl-multiple-values.el
-\f
-;;;; ARITH
-;;;; This file provides integer arithmetic extensions. Although
-;;;; Emacs Lisp doesn't really support anything but integers, that
-;;;; has still to be made to look more or less standard.
-;;;;
-;;;;
-;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986
-;;;; (quiroz@cs.rochester.edu)
-
-
-(defsubst plusp (number)
- "True if NUMBER is strictly greater than zero."
- (> number 0))
-
-(defsubst minusp (number)
- "True if NUMBER is strictly less than zero."
- (< number 0))
-
-(defsubst oddp (number)
- "True if INTEGER is not divisible by 2."
- (/= (% number 2) 0))
-
-(defsubst evenp (number)
- "True if INTEGER is divisible by 2."
- (= (% number 2) 0))
-
-(defsubst abs (number)
- "Return the absolute value of NUMBER."
- (if (< number 0)
- (- number)
- number))
-
-(defsubst signum (number)
- "Return -1, 0 or 1 according to the sign of NUMBER."
- (cond ((< number 0)
- -1)
- ((> number 0)
- 1)
- (t ;exactly zero
- 0)))
-\f
-(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)) ;successive 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.
-The arguments must be integers and there must be at least one of them."
- (let ((howmany (length more))
- (a integer)
- (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))))))))
-\f
-(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)))))
-\f
-(defun cl-floor (number &optional divisor)
- "Divide DIVIDEND by DIVISOR, rounding toward minus infinity.
-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)
- (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)))))))))))
-
-(defun cl-ceiling (number &optional divisor)
- "Divide DIVIDEND by DIVISOR, rounding toward plus infinity.
-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)
- (cond ((zerop s)
- (values 0 0))
- ((plusp s)
- (values (+ q 1) (- r divisor)))
- (t
- (values (- q) (+ number (* q divisor)))))))))
-\f
-(defun cl-truncate (number &optional divisor)
- "Divide DIVIDEND by DIVISOR, rounding toward zero.
-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)
- (cond ((zerop s)
- (values 0 0))
- ((plusp s) ;same as floor
- (values q r))
- (t ;same as ceiling
- (values (- q) (+ number (* q divisor)))))))))
-
-(defun cl-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))))))
-\f
-;;; These two functions access the implementation-dependent representation of
-;;; the multiple value returns.
-
-(defun cl-mod (number divisor)
- "Return remainder of X by Y (rounding quotient toward minus infinity).
-That is, the remainder goes with the quotient produced by `cl-floor'.
-Emacs Lisp hint:
-If you know that both arguments are positive, use `%' instead for speed."
- (cl-floor number divisor)
- (cadr *mvalues-values*))
-
-(defun rem (number divisor)
- "Return remainder of X by Y (rounding quotient toward zero).
-That is, the remainder goes with the quotient produced by `cl-truncate'.
-Emacs Lisp hint:
-If you know that both arguments are positive, use `%' instead for speed."
- (cl-truncate number divisor)
- (cadr *mvalues-values*))
-\f
-;;; internal utilities
-;;;
-;;; safe-idiv performs an integer division with positive numbers only.
-;;; It is known that some machines/compilers implement weird remainder
-;;; 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|, S is the sign of A/B, R is the rest A - S*Q*B."
- ;; (unless (and (numberp a) (numberp b))
- ;; (error "arguments to `safe-idiv' must be numbers"))
- ;; (when (zerop b)
- ;; (error "cannot divide %d by zero" a))
- (let* ((q (/ (abs a) (abs b)))
- (s (* (signum a) (signum b)))
- (r (- a (* s q b))))
- (values q r s)))
-
-;;;; end of cl-arith.el
-\f
-;;;; SETF
-;;;; This file provides the setf macro and friends. The purpose has
-;;;; been modest, only the simplest defsetf forms are accepted.
-;;;; Use it and enjoy.
-;;;;
-;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986
-;;;; (quiroz@cs.rochester.edu)
-
-
-(defkeyword :setf-update-fn
- "Property, its value is the function setf must invoke to update a
-generalized variable whose access form is a function call of the
-symbol that has this property.")
-
-(defkeyword :setf-update-doc
- "Property of symbols that have a `defsetf' update function on them,
-installed by the `defsetf' from its optional third argument.")
-\f
-(defmacro setf (&rest pairs)
- "Generalized `setq' that can set things other than variable values.
-A use of `setf' looks like (setf {PLACE VALUE}...).
-The behavior of (setf PLACE VALUE) is to access the generalized variable
-at PLACE and store VALUE there. It returns VALUE. If there is more
-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)))
- ;; dispatch on the type of update function
- (cond ((and (consp updatefn) (eq (car updatefn) 'lambda))
- (cons 'funcall
- (cons (list 'function updatefn)
- (append (cdr place) (list value)))))
- ((and (symbolp updatefn)
- (fboundp updatefn)
- (let ((defn (symbol-function updatefn)))
- (or (subrp defn)
- (and (consp defn)
- (or (eq (car defn) 'lambda)
- (eq (car defn) 'macro))))))
- (cons updatefn (append (cdr place) (list value))))
- (t
- (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)))))))))
-\f
-(defmacro defsetf (accessfn updatefn &optional docstring)
- "Define how `setf' works on a certain kind of generalized variable.
-A use of `defsetf' looks like (defsetf ACCESSFN UPDATEFN [DOCSTRING]).
-ACCESSFN is a symbol. UPDATEFN is a function or macro which takes
-one more argument than ACCESSFN does. DEFSETF defines the translation
-of (SETF (ACCESFN . ARGS) NEWVAL) to be a form like (UPDATEFN ARGS... NEWVAL).
-The function UPDATEFN must return its last arg, after performing the
-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'"
- (prin1-to-string accessfn)))
- ;; update properties
- (list 'progn
- (list 'eval-and-compile
- (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)))
-\f
-;;; This section provides the "default" setfs for Common-Emacs-Lisp
-;;; The user will not normally add anything to this, although
-;;; defstruct will introduce new ones as a matter of fact.
-;;;
-;;; Apply is a special case. The Common Lisp
-;;; standard makes the case of apply be useful when the user writes
-;;; something like (apply #'name ...), Emacs Lisp doesn't have the #
-;;; stuff, but it has (function ...). Notice that V18 includes a new
-;;; apply: this file is compatible with V18 and pre-V18 Emacses.
-
-;;; INCOMPATIBILITY: the SETF macro evaluates its arguments in the
-;;; (correct) left to right sequence *before* checking for apply
-;;; methods (which should really be an special case inside setf). Due
-;;; to this, the lambda expression defsetf'd to apply will succeed in
-;;; applying the right function even if the name was not quoted, but
-;;; computed! That extension is not Common Lisp (nor is particularly
-;;; useful, I think).
-
-(defsetf apply
- (lambda (&rest args)
- ;; disassemble the calling form
- ;; "(((quote fn) x1 x2 ... xn) val)" (function instead of quote, too)
- (let* ((fnform (car args)) ;functional form
- (applyargs (append ;arguments "to apply fnform"
- (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)))))
- "`apply' is a special case for `setf'")
-
-\f
-(defsetf aref
- aset
- "`setf' inversion for `aref'")
-
-(defsetf nth
- setnth
- "`setf' inversion for `nth'")
-
-(defsetf nthcdr
- setnthcdr
- "`setf' inversion for `nthcdr'")
-
-(defsetf elt
- setelt
- "`setf' inversion for `elt'")
-
-(defsetf first
- (lambda (list val) (setnth 0 list val))
- "`setf' inversion for `first'")
-
-(defsetf second
- (lambda (list val) (setnth 1 list val))
- "`setf' inversion for `second'")
-
-(defsetf third
- (lambda (list val) (setnth 2 list val))
- "`setf' inversion for `third'")
-
-(defsetf fourth
- (lambda (list val) (setnth 3 list val))
- "`setf' inversion for `fourth'")
-
-(defsetf fifth
- (lambda (list val) (setnth 4 list val))
- "`setf' inversion for `fifth'")
-
-(defsetf sixth
- (lambda (list val) (setnth 5 list val))
- "`setf' inversion for `sixth'")
-
-(defsetf seventh
- (lambda (list val) (setnth 6 list val))
- "`setf' inversion for `seventh'")
-\f
-(defsetf eighth
- (lambda (list val) (setnth 7 list val))
- "`setf' inversion for `eighth'")
-
-(defsetf ninth
- (lambda (list val) (setnth 8 list val))
- "`setf' inversion for `ninth'")
-
-(defsetf tenth
- (lambda (list val) (setnth 9 list val))
- "`setf' inversion for `tenth'")
-
-(defsetf rest
- (lambda (list val) (setcdr list val))
- "`setf' inversion for `rest'")
-
-(defsetf car setcar "Replace the car of a cons")
-
-(defsetf cdr setcdr "Replace the cdr of a cons")
-
-(defsetf caar
- (lambda (list val) (setcar (nth 0 list) val))
- "`setf' inversion for `caar'")
-
-(defsetf cadr
- (lambda (list val) (setcar (cdr list) val))
- "`setf' inversion for `cadr'")
-
-(defsetf cdar
- (lambda (list val) (setcdr (car list) val))
- "`setf' inversion for `cdar'")
-
-(defsetf cddr
- (lambda (list val) (setcdr (cdr list) val))
- "`setf' inversion for `cddr'")
-
-(defsetf caaar
- (lambda (list val) (setcar (caar list) val))
- "`setf' inversion for `caaar'")
-
-(defsetf caadr
- (lambda (list val) (setcar (cadr list) val))
- "`setf' inversion for `caadr'")
-
-(defsetf cadar
- (lambda (list val) (setcar (cdar list) val))
- "`setf' inversion for `cadar'")
-\f
-(defsetf cdaar
- (lambda (list val) (setcdr (caar list) val))
- "`setf' inversion for `cdaar'")
-
-(defsetf caddr
- (lambda (list val) (setcar (cddr list) val))
- "`setf' inversion for `caddr'")
-
-(defsetf cdadr
- (lambda (list val) (setcdr (cadr list) val))
- "`setf' inversion for `cdadr'")
-
-(defsetf cddar
- (lambda (list val) (setcdr (cdar list) val))
- "`setf' inversion for `cddar'")
-
-(defsetf cdddr
- (lambda (list val) (setcdr (cddr list) val))
- "`setf' inversion for `cdddr'")
-
-(defsetf caaaar
- (lambda (list val) (setcar (caaar list) val))
- "`setf' inversion for `caaaar'")
-
-(defsetf caaadr
- (lambda (list val) (setcar (caadr list) val))
- "`setf' inversion for `caaadr'")
-
-(defsetf caadar
- (lambda (list val) (setcar (cadar list) val))
- "`setf' inversion for `caadar'")
-
-(defsetf cadaar
- (lambda (list val) (setcar (cdaar list) val))
- "`setf' inversion for `cadaar'")
-
-(defsetf cdaaar
- (lambda (list val) (setcdr (caar list) val))
- "`setf' inversion for `cdaaar'")
-
-(defsetf caaddr
- (lambda (list val) (setcar (caddr list) val))
- "`setf' inversion for `caaddr'")
-\f
-(defsetf cadadr
- (lambda (list val) (setcar (cdadr list) val))
- "`setf' inversion for `cadadr'")
-
-(defsetf cdaadr
- (lambda (list val) (setcdr (caadr list) val))
- "`setf' inversion for `cdaadr'")
-
-(defsetf caddar
- (lambda (list val) (setcar (cddar list) val))
- "`setf' inversion for `caddar'")
-
-(defsetf cdadar
- (lambda (list val) (setcdr (cadar list) val))
- "`setf' inversion for `cdadar'")
-
-(defsetf cddaar
- (lambda (list val) (setcdr (cdaar list) val))
- "`setf' inversion for `cddaar'")
-
-(defsetf cadddr
- (lambda (list val) (setcar (cdddr list) val))
- "`setf' inversion for `cadddr'")
-
-(defsetf cddadr
- (lambda (list val) (setcdr (cdadr list) val))
- "`setf' inversion for `cddadr'")
-
-(defsetf cdaddr
- (lambda (list val) (setcdr (caddr list) val))
- "`setf' inversion for `cdaddr'")
-
-(defsetf cdddar
- (lambda (list val) (setcdr (cddar list) val))
- "`setf' inversion for `cdddar'")
-
-(defsetf cddddr
- (lambda (list val) (setcdr (cddr list) val))
- "`setf' inversion for `cddddr'")
-
-(defsetf get put "`setf' inversion for `get' is `put'")
-
-(defsetf symbol-function fset
- "`setf' inversion for `symbol-function' is `fset'")
-
-(defsetf symbol-plist setplist
- "`setf' inversion for `symbol-plist' is `setplist'")
-
-(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?
-\f
-;;; Modify macros
-;;;
-;;; It could be nice to implement define-modify-macro, but I don't
-;;; think it really pays.
-
-(defmacro incf (ref &optional delta)
- "(incf REF [DELTA]) -> increment the g.v. REF by DELTA (default 1)"
- (if (null delta)
- (setq delta 1))
- (list 'setf ref (list '+ ref delta)))
-
-(defmacro decf (ref &optional delta)
- "(decf REF [DELTA]) -> decrement the g.v. REF by DELTA (default 1)"
- (if (null delta)
- (setq delta 1))
- (list 'setf ref (list '- ref delta)))
-
-(defmacro push (item ref)
- "(push ITEM REF) -> cons ITEM at the head of the g.v. REF (a list)"
- (list 'setf ref (list 'cons item ref)))
-
-(defmacro pushnew (item ref)
- "(pushnew ITEM REF): adjoin ITEM at the head of the g.v. REF (a list)"
- (list 'setf ref (list 'adjoin item ref)))
-
-(defmacro pop (ref)
- "(pop REF) -> (prog1 (car REF) (setf REF (cdr REF)))"
- (let ((listname (gensym)))
- (list 'let (list (list listname ref))
- (list 'prog1
- (list 'car listname)
- (list 'setf ref (list 'cdr listname))))))
-\f
-;;; PSETF
-;;;
-;;; Psetf is the generalized variable equivalent of psetq. The right
-;;; hand sides are evaluated and assigned (via setf) to the left hand
-;;; 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))))))
-\f
-;;; SHIFTF and ROTATEF
-;;;
-
-(defmacro shiftf (&rest forms)
- "(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."
- (unless (> (length forms) 1)
- (error "`shiftf' needs more than one argument"))
- (let ((places (butlast forms))
- (newvalue (car (last forms))))
- ;; the places are accessed to fresh symbols
- (multiple-value-bind
- (bindings newsyms)
- (pair-with-newsyms places)
- (list 'let bindings
- (cons 'setf
- (zip-lists places
- (append (cdr newsyms) (list newvalue))))
- (car newsyms)))))
-
-(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))))
-\f
-;;; GETF, REMF, and REMPROP
-;;;
-
-(defun getf (place indicator &optional default)
- "Return PLACE's PROPNAME property, or DEFAULT if not present."
- (while (and place (not (eq (car place) indicator)))
- (setq place (cdr (cdr place))))
- (if place
- (car (cdr place))
- default))
-
-(defmacro getf$setf$method (place indicator default &rest newval)
- "SETF method for GETF. Not for public use."
- (case (length newval)
- (0 (setq newval default default nil))
- (1 (setq newval (car newval)))
- (t (error "Wrong number of arguments to (setf (getf ...)) form")))
- (let ((psym (gentemp)) (isym (gentemp)) (vsym (gentemp)))
- (list 'let (list (list psym place)
- (list isym indicator)
- (list vsym newval))
- (list 'while
- (list 'and psym
- (list 'not
- (list 'eq (list 'car psym) isym)))
- (list 'setq psym (list 'cdr (list 'cdr psym))))
- (list 'if psym
- (list 'setcar (list 'cdr psym) vsym)
- (list 'setf place
- (list 'nconc place (list 'list isym newval))))
- vsym)))
-
-(defsetf getf
- getf$setf$method)
-
-(defmacro remf (place indicator)
- "Remove from the property list at PLACE its PROPNAME property.
-Returns non-nil if and only if the property existed."
- (let ((psym (gentemp)) (isym (gentemp)))
- (list 'let (list (list psym place) (list isym indicator))
- (list 'cond
- (list (list 'eq isym (list 'car psym))
- (list 'setf place (list 'cdr (list 'cdr psym)))
- t)
- (list t
- (list 'setq psym (list 'cdr psym))
- (list 'while
- (list 'and (list 'cdr psym)
- (list 'not
- (list 'eq (list 'car (list 'cdr psym))
- isym)))
- (list 'setq psym (list 'cdr (list 'cdr psym))))
- (list 'cond
- (list (list 'cdr psym)
- (list 'setcdr psym
- (list 'cdr
- (list 'cdr (list 'cdr psym))))
- t)))))))
-
-(defun remprop (symbol indicator)
- "Remove SYMBOL's PROPNAME property, returning non-nil if it was present."
- (remf (symbol-plist symbol) indicator))
-
-\f
-;;;; STRUCTS
-;;;; This file provides the structures mechanism. See the
-;;;; documentation for Common-Lisp's defstruct. Mine doesn't
-;;;; implement all the functionality of the standard, although some
-;;;; more could be grafted if so desired. More details along with
-;;;; the code.
-;;;;
-;;;;
-;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986
-;;;; (quiroz@cs.rochester.edu)
-
-
-(defkeyword :include "Syntax of `defstruct'")
-(defkeyword :named "Syntax of `defstruct'")
-(defkeyword :conc-name "Syntax of `defstruct'")
-(defkeyword :copier "Syntax of `defstruct'")
-(defkeyword :predicate "Syntax of `defstruct'")
-(defkeyword :print-function "Syntax of `defstruct'")
-(defkeyword :type "Syntax of `defstruct'")
-(defkeyword :initial-offset "Syntax of `defstruct'")
-
-(defkeyword :structure-doc "Documentation string for a structure.")
-(defkeyword :structure-slotsn "Number of slots in structure")
-(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")
-
-\f
-(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-function, :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.
-
-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
-the slot.
-`defstruct' defines functions `make-NAME', `NAME-p', `copy-NAME' for the
-structure, and functions with the same name as the slots to access
-them. `setf' of the accessors sets their values."
- (multiple-value-bind
- (name options docstring slotsn slots initlist)
- (parse$defstruct$args args)
- ;; 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)
- (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
- (when (and (numberp moreslotsn)
- (> moreslotsn 0))
- (setf slotsn (+ slotsn moreslotsn))
- (setf slots (append moreslots slots))
- (setf initlist (append moreinits initlist)))
- (unless (> slotsn 0)
- (error "%s needs at least one slot"
- (prin1-to-string name)))
- (let ((dups (duplicate-symbols-p slots)))
- (when dups
- (error "`%s' are duplicates"
- (prin1-to-string dups))))
- (setq initlist (simplify$inits slots initlist))
- (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))))))))
-
- ;; Compute functions associated with NAME. This is not
- ;; handling BOA constructors yet, but here would be the place.
- (setq functions
- (list
- (list 'fset (list 'quote constructor)
- (list 'function
- (list 'lambda (list '&rest 'args)
- (list 'make$structure$instance
- (list 'quote name)
- 'args))))
- (list 'fset (list 'quote copier)
- (list 'function 'copy-sequence))
- (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))))))
- )))))
- ;; compute accessors for NAME's slots
- (multiple-value-setq
- (accessors alterators keywords)
- (build$accessors$for name conc-name predicate slots slotsn))
- ;; generate returned value -- not defined by the standard
- (setq returned
- (list
- (cons 'vector
- (mapcar
- (function (lambda (x) (list 'quote x)))
- (cons name slots)))))
- ;; generate code
- (cons 'progn
- (nconc properties functions keywords
- accessors alterators returned))))))
-\f
-(defun parse$defstruct$args (args)
- "(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...)...)
- options ;args=((symbol . options) ...)
- (docstring "") ;args=(head docstring . slotargs)
- slotargs ;second or third cdr of args
- (slotsn 0) ;number of slots
- (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 ...)")))
- (setq slotargs (cdr args))
- ;; is there a docstring?
- (when (stringp (car slotargs))
- (setq docstring (car slotargs)
- slotargs (cdr slotargs)))
- ;; now for the slots
- (multiple-value-bind
- (slotsn slots initlist)
- (process$slots slotargs)
- (values name options docstring slotsn slots initlist))))
-\f
-(defun process$slots (slots)
- "(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
- slotslist ;(slot1 slot2 ...)
- initlist) ;((:slot1 . init1) ...)
- (do*
- ((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)))))
- (values slotsn (nreverse slotslist) (nreverse initlist))))
-\f
-(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"
- (let* ((namestring (symbol-name name))
- ;; to build the return values
- (conc-name (concat namestring "-"))
- (const (intern (concat "make-" namestring)))
- (copier (intern (concat "copy-" namestring)))
- (pred (intern (concat namestring "-p")))
- (moreslotsn 0)
- (moreslots '())
- (moreinits '())
- ;; auxiliaries
- option-head ;When an option is not a plain
- option-second ; keyword, it must be a list of
- option-rest ; the form (head second . rest)
- 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)
- ;; 2 cases arise, as options must be a keyword or a list
- (cond
- ((keywordp option)
- (case option
- (:named
- ) ;ignore silently
- (t
- (error "can't recognize option `%s'"
- (prin1-to-string option)))))
- ((and (listp option)
- (keywordp (setq option-head (car option))))
- (setq option-second (second option))
- (setq option-rest (nthcdr 2 option))
- (case option-head
- (:conc-name
- (setq conc-name
- (cond
- ((stringp option-second)
- option-second)
- ((null option-second)
- "")
- (t
- (error "`%s' is invalid as `conc-name'"
- (prin1-to-string option-second))))))
- (:copier
- (setq copier
- (cond
- ((and (symbolp option-second)
- (null option-rest))
- option-second)
- (t
- (error "can't recognize option `%s'"
- (prin1-to-string option))))))
-\f
- (:constructor ;no BOA-constructors allowed
- (setq const
- (cond
- ((and (symbolp option-second)
- (null option-rest))
- option-second)
- (t
- (error "can't recognize option `%s'"
- (prin1-to-string option))))))
- (:predicate
- (setq pred
- (cond
- ((and (symbolp option-second)
- (null option-rest))
- option-second)
- (t
- (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'"
- (prin1-to-string option-second)))
- (setq these-slotsn (get option-second :structure-slotsn)
- these-slots (get option-second :structure-slots)
- these-inits (get option-second :structure-initforms))
- (unless (and (numberp these-slotsn)
- (> 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)
- (when (> xtra-slotsn 0)
- (dolist (xslot xtra-slots)
- (unless (memq xslot these-slots)
- (error "`%s' is not a slot of `%s'"
- (prin1-to-string xslot)
- (prin1-to-string option-second))))
- (setq these-inits (append xtra-inits these-inits)))
- (setq moreslotsn (+ moreslotsn these-slotsn))
- (setq moreslots (append these-slots moreslots))
- (setq moreinits (append these-inits moreinits))))
- ((:print-function :type :initial-offset)
- ) ;ignore silently
- (t
- (error "can't recognize option `%s'"
- (prin1-to-string option)))))
- (t
- (error "can't recognize option `%s'"
- (prin1-to-string option)))))
- ;; Return values found
- (values conc-name const copier pred
- moreslotsn moreslots moreinits
- included)))
-\f
-(defun simplify$inits (slots initlist)
- "(simplify$inits SLOTS INITLIST) => new INITLIST
-Removes from INITLIST - an ALIST - any shadowed bindings."
- (let ((result '()) ;built here
- key ;from the slot
- )
- (dolist (slot slots)
- (setq key (keyword-of slot))
- (setq result (acons key (cdr (assoc key initlist)) result)))
- (nreverse result)))
-
-(defun extract$indices (initlist)
- "(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."
- (let ((result '())
- (index 0))
- (dolist (entry initlist (nreverse result))
- (setq result (acons (car entry) index result)
- index (+ index 1)))))
-\f
-(defun build$accessors$for (name conc-name predicate slots slotsn)
- "(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."
- (do ((i 0 (1+ i))
- (accessors '())
- (alterators '())
- (keywords '())
- (canonic "")) ;slot name with conc-name prepended
- ((>= i slotsn)
- (values
- (nreverse accessors) (nreverse alterators) (nreverse keywords)))
- (setq canonic (intern (concat conc-name (symbol-name (nth i slots)))))
- (setq accessors
- (cons
- (list 'fset (list 'quote canonic)
- (list 'function
- (list 'lambda (list 'object)
- (list 'cond
- (list (list predicate 'object)
- (list 'aref 'object (1+ i)))
- (list 't
- (list 'error
- "`%s' is not a struct %s"
- (list 'prin1-to-string
- 'object)
- (list 'prin1-to-string
- (list 'quote
- name))))))))
- accessors))
- (setq alterators
- (cons
- (list 'defsetf canonic
- (list 'lambda (list 'object 'newval)
- (list 'cond
- (list (list predicate 'object)
- (list 'aset 'object (1+ i) 'newval))
- (list 't
- (list 'error
- "`%s' not a `%s'"
- (list 'prin1-to-string
- 'object)
- (list 'prin1-to-string
- (list 'quote
- name)))))))
- alterators))
- (setq keywords
- (cons (list 'defkeyword (keyword-of (nth i slots)))
- keywords))))
-\f
-(defun make$structure$instance (name args)
- "(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)
- (error "`%s' is not a possible name for a structure"
- (prin1-to-string name)))
- (let ((initforms (get name :structure-initforms))
- (slotsn (get name :structure-slotsn))
- (indices (get name :structure-indices))
- initalist ;pairlis'd on initforms
- initializers ;definitive initializers
- )
- ;; check sanity of the request
- (unless (and (numberp slotsn)
- (> slotsn 0))
- (error "`%s' is not a defined structure"
- (prin1-to-string name)))
- (unless (evenp (length args))
- (error "slot initializers `%s' not of even length"
- (prin1-to-string args)))
- ;; analyze the initializers provided by the call
- (multiple-value-bind
- (speckwds specvals) ;keywords and values given
- (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"
- (prin1-to-string speckwds)))
- ;; check that all the keywords are known
- (dolist (kwd speckwds)
- (unless (numberp (cdr (assoc kwd indices)))
- (error "`%s' is not a valid slot name for %s"
- (prin1-to-string kwd) (prin1-to-string name))))
- ;; update initforms
- (setq initalist
- (pairlis speckwds
- (do* ;;protect values from further evaluation
- ((ptr specvals (cdr ptr))
- (val (car ptr) (car ptr))
- (result '()))
- ((endp ptr) (nreverse result))
- (setq result
- (cons (list 'quote val)
- result)))
- (copy-sequence initforms)))
- ;; compute definitive initializers
- (setq initializers
- (do* ;;gather the values of the most definitive forms
- ((ptr indices (cdr ptr))
- (key (caar ptr) (caar ptr))
- (result '()))
- ((endp ptr) (nreverse result))
- (setq result
- (cons (eval (cdr (assoc key initalist))) result))))
- ;; do real initialization
- (apply (function vector)
- (cons name initializers)))))
-
-;;;; end of cl-structs.el
-\f
-;;; 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))
-\f
-;;;; 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
-
-(defsubst 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))))
-\f
-;;; 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))
-\f
-;;; 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)
-\f
-;;; Due to Aaron Larson (alarson@src.honeywell.com, 26 Jul 91)
-(put 'progv 'common-lisp-indent-hook '(4 4 &body))
-(defmacro progv (vars vals &rest body)
- "progv vars vals &body forms
-bind vars to vals then execute forms.
-If there are more vars than vals, the extra vars are unbound, if
-there are more vals than vars, the extra vals are just ignored."
- (` (progv$runtime (, vars) (, vals) (function (lambda () (,@ body))))))
-
-;;; To do this efficiently, it really needs to be a special form...
-(defun progv$runtime (vars vals body)
- (eval (let ((vars-n-vals nil)
- (unbind-forms nil))
- (do ((r vars (cdr r))
- (l vals (cdr l)))
- ((endp r))
- (push (list (car r) (list 'quote (car l))) vars-n-vals)
- (if (null l)
- (push (` (makunbound '(, (car r)))) unbind-forms)))
- (` (let (, vars-n-vals) (,@ unbind-forms) (funcall '(, body)))))))
-
-(provide 'cl)
-
-;;;; end of cl.el
+++ /dev/null
-;;; cmulisp.el --- improved version of standard inferior-lisp mode
-
-;;; Copyright Olin Shivers (1988).
-
-;; Keywords: processes, lisp
-
-;;; Please imagine a long, tedious, legalistic 5-page gnu-style copyright
-;;; notice appearing here to the effect that you may use this code any
-;;; way you like, as long as you don't charge money for it, remove this
-;;; notice, or hold me liable for its results.
-
-;;; Commentary:
-
-;;; This replaces the standard inferior-lisp mode.
-;;; Hacked from tea.el by Olin Shivers (shivers@cs.cmu.edu). 8/88
-;;; Please send me bug reports, bug fixes, and extensions, so that I can
-;;; merge them into the master source.
-;;;
-;;; Change log at end of file.
-
-;;; This file defines a a lisp-in-a-buffer package (cmulisp mode) built on top
-;;; of comint mode. Cmulisp mode is similar to, and intended to replace, its
-;;; counterpart in the standard gnu emacs release. This replacements is more
-;;; featureful, robust, and uniform than the released version. The key
-;;; bindings are also more compatible with the bindings of Hemlock and Zwei
-;;; (the Lisp Machine emacs).
-
-;;; 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.
-;;; This makes these modes easier to use.
-
-;;; For documentation on the functionality provided by comint mode, and
-;;; the hooks available for customising it, see the file comint.el.
-;;; For further information on cmulisp mode, see the comments below.
-
-;;; Needs fixin:
-;;; 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, ...).
-;;;
-;;; It would be nice if cmulisp (and inferior scheme, T, ...) modes
-;;; had a verbose minor mode wherein sending or compiling defuns, etc.
-;;; would be reflected in the transcript with suitable comments, e.g.
-;;; ";;; redefining fact". Several ways to do this. Which is right?
-;;;
-;;; 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?
-
-(require 'comint)
-;; YOUR .EMACS FILE
-;;=============================================================================
-;; Some suggestions for your .emacs file.
-;;
-;; ; If cmulisp lives in some non-standard directory, you must tell emacs
-;; ; where to get it. This may or may not be necessary.
-;; (setq load-path (cons (expand-file-name "~jones/lib/emacs") load-path))
-;;
-;; ; Autoload cmulisp from file cmulisp.el
-;; (autoload 'cmulisp "cmulisp"
-;; "Run an inferior Lisp process."
-;; t)
-;;
-;; ; Define C-c t to run my favorite command in cmulisp mode:
-;; (setq cmulisp-load-hook
-;; '((lambda ()
-;; (define-key cmulisp-mode-map "\C-ct" 'favorite-cmd))))
-
-;; Brief Command Documentation:
-;;============================================================================
-;; Comint Mode Commands: (common to cmulisp and all comint-derived modes)
-;;
-;; m-p comint-previous-input Cycle backwards in input history
-;; m-n comint-next-input Cycle forwards
-;; m-c-r comint-previous-input-matching Search backwards in input history
-;; return comint-send-input
-;; c-a comint-bol Beginning of line; skip prompt.
-;; c-d comint-delchar-or-maybe-eof Delete char unless at end of buff.
-;; c-c c-u comint-kill-input ^u
-;; c-c c-w backward-kill-word ^w
-;; c-c c-c comint-interrupt-subjob ^c
-;; c-c c-z comint-stop-subjob ^z
-;; c-c c-\ comint-quit-subjob ^\
-;; c-c c-o comint-kill-output Delete last batch of process output
-;; c-c c-r comint-show-output Show last batch of process output
-;; send-invisible Read line w/o echo & send to proc
-;; comint-continue-subjob Useful if you accidentally suspend
-;; top-level job.
-;; comint-mode-hook is the comint mode hook.
-
-;; CMU Lisp Mode Commands:
-;; c-m-x lisp-send-defun This binding is a gnu convention.
-;; c-c c-l lisp-load-file Prompt for file name; tell Lisp to load it.
-;; c-c c-k lisp-compile-file Prompt for file name; tell Lisp to kompile it.
-;; Filename completion is available, of course.
-;;
-;; Additionally, these commands are added to the key bindings of Lisp mode:
-;; c-m-x lisp-eval-defun This binding is a gnu convention.
-;; c-c c-e lisp-eval-defun Send the current defun to Lisp process.
-;; c-x c-e lisp-eval-last-sexp Send the previous sexp to Lisp process.
-;; c-c c-r lisp-eval-region Send the current region to Lisp process.
-;; c-c c-c lisp-compile-defun Compile the current defun in Lisp process.
-;; c-c c-z switch-to-lisp Switch to the Lisp process buffer.
-;; c-c c-l lisp-load-file (See above. In a Lisp file buffer, default
-;; c-c c-k lisp-compile-file is to load/compile the current file.)
-;; c-c c-d lisp-describe-sym Query Lisp for a symbol's description.
-;; c-c c-a lisp-show-arglist Query Lisp for function's arglist.
-;; c-c c-f lisp-show-function-documentation Query Lisp for a function's doc.
-;; c-c c-v lisp-show-variable-documentation Query Lisp for a variable's doc.
-
-;; cmulisp Fires up the Lisp process.
-;; lisp-compile-region Compile all forms in the current region.
-;;
-;; CMU Lisp Mode Variables:
-;; cmulisp-filter-regexp Match this => don't get saved on input hist
-;; inferior-lisp-program Name of Lisp program run-lisp executes
-;; inferior-lisp-load-command Customises lisp-load-file
-;; cmulisp-mode-hook
-;; inferior-lisp-prompt Initialises comint-prompt-regexp.
-;; Backwards compatibility.
-;; lisp-source-modes Anything loaded into a buffer that's in
-;; one of these modes is considered Lisp
-;; source by lisp-load/compile-file.
-
-;;; Code:
-
-(require 'comint)
-
-;;; Read the rest of this file for more information.
-\f
-
-;;; Code:
-
-(defvar cmulisp-filter-regexp "\\`\\s *\\(:\\(\\w\\|\\s_\\)\\)?\\s *\\'"
- "*What not to save on inferior Lisp's input history
-Input matching this regexp is not saved on the input history in cmulisp
-mode. Default is whitespace followed by 0 or 1 single-letter :keyword
-(as in :a, :c, etc.)")
-
-(defvar cmulisp-mode-map nil)
-(cond ((not cmulisp-mode-map)
- (setq cmulisp-mode-map
- (nconc (full-copy-sparse-keymap comint-mode-map)
- shared-lisp-mode-map))
- (define-key cmulisp-mode-map "\C-x\C-e" 'lisp-eval-last-sexp)
- (define-key cmulisp-mode-map "\C-c\C-l" 'lisp-load-file)
- (define-key cmulisp-mode-map "\C-c\C-k" 'lisp-compile-file)
- (define-key cmulisp-mode-map "\C-c\C-a" 'lisp-show-arglist)
- (define-key cmulisp-mode-map "\C-c\C-d" 'lisp-describe-sym)
- (define-key cmulisp-mode-map "\C-c\C-f" 'lisp-show-function-documentation)
- (define-key cmulisp-mode-map "\C-c\C-v" 'lisp-show-variable-documentation)))
-
-;;; These commands augment Lisp mode, so you can process Lisp code in
-;;; the source files.
-(define-key lisp-mode-map "\M-\C-x" 'lisp-eval-defun) ; Gnu convention
-(define-key lisp-mode-map "\C-x\C-e" 'lisp-eval-last-sexp) ; Gnu convention
-(define-key lisp-mode-map "\C-c\C-e" 'lisp-eval-defun)
-(define-key lisp-mode-map "\C-c\C-r" 'lisp-eval-region)
-(define-key lisp-mode-map "\C-c\C-c" 'lisp-compile-defun)
-(define-key lisp-mode-map "\C-c\C-z" 'switch-to-lisp)
-(define-key lisp-mode-map "\C-c\C-l" 'lisp-load-file)
-(define-key lisp-mode-map "\C-c\C-k" 'lisp-compile-file) ; "kompile" file
-(define-key lisp-mode-map "\C-c\C-a" 'lisp-show-arglist)
-(define-key lisp-mode-map "\C-c\C-d" 'lisp-describe-sym)
-(define-key lisp-mode-map "\C-c\C-f" 'lisp-show-function-documentation)
-(define-key lisp-mode-map "\C-c\C-v" 'lisp-show-variable-documentation)
-
-(defvar cmulisp-buffer)
-
-;;; This function exists for backwards compatibility.
-;;; Previous versions of this package bound commands to C-c <letter>
-;;; bindings, which is not allowed by the gnumacs standard.
-
-(defun cmulisp-install-letter-bindings ()
- "This function binds many cmulisp commands to C-c <letter> bindings,
-where they are more accessible. C-c <letter> bindings are reserved for the
-user, so these bindings are non-standard. If you want them, you should
-have this function called by the cmulisp-load-hook:
- (setq cmulisp-load-hook '(cmulisp-install-letter-bindings))
-You can modify this function to install just the bindings you want."
-
- (define-key lisp-mode-map "\C-ce" 'lisp-eval-defun-and-go)
- (define-key lisp-mode-map "\C-cr" 'lisp-eval-region-and-go)
- (define-key lisp-mode-map "\C-cc" 'lisp-compile-defun-and-go)
- (define-key lisp-mode-map "\C-cz" 'switch-to-lisp)
- (define-key lisp-mode-map "\C-cl" 'lisp-load-file)
- (define-key lisp-mode-map "\C-ck" 'lisp-compile-file)
- (define-key lisp-mode-map "\C-ca" 'lisp-show-arglist)
- (define-key lisp-mode-map "\C-cd" 'lisp-describe-sym)
- (define-key lisp-mode-map "\C-cf" 'lisp-show-function-documentation)
- (define-key lisp-mode-map "\C-cv" 'lisp-show-variable-documentation)
-
- (define-key cmulisp-mode-map "\C-cl" 'lisp-load-file)
- (define-key cmulisp-mode-map "\C-ck" 'lisp-compile-file)
- (define-key cmulisp-mode-map "\C-ca" 'lisp-show-arglist)
- (define-key cmulisp-mode-map "\C-cd" 'lisp-describe-sym)
- (define-key cmulisp-mode-map "\C-cf" 'lisp-show-function-documentation)
- (define-key cmulisp-mode-map "\C-cv" 'lisp-show-variable-documentation))
-
-
-(defvar inferior-lisp-program "lisp"
- "*Program name for invoking an inferior Lisp with `cmulisp'.")
-
-(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 recognise prompts in the inferior Lisp.
-Defaults to \"^[^> ]*>+:? *\", which works pretty good for Lucid, kcl,
-and franz. This variable is used to initialise comint-prompt-regexp in the
-cmulisp buffer.
-
-More precise choices:
-Lucid Common Lisp: \"^\\(>\\|\\(->\\)+\\) *\"
-franz: \"^\\(->\\|<[0-9]*>:\\) *\"
-kcl: \"^>+ *\"
-
-This is a fine thing to set in your .emacs file.")
-
-(defvar cmulisp-mode-hook '()
- "*Hook for customising cmulisp mode")
-
-(defun cmulisp-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, cmulisp-filter-regexp and
-inferior-lisp-load-command can customize this mode for different Lisp
-interpreters.
-
-For information on running multiple processes in multiple buffers, see
-documentation for variable cmulisp-buffer.
-
-\\{cmulisp-mode-map}
-
-Customisation: Entry to this mode runs the hooks on comint-mode-hook and
-cmulisp-mode-hook (in that order).
-
-You can send text to the inferior Lisp process from other buffers containing
-Lisp source.
- switch-to-lisp switches the current buffer to the Lisp process buffer.
- lisp-eval-defun sends the current defun to the Lisp process.
- lisp-compile-defun compiles the current defun.
- lisp-eval-region sends the current region to the Lisp process.
- lisp-compile-region compiles the current region.
-
- Prefixing the lisp-eval/compile-defun/region commands with
- a \\[universal-argument] causes a switch to the Lisp process buffer after sending
- the text.
-
-Commands:
-Return after the end of the process' output sends the text from the
- end of process to point.
-Return before the end of the process' output copies the sexp ending at point
- to the end of the process' output, and sends it.
-Delete converts tabs to spaces as it moves back.
-Tab indents for Lisp; with argument, shifts rest
- of expression rigidly with the current line.
-C-M-q does Tab on each line starting within following expression.
-Paragraphs are separated only by blank lines. Semicolons start comments.
-If you accidentally suspend your process, use \\[comint-continue-subjob]
-to continue it."
- (interactive)
- (comint-mode)
- (setq comint-prompt-regexp inferior-lisp-prompt)
- (setq major-mode 'cmulisp-mode)
- (setq mode-name "CMU Lisp")
- (setq mode-line-process '(": %s"))
- (lisp-mode-variables t)
- (use-local-map cmulisp-mode-map) ;c-c c-k for "kompile" file
- (setq comint-get-old-input (function lisp-get-old-input))
- (setq comint-input-filter (function lisp-input-filter))
- (setq comint-input-sentinel 'ignore)
- (run-hooks 'cmulisp-mode-hook))
-
-(defun lisp-get-old-input ()
- "Snarf the sexp ending at point"
- (save-excursion
- (let ((end (point)))
- (backward-sexp)
- (buffer-substring (point) end))))
-
-(defun lisp-input-filter (str)
- "Don't save anything matching cmulisp-filter-regexp"
- (not (string-match cmulisp-filter-regexp str)))
-
-(defun cmulisp (cmd)
- "Run an inferior Lisp process, input and output via buffer *cmulisp*.
-If there is a process already running in *cmulisp*, just switch to that buffer.
-With argument, allows you to edit the command line (default is value
-of inferior-lisp-program). Runs the hooks from cmulisp-mode-hook (after the
-comint-mode-hook is run).
-\(Type \\[describe-mode] in the process buffer for a list of commands.)"
- (interactive (list (if current-prefix-arg
- (read-string "Run lisp: " inferior-lisp-program)
- inferior-lisp-program)))
- (if (not (comint-check-proc "*cmulisp*"))
- (let ((cmdlist (cmulisp-args-to-list cmd)))
- (set-buffer (apply (function make-comint) "cmulisp" (car cmdlist) nil
- (cdr cmdlist)))
- (cmulisp-mode)))
- (setq cmulisp-buffer "*cmulisp*")
- (switch-to-buffer "*cmulisp*"))
-
-;;; Break a string up into a list of arguments.
-;;; This will break if you have an argument with whitespace, as in
-;;; string = "-ab +c -x 'you lose'".
-(defun cmulisp-args-to-list (string)
- (let ((where (string-match "[ \t]" string)))
- (cond ((null where) (list string))
- ((not (= where 0))
- (cons (substring string 0 where)
- (tea-args-to-list (substring string (+ 1 where)
- (length string)))))
- (t (let ((pos (string-match "[^ \t]" string)))
- (if (null pos)
- nil
- (cmulisp-args-to-list (substring string pos
- (length string)))))))))
-
-(defun lisp-eval-region (start end &optional and-go)
- "Send the current region to the inferior Lisp process.
-Prefix argument means switch-to-lisp afterwards."
- (interactive "r\nP")
- (comint-send-region (cmulisp-proc) start end)
- (comint-send-string (cmulisp-proc) "\n")
- (if and-go (switch-to-lisp t)))
-
-(defun lisp-eval-defun (&optional and-go)
- "Send the current defun to the inferior Lisp process.
-Prefix argument means switch-to-lisp afterwards."
- (interactive "P")
- (save-excursion
- (end-of-defun)
- (skip-chars-backward " \t\n\r\f") ; Makes allegro happy
- (let ((end (point)))
- (beginning-of-defun)
- (lisp-eval-region (point) end)))
- (if and-go (switch-to-lisp t)))
-
-(defun lisp-eval-last-sexp (&optional and-go)
- "Send the previous sexp to the inferior Lisp process.
-Prefix argument means switch-to-lisp afterwards."
- (interactive "P")
- (lisp-eval-region (save-excursion (backward-sexp) (point)) (point) and-go))
-
-;;; Common Lisp COMPILE sux.
-(defun lisp-compile-region (start end &optional and-go)
- "Compile the current region in the inferior Lisp process.
-Prefix argument means switch-to-lisp afterwards."
- (interactive "r\nP")
- (comint-send-string (cmulisp-proc)
- (format "(funcall (compile nil `(lambda () (progn 'compile %s))))\n"
- (buffer-substring start end)))
- (if and-go (switch-to-lisp t)))
-
-(defun lisp-compile-defun (&optional and-go)
- "Compile the current defun in the inferior Lisp process.
-Prefix argument means switch-to-lisp afterwards."
- (interactive "P")
- (save-excursion
- (end-of-defun)
- (skip-chars-backward " \t\n\r\f") ; Makes allegro happy
- (let ((e (point)))
- (beginning-of-defun)
- (lisp-compile-region (point) e)))
- (if and-go (switch-to-lisp t)))
-
-(defun switch-to-lisp (eob-p)
- "Switch to the inferior Lisp process buffer.
-With argument, positions cursor at end of buffer."
- (interactive "P")
- (if (get-buffer cmulisp-buffer)
- (pop-to-buffer cmulisp-buffer)
- (error "No current process buffer. See variable cmulisp-buffer."))
- (cond (eob-p
- (push-mark)
- (goto-char (point-max)))))
-
-
-;;; Now that lisp-compile/eval-defun/region takes an optional prefix arg,
-;;; these commands are redundant. But they are kept around for the user
-;;; to bind if he wishes, for backwards functionality, and because it's
-;;; easier to type C-c e than C-u C-c C-e.
-
-(defun lisp-eval-region-and-go (start end)
- "Send the current region to the inferior Lisp,
-and switch to the process buffer."
- (interactive "r")
- (lisp-eval-region start end t))
-
-(defun lisp-eval-defun-and-go ()
- "Send the current defun to the inferior Lisp,
-and switch to the process buffer."
- (interactive)
- (lisp-eval-defun t))
-
-(defun lisp-compile-region-and-go (start end)
- "Compile the current region in the inferior Lisp,
-and switch to the process buffer."
- (interactive "r")
- (lisp-compile-region start end t))
-
-(defun lisp-compile-defun-and-go ()
- "Compile the current defun in the inferior Lisp,
-and switch to the process buffer."
- (interactive)
- (lisp-compile-defun t))
-
-;;; A version of the form in H. Shevis' soar-mode.el package. Less robust.
-;(defun lisp-compile-sexp (start end)
-; "Compile the s-expression bounded by START and END in the inferior lisp.
-;If the sexp isn't a DEFUN form, it is evaluated instead."
-; (cond ((looking-at "(defun\\s +")
-; (goto-char (match-end 0))
-; (let ((name-start (point)))
-; (forward-sexp 1)
-; (process-send-string "cmulisp" (format "(compile '%s #'(lambda "
-; (buffer-substring name-start
-; (point)))))
-; (let ((body-start (point)))
-; (goto-char start) (forward-sexp 1) ; Can't use end-of-defun.
-; (process-send-region "cmulisp" (buffer-substring body-start (point))))
-; (process-send-string "cmulisp" ")\n"))
-; (t (lisp-eval-region start end)))))
-;
-;(defun lisp-compile-region (start end)
-; "Each s-expression in the current region is compiled (if a DEFUN)
-;or evaluated (if not) in the inferior lisp."
-; (interactive "r")
-; (save-excursion
-; (goto-char start) (end-of-defun) (beginning-of-defun) ; error check
-; (if (< (point) start) (error "region begins in middle of defun"))
-; (goto-char start)
-; (let ((s start))
-; (end-of-defun)
-; (while (<= (point) end) ; Zip through
-; (lisp-compile-sexp s (point)) ; compiling up defun-sized chunks.
-; (setq s (point))
-; (end-of-defun))
-; (if (< s end) (lisp-compile-sexp s end)))))
-;;;
-;;; End of HS-style code
-
-
-(defvar lisp-prev-l/c-dir/file nil
- "Saves the (directory . file) pair used in the last lisp-load-file or
-lisp-compile-file command. Used for determining the default in the
-next one.")
-
-(defvar lisp-source-modes '(lisp-mode)
- "*Used to determine if a buffer contains Lisp source code.
-If it's loaded into a buffer that is in one of these major modes, it's
-considered a Lisp source file by lisp-load-file and lisp-compile-file.
-Used by these commands to determine defaults.")
-
-(defun lisp-load-file (file-name)
- "Load a Lisp file into the inferior Lisp process."
- (interactive (comint-get-source "Load Lisp file: " lisp-prev-l/c-dir/file
- lisp-source-modes nil)) ; NIL because LOAD
- ; doesn't need an exact name
- (comint-check-source file-name) ; Check to see if buffer needs saved.
- (setq lisp-prev-l/c-dir/file (cons (file-name-directory file-name)
- (file-name-nondirectory file-name)))
- (comint-send-string (cmulisp-proc)
- (format inferior-lisp-load-command file-name))
- (switch-to-lisp t))
-
-
-(defun lisp-compile-file (file-name)
- "Compile a Lisp file in the inferior Lisp process."
- (interactive (comint-get-source "Compile Lisp file: " lisp-prev-l/c-dir/file
- lisp-source-modes nil)) ; NIL = don't need
- ; suffix .lisp
- (comint-check-source file-name) ; Check to see if buffer needs saved.
- (setq lisp-prev-l/c-dir/file (cons (file-name-directory file-name)
- (file-name-nondirectory file-name)))
- (comint-send-string (cmulisp-proc) (concat "(compile-file \""
- file-name
- "\"\)\n"))
- (switch-to-lisp t))
-
-
-\f
-;;; Documentation functions: function doc, var doc, arglist, and
-;;; describe symbol.
-;;; ===========================================================================
-
-;;; Command strings
-;;; ===============
-
-(defvar lisp-function-doc-command
- "(let ((fn '%s))
- (format t \"Documentation for ~a:~&~a\"
- fn (documentation fn 'function))
- (values))\n"
- "Command to query inferior Lisp for a function's documentation.")
-
-(defvar lisp-var-doc-command
- "(let ((v '%s))
- (format t \"Documentation for ~a:~&~a\"
- v (documentation v 'variable))
- (values))\n"
- "Command to query inferior Lisp for a variable's documentation.")
-
-(defvar lisp-arglist-command
- "(let ((fn '%s))
- (format t \"Arglist for ~a: ~a\" fn (arglist fn))
- (values))\n"
- "Command to query inferior Lisp for a function's arglist.")
-
-(defvar lisp-describe-sym-command
- "(describe '%s)\n"
- "Command to query inferior Lisp for a variable's documentation.")
-
-
-;;; Ancillary functions
-;;; ===================
-
-;;; Reads a string from the user.
-(defun lisp-symprompt (prompt default)
- (list (let* ((prompt (if default
- (format "%s (default %s): " prompt default)
- (concat prompt ": ")))
- (ans (read-string prompt)))
- (if (zerop (length ans)) default ans))))
-
-
-;;; Adapted from function-called-at-point in help.el.
-(defun lisp-fn-called-at-pt ()
- "Returns the name of the function called in the current call.
-Nil if it can't find one."
- (condition-case nil
- (save-excursion
- (save-restriction
- (narrow-to-region (max (point-min) (- (point) 1000)) (point-max))
- (backward-up-list 1)
- (forward-char 1)
- (let ((obj (read (current-buffer))))
- (and (symbolp obj) obj))))
- (error nil)))
-
-
-;;; Adapted from variable-at-point in help.el.
-(defun lisp-var-at-pt ()
- (condition-case ()
- (save-excursion
- (forward-sexp -1)
- (skip-chars-forward "'")
- (let ((obj (read (current-buffer))))
- (and (symbolp obj) obj)))
- (error nil)))
-
-
-;;; Documentation functions: fn and var doc, arglist, and symbol describe.
-;;; ======================================================================
-
-(defun lisp-show-function-documentation (fn)
- "Send a command to the inferior Lisp to give documentation for function FN.
-See variable lisp-function-doc-command."
- (interactive (lisp-symprompt "Function doc" (lisp-fn-called-at-pt)))
- (comint-proc-query (cmulisp-proc) (format lisp-function-doc-command fn)))
-
-(defun lisp-show-variable-documentation (var)
- "Send a command to the inferior Lisp to give documentation for function FN.
-See variable lisp-var-doc-command."
- (interactive (lisp-symprompt "Variable doc" (lisp-var-at-pt)))
- (comint-proc-query (cmulisp-proc) (format lisp-var-doc-command var)))
-
-(defun lisp-show-arglist (fn)
- "Sends an query to the inferior Lisp for the arglist for function FN.
-See variable lisp-arglist-command."
- (interactive (lisp-symprompt "Arglist" (lisp-fn-called-at-pt)))
- (comint-proc-query (cmulisp-proc) (format lisp-arglist-command fn)))
-
-(defun lisp-describe-sym (sym)
- "Send a command to the inferior Lisp to describe symbol SYM.
-See variable lisp-describe-sym-command."
- (interactive (lisp-symprompt "Describe" (lisp-var-at-pt)))
- (comint-proc-query (cmulisp-proc) (format lisp-describe-sym-command sym)))
-
-\f
-(defvar cmulisp-buffer nil "*The current cmulisp process buffer.
-
-MULTIPLE PROCESS SUPPORT
-===========================================================================
-Cmulisp.el supports, in a fairly simple fashion, running multiple Lisp
-processes. To run multiple Lisp processes, you start the first up with
-\\[cmulisp]. It will be in a buffer named *cmulisp*. Rename this buffer
-with \\[rename-buffer]. You may now start up a new process with another
-\\[cmulisp]. It will be in a new buffer, named *cmulisp*. You can
-switch between the different process buffers with \\[switch-to-buffer].
-
-Commands that send text from source buffers to Lisp processes --
-like lisp-eval-defun or lisp-show-arglist -- have to choose a process
-to send to, when you have more than one Lisp process around. This
-is determined by the global variable cmulisp-buffer. Suppose you
-have three inferior lisps running:
- Buffer Process
- foo cmulisp
- bar cmulisp<2>
- *cmulisp* cmulisp<3>
-If you do a \\[lisp-eval-defun] command on some Lisp source code,
-what process do you send it to?
-
-- If you're in a process buffer (foo, bar, or *cmulisp*),
- you send it to that process.
-- If you're in some other buffer (e.g., a source file), you
- send it to the process attached to buffer cmulisp-buffer.
-This process selection is performed by function cmulisp-proc.
-
-Whenever \\[cmulisp] fires up a new process, it resets cmulisp-buffer
-to be the new process's buffer. If you only run one process, this will
-do the right thing. If you run multiple processes, you can change
-cmulisp-buffer to another process buffer with \\[set-variable].
-
-More sophisticated approaches are, of course, possible. If you find yourself
-needing to switch back and forth between multiple processes frequently,
-you may wish to consider ilisp.el, a larger, more sophisticated package
-for running inferior Lisp processes. The approach taken here is for a
-minimal, simple implementation. Feel free to extend it.")
-
-(defun cmulisp-proc ()
- "Returns the current cmulisp process. See variable cmulisp-buffer."
- (let ((proc (get-buffer-process (if (eq major-mode 'inferior-lisp-mode)
- (current-buffer)
- cmulisp-buffer))))
- (or proc
- (error "No current process. See variable cmulisp-buffer"))))
-
-
-;;; Do the user's customisation...
-;;;===============================
-(defvar cmulisp-load-hook nil
- "This hook is run when cmulisp is loaded in.
-This is a good place to put keybindings.")
-
-(run-hooks 'cmulisp-load-hook)
-
-;;; CHANGE LOG
-;;; ===========================================================================
-;;; 5/24/90 Olin
-;;; - Split cmulisp and cmushell modes into separate files.
-;;; Not only is this a good idea, it's apparently the way it'll be rel 19.
-;;; - Upgraded process sends to use comint-send-string instead of
-;;; process-send-string.
-;;; - Explicit references to process "cmulisp" have been replaced with
-;;; (cmulisp-proc). This allows better handling of multiple process bufs.
-;;; - Added process query and var/function/symbol documentation
-;;; commands. Based on code written by Douglas Roberts.
-;;; - Added lisp-eval-last-sexp, bound to C-x C-e.
-;;;
-;;; 9/20/90 Olin
-;;; Added a save-restriction to lisp-fn-called-at-pt. This bug and fix
-;;; reported by Lennart Staflin.
-;;;
-;;; 3/12/90 Olin
-;;; - lisp-load-file and lisp-compile-file no longer switch-to-lisp.
-;;; Tale suggested this.
-;;; - Reversed this decision 7/15/91. You need the visual feedback.
-;;;
-;;; 7/25/91 Olin
-;;; Changed all keybindings of the form C-c <letter>. These are
-;;; supposed to be reserved for the user to bind. This affected
-;;; mainly the compile/eval-defun/region[-and-go] commands.
-;;; This was painful, but necessary to adhere to the gnumacs standard.
-;;; For some backwards compatibility, see the
-;;; cmulisp-install-letter-bindings
-;;; function.
-;;;
-;;; 8/2/91 Olin
-;;; - The lisp-compile/eval-defun/region commands now take a prefix arg,
-;;; which means switch-to-lisp after sending the text to the Lisp process.
-;;; This obsoletes all the -and-go commands. The -and-go commands are
-;;; kept around for historical reasons, and because the user can bind
-;;; them to key sequences shorter than C-u C-c C-<letter>.
-;;; - If M-x cmulisp is invoked with a prefix arg, it allows you to
-;;; edit the command line.
-
-(provide 'cmulisp)
-
-;;; cmulisp.el ends here
+++ /dev/null
-;;; custom.el -- Tools for declaring and initializing options.
-;;
-;; Copyright (C) 1996, 1997, 1999, 2001 Free Software Foundation, Inc.
-;;
-;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
-;; Maintainer: FSF
-;; Keywords: help, faces
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;;; Commentary:
-;;
-;; This file only contain the code needed to declare and initialize
-;; user options. The code to customize options is autoloaded from
-;; `cus-edit.el' and is documented in the Emacs Lisp Reference manual.
-
-;; The code implementing face declarations is in `cus-face.el'
-
-;;; Code:
-
-(require 'widget)
-
-(defvar custom-define-hook nil
- ;; Customize information for this option is in `cus-edit.el'.
- "Hook called after defining each customize option.")
-
-;;; The `defcustom' Macro.
-
-(defun custom-initialize-default (symbol value)
- "Initialize SYMBOL with VALUE.
-This will do nothing if symbol already has a default binding.
-Otherwise, if symbol has a `saved-value' property, it will evaluate
-the car of that and used as the default binding for symbol.
-Otherwise, VALUE will be evaluated and used as the default binding for
-symbol."
- (unless (default-boundp symbol)
- ;; Use the saved value if it exists, otherwise the standard setting.
- (set-default symbol (if (get symbol 'saved-value)
- (eval (car (get symbol 'saved-value)))
- (eval value)))))
-
-(defun custom-initialize-set (symbol value)
- "Initialize SYMBOL based on VALUE.
-If the symbol doesn't have a default binding already,
-then set it using its `:set' function (or `set-default' if it has none).
-The value is either the value in the symbol's `saved-value' property,
-if any, or VALUE."
- (unless (default-boundp symbol)
- (funcall (or (get symbol 'custom-set) 'set-default)
- symbol
- (if (get symbol 'saved-value)
- (eval (car (get symbol 'saved-value)))
- (eval value)))))
-
-(defun custom-initialize-reset (symbol value)
- "Initialize SYMBOL based on VALUE.
-Set the symbol, using its `:set' function (or `set-default' if it has none).
-The value is either the symbol's current value
- \(as obtained using the `:get' function), if any,
-or the value in the symbol's `saved-value' property if any,
-or (last of all) VALUE."
- (funcall (or (get symbol 'custom-set) 'set-default)
- symbol
- (cond ((default-boundp symbol)
- (funcall (or (get symbol 'custom-get) 'default-value)
- symbol))
- ((get symbol 'saved-value)
- (eval (car (get symbol 'saved-value))))
- (t
- (eval value)))))
-
-(defun custom-initialize-changed (symbol value)
- "Initialize SYMBOL with VALUE.
-Like `custom-initialize-reset', but only use the `:set' function if
-not using the standard setting.
-For the standard setting, use `set-default'."
- (cond ((default-boundp symbol)
- (funcall (or (get symbol 'custom-set) 'set-default)
- symbol
- (funcall (or (get symbol 'custom-get) 'default-value)
- symbol)))
- ((get symbol 'saved-value)
- (funcall (or (get symbol 'custom-set) 'set-default)
- symbol
- (eval (car (get symbol 'saved-value)))))
- (t
- (set-default symbol (eval value)))))
-
-(defun custom-declare-variable (symbol default doc &rest args)
- "Like `defcustom', but SYMBOL and DEFAULT are evaluated as normal arguments.
-DEFAULT should be an expression to evaluate to compute the default value,
-not the default value itself."
- ;; Remember the standard setting.
- (put symbol 'standard-value (list default))
- ;; Maybe this option was rogue in an earlier version. It no longer is.
- (when (get symbol 'force-value)
- (put symbol 'force-value nil))
- (when doc
- (put symbol 'variable-documentation doc))
- (let ((initialize 'custom-initialize-reset)
- (requests nil))
- (while args
- (let ((arg (car args)))
- (setq args (cdr args))
- (unless (symbolp arg)
- (error "Junk in args %S" args))
- (let ((keyword arg)
- (value (car args)))
- (unless args
- (error "Keyword %s is missing an argument" keyword))
- (setq args (cdr args))
- (cond ((eq keyword :initialize)
- (setq initialize value))
- ((eq keyword :set)
- (put symbol 'custom-set value))
- ((eq keyword :get)
- (put symbol 'custom-get value))
- ((eq keyword :require)
- (setq requests (cons value requests)))
- ((eq keyword :type)
- (put symbol 'custom-type (purecopy value)))
- ((eq keyword :options)
- (if (get symbol 'custom-options)
- ;; Slow safe code to avoid duplicates.
- (mapc (lambda (option)
- (custom-add-option symbol option))
- value)
- ;; Fast code for the common case.
- (put symbol 'custom-options (copy-sequence value))))
- (t
- (custom-handle-keyword symbol keyword value
- 'custom-variable))))))
- (put symbol 'custom-requests requests)
- ;; Do the actual initialization.
- (funcall initialize symbol default))
- (setq current-load-list (cons symbol current-load-list))
- (run-hooks 'custom-define-hook)
- symbol)
-
-(defmacro defcustom (symbol value doc &rest args)
- "Declare SYMBOL as a customizable variable that defaults to VALUE.
-DOC is the variable documentation.
-
-Neither SYMBOL nor VALUE needs to be quoted.
-If SYMBOL is not already bound, initialize it to VALUE.
-The remaining arguments should have the form
-
- [KEYWORD VALUE]...
-
-The following keywords are meaningful:
-
-:type VALUE should be a widget type for editing the symbols value.
-:options VALUE should be a list of valid members of the widget type.
-:group VALUE should be a customization group.
- Add SYMBOL to that group.
-:initialize
- VALUE should be a function used to initialize the
- variable. It takes two arguments, the symbol and value
- given in the `defcustom' call. The default is
- `custom-initialize-default'
-:set VALUE should be a function to set the value of the symbol.
- It takes two arguments, the symbol to set and the value to
- give it. The default choice of function is `custom-set-default'.
-:get VALUE should be a function to extract the value of symbol.
- The function takes one argument, a symbol, and should return
- the current value for that symbol. The default choice of function
- is `custom-default-value'.
-:require
- VALUE should be a feature symbol. If you save a value
- for this option, then when your `.emacs' file loads the value,
- it does (require VALUE) first.
-:version
- VALUE should be a string specifying that the variable was
- first introduced, or its default value was changed, in Emacs
- version VERSION.
-
-Read the section about customization in the Emacs Lisp manual for more
-information."
- ;; It is better not to use backquote in this file,
- ;; because that makes a bootstrapping problem
- ;; if you need to recompile all the Lisp files using interpreted code.
- (nconc (list 'custom-declare-variable
- (list 'quote symbol)
- (list 'quote value)
- doc)
- args))
-
-;;; The `defface' Macro.
-
-(defmacro defface (face spec doc &rest args)
- "Declare FACE as a customizable face that defaults to SPEC.
-FACE does not need to be quoted.
-
-Third argument DOC is the face documentation.
-
-If FACE has been set with `custom-set-face', set the face attributes
-as specified by that function, otherwise set the face attributes
-according to SPEC.
-
-The remaining arguments should have the form
-
- [KEYWORD VALUE]...
-
-The following KEYWORDs are defined:
-
-:group VALUE should be a customization group.
- Add FACE to that group.
-
-SPEC should be an alist of the form ((DISPLAY ATTS)...).
-
-The first element of SPEC where the DISPLAY matches the frame
-is the one that takes effect in that frame. The ATTRs in this
-element take effect; the other elements are ignored, on that frame.
-
-ATTS is a list of face attributes followed by their values:
- (ATTR VALUE ATTR VALUE...)
-
-The possible attributes are `:family', `:width', `:height', `:weight',
-`:slant', `:underline', `:overline', `:strike-through', `:box',
-`:foreground', `:background', `:stipple', and `:inverse-video'.
-
-DISPLAY can either be the symbol t, which will match all frames, or an
-alist of the form \((REQ ITEM...)...). For the DISPLAY to match a
-FRAME, the REQ property of the frame must match one of the ITEM. The
-following REQ are defined:
-
-`type' (the value of `window-system')
- Under X, in addition to the values `window-system' can take,
- `motif', `lucid' and `x-toolkit' are allowed, and match when
- the Motif toolkit, Lucid toolkit, or any X toolkit is in use.
-
-`class' (the frame's color support)
- Should be one of `color', `grayscale', or `mono'.
-
-`background' (what color is used for the background text)
- Should be one of `light' or `dark'.
-
-Read the section about customization in the Emacs Lisp manual for more
-information."
- ;; It is better not to use backquote in this file,
- ;; because that makes a bootstrapping problem
- ;; if you need to recompile all the Lisp files using interpreted code.
- (nconc (list 'custom-declare-face (list 'quote face) spec doc) args))
-
-;;; The `defgroup' Macro.
-
-(defun custom-declare-group (symbol members doc &rest args)
- "Like `defgroup', but SYMBOL is evaluated as a normal argument."
- (while members
- (apply 'custom-add-to-group symbol (car members))
- (setq members (cdr members)))
- (put symbol 'custom-group (nconc members (get symbol 'custom-group)))
- (when doc
- ;; This text doesn't get into DOC.
- (put symbol 'group-documentation (purecopy doc)))
- (while args
- (let ((arg (car args)))
- (setq args (cdr args))
- (unless (symbolp arg)
- (error "Junk in args %S" args))
- (let ((keyword arg)
- (value (car args)))
- (unless args
- (error "Keyword %s is missing an argument" keyword))
- (setq args (cdr args))
- (cond ((eq keyword :prefix)
- (put symbol 'custom-prefix value))
- (t
- (custom-handle-keyword symbol keyword value
- 'custom-group))))))
- (run-hooks 'custom-define-hook)
- symbol)
-
-(defmacro defgroup (symbol members doc &rest args)
- "Declare SYMBOL as a customization group containing MEMBERS.
-SYMBOL does not need to be quoted.
-
-Third arg DOC is the group documentation.
-
-MEMBERS should be an alist of the form ((NAME WIDGET)...) where
-NAME is a symbol and WIDGET is a widget for editing that symbol.
-Useful widgets are `custom-variable' for editing variables,
-`custom-face' for edit faces, and `custom-group' for editing groups.
-
-The remaining arguments should have the form
-
- [KEYWORD VALUE]...
-
-The following KEYWORDs are defined:
-
-:group VALUE should be a customization group.
- Add SYMBOL to that group.
-
-:version VALUE should be a string specifying that the group was introduced
- in Emacs version VERSION.
-
-Read the section about customization in the Emacs Lisp manual for more
-information."
- ;; It is better not to use backquote in this file,
- ;; because that makes a bootstrapping problem
- ;; if you need to recompile all the Lisp files using interpreted code.
- (nconc (list 'custom-declare-group (list 'quote symbol) members doc) args))
-
-(defun custom-add-to-group (group option widget)
- "To existing GROUP add a new OPTION of type WIDGET.
-If there already is an entry for OPTION and WIDGET, nothing is done."
- (let ((members (get group 'custom-group))
- (entry (list option widget)))
- (unless (member entry members)
- (put group 'custom-group (nconc members (list entry))))))
-
-;;; Properties.
-
-(defun custom-handle-all-keywords (symbol args type)
- "For customization option SYMBOL, handle keyword arguments ARGS.
-Third argument TYPE is the custom option type."
- (while args
- (let ((arg (car args)))
- (setq args (cdr args))
- (unless (symbolp arg)
- (error "Junk in args %S" args))
- (let ((keyword arg)
- (value (car args)))
- (unless args
- (error "Keyword %s is missing an argument" keyword))
- (setq args (cdr args))
- (custom-handle-keyword symbol keyword value type)))))
-
-(defun custom-handle-keyword (symbol keyword value type)
- "For customization option SYMBOL, handle KEYWORD with VALUE.
-Fourth argument TYPE is the custom option type."
- (if purify-flag
- (setq value (purecopy value)))
- (cond ((eq keyword :group)
- (custom-add-to-group value symbol type))
- ((eq keyword :version)
- (custom-add-version symbol value))
- ((eq keyword :link)
- (custom-add-link symbol value))
- ((eq keyword :load)
- (custom-add-load symbol value))
- ((eq keyword :tag)
- (put symbol 'custom-tag value))
- ((eq keyword :set-after)
- (custom-add-dependencies symbol value))
- (t
- (error "Unknown keyword %s" keyword))))
-
-(defun custom-add-dependencies (symbol value)
- "To the custom option SYMBOL, add dependencies specified by VALUE.
-VALUE should be a list of symbols. For each symbol in that list,
-this specifies that SYMBOL should be set after the specified symbol, if
-both appear in constructs like `custom-set-variables'."
- (unless (listp value)
- (error "Invalid custom dependency `%s'" value))
- (let* ((deps (get symbol 'custom-dependencies))
- (new-deps deps))
- (while value
- (let ((dep (car value)))
- (unless (symbolp dep)
- (error "Invalid custom dependency `%s'" dep))
- (unless (memq dep new-deps)
- (setq new-deps (cons dep new-deps)))
- (setq value (cdr value))))
- (unless (eq deps new-deps)
- (put symbol 'custom-dependencies new-deps))))
-
-(defun custom-add-option (symbol option)
- "To the variable SYMBOL add OPTION.
-
-If SYMBOL is a hook variable, OPTION should be a hook member.
-For other types variables, the effect is undefined."
- (let ((options (get symbol 'custom-options)))
- (unless (member option options)
- (put symbol 'custom-options (cons option options)))))
-
-(defun custom-add-link (symbol widget)
- "To the custom option SYMBOL add the link WIDGET."
- (let ((links (get symbol 'custom-links)))
- (unless (member widget links)
- (put symbol 'custom-links (cons (purecopy widget) links)))))
-
-(defun custom-add-version (symbol version)
- "To the custom option SYMBOL add the version VERSION."
- (put symbol 'custom-version (purecopy version)))
-
-(defun custom-add-load (symbol load)
- "To the custom option SYMBOL add the dependency LOAD.
-LOAD should be either a library file name, or a feature name."
- (let ((loads (get symbol 'custom-loads)))
- (unless (member load loads)
- (put symbol 'custom-loads (cons (purecopy load) loads)))))
-
-;;; Initializing.
-
-(defvar custom-local-buffer nil
- "Non-nil, in a Customization buffer, means customize a specific buffer.
-If this variable is non-nil, it should be a buffer,
-and it means customize the local bindings of that buffer.
-This variable is a permanent local, and it normally has a local binding
-in every Customization buffer.")
-(put 'custom-local-buffer 'permanent-local t)
-
-(defun custom-set-variables (&rest args)
- "Initialize variables according to user preferences.
-
-The arguments should be a list where each entry has the form:
-
- (SYMBOL VALUE [NOW [REQUEST [COMMENT]]])
-
-The unevaluated VALUE is stored as the saved value for SYMBOL.
-If NOW is present and non-nil, VALUE is also evaluated and bound as
-the default value for the SYMBOL.
-REQUEST is a list of features we must require for SYMBOL.
-COMMENT is a comment string about SYMBOL."
- (setq args
- (sort args
- (lambda (a1 a2)
- (let* ((sym1 (car a1))
- (sym2 (car a2))
- (1-then-2 (memq sym1 (get sym2 'custom-dependencies)))
- (2-then-1 (memq sym2 (get sym1 'custom-dependencies))))
- (cond ((and 1-then-2 2-then-1)
- (error "Circular custom dependency between `%s' and `%s'"
- sym1 sym2))
- (1-then-2 t)
- (t nil))))))
- (while args
- (let ((entry (car args)))
- (if (listp entry)
- (let* ((symbol (nth 0 entry))
- (value (nth 1 entry))
- (now (nth 2 entry))
- (requests (nth 3 entry))
- (comment (nth 4 entry))
- set)
- (when requests
- (put symbol 'custom-requests requests)
- (mapc 'require requests))
- (setq set (or (get symbol 'custom-set) 'custom-set-default))
- (put symbol 'saved-value (list value))
- (put symbol 'saved-variable-comment comment)
- ;; Allow for errors in the case where the setter has
- ;; changed between versions, say, but let the user know.
- (condition-case data
- (cond (now
- ;; Rogue variable, set it now.
- (put symbol 'force-value t)
- (funcall set symbol (eval value)))
- ((default-boundp symbol)
- ;; Something already set this, overwrite it.
- (funcall set symbol (eval value))))
- (error
- (message "Error setting %s: %s" symbol data)))
- (setq args (cdr args))
- (and (or now (default-boundp symbol))
- (put symbol 'variable-comment comment)))
- ;; Old format, a plist of SYMBOL VALUE pairs.
- (message "Warning: old format `custom-set-variables'")
- (ding)
- (sit-for 2)
- (let ((symbol (nth 0 args))
- (value (nth 1 args)))
- (put symbol 'saved-value (list value)))
- (setq args (cdr (cdr args)))))))
-
-(defun custom-set-default (variable value)
- "Default :set function for a customizable variable.
-Normally, this sets the default value of VARIABLE to VALUE,
-but if `custom-local-buffer' is non-nil,
-this sets the local binding in that buffer instead."
- (if custom-local-buffer
- (with-current-buffer custom-local-buffer
- (set variable value))
- (set-default variable value)))
-
-;;; The End.
-
-;; Process the defcustoms for variables loaded before this file.
-(while custom-declare-variable-list
- (apply 'custom-declare-variable (car custom-declare-variable-list))
- (setq custom-declare-variable-list (cdr custom-declare-variable-list)))
-
-(provide 'custom)
-
-;;; custom.el ends here
+++ /dev/null
-;;; diary-ins.el --- calendar functions for adding diary entries.
-
-;; Copyright (C) 1990, 1994 Free Software Foundation, Inc.
-
-;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
-;; Keywords: diary, calendar
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to
-;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;;; Commentary:
-
-;; This collection of functions implements the diary insertion features as
-;; described in calendar.el.
-
-;; 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@cs.uiuc.edu 1304 West Springfield Avenue
-;; Urbana, Illinois 61801
-
-;;; Code:
-
-(require 'diary-lib)
-
-(defun make-diary-entry (string &optional nonmarking file)
- "Insert a diary entry STRING which may be NONMARKING in FILE.
-If omitted, NONMARKING defaults to nil and FILE defaults to diary-file."
- (find-file-other-window
- (substitute-in-file-name (if file file diary-file)))
- (goto-char (point-max))
- (insert
- (if (bolp) "" "\n")
- (if nonmarking diary-nonmarking-symbol "")
- string " "))
-
-(defun insert-diary-entry (arg)
- "Insert a diary entry for the date indicated by point.
-Prefix arg will make the entry nonmarking."
- (interactive "P")
- (make-diary-entry (calendar-date-string (calendar-cursor-to-date t) t t)
- arg))
-
-(defun insert-weekly-diary-entry (arg)
- "Insert a weekly diary entry for the day of the week indicated by point.
-Prefix arg will make the entry nonmarking."
- (interactive "P")
- (make-diary-entry (calendar-day-name (calendar-cursor-to-date t))
- arg))
-
-(defun insert-monthly-diary-entry (arg)
- "Insert a monthly diary entry for the day of the month indicated by point.
-Prefix arg will make the entry nonmarking."
- (interactive "P")
- (let* ((calendar-date-display-form
- (if european-calendar-style
- '(day " * ")
- '("* " day))))
- (make-diary-entry (calendar-date-string (calendar-cursor-to-date t) t)
- arg)))
-
-(defun insert-yearly-diary-entry (arg)
- "Insert an annual diary entry for the day of the year indicated by point.
-Prefix arg will make the entry nonmarking."
- (interactive "P")
- (let* ((calendar-date-display-form
- (if european-calendar-style
- '(day " " monthname)
- '(monthname " " day))))
- (make-diary-entry (calendar-date-string (calendar-cursor-to-date t) t)
- arg)))
-
-(defun insert-anniversary-diary-entry (arg)
- "Insert an anniversary diary entry for the date given by point.
-Prefix arg will make the entry nonmarking."
- (interactive "P")
- (let* ((calendar-date-display-form
- (if european-calendar-style
- '(day " " month " " year)
- '(month " " day " " year))))
- (make-diary-entry
- (format "%s(diary-anniversary %s)"
- sexp-diary-entry-symbol
- (calendar-date-string (calendar-cursor-to-date t) nil t))
- arg)))
-
-(defun insert-block-diary-entry (arg)
- "Insert a block diary entry for the days between the point and marked date.
-Prefix arg will make the entry nonmarking."
- (interactive "P")
- (let* ((calendar-date-display-form
- (if european-calendar-style
- '(day " " month " " year)
- '(month " " day " " year)))
- (cursor (calendar-cursor-to-date t))
- (mark (or (car calendar-mark-ring)
- (error "No mark set in this buffer")))
- (start)
- (end))
- (if (< (calendar-absolute-from-gregorian mark)
- (calendar-absolute-from-gregorian cursor))
- (setq start mark
- end cursor)
- (setq start cursor
- end mark))
- (make-diary-entry
- (format "%s(diary-block %s %s)"
- sexp-diary-entry-symbol
- (calendar-date-string start nil t)
- (calendar-date-string end nil t))
- arg)))
-
-(defun insert-cyclic-diary-entry (arg)
- "Insert a cyclic diary entry starting at the date given by point.
-Prefix arg will make the entry nonmarking."
- (interactive "P")
- (let* ((calendar-date-display-form
- (if european-calendar-style
- '(day " " month " " year)
- '(month " " day " " year))))
- (make-diary-entry
- (format "%s(diary-cyclic %d %s)"
- sexp-diary-entry-symbol
- (calendar-read "Repeat every how many days: "
- '(lambda (x) (> x 0)))
- (calendar-date-string (calendar-cursor-to-date t) nil t))
- arg)))
-
-(defun insert-hebrew-diary-entry (arg)
- "Insert a diary entry.
-For the Hebrew date corresponding to the date indicated by point.
-Prefix arg will make the entry nonmarking."
- (interactive "P")
- (let* ((calendar-month-name-array
- calendar-hebrew-month-name-array-leap-year))
- (make-diary-entry
- (concat
- hebrew-diary-entry-symbol
- (calendar-date-string
- (calendar-hebrew-from-absolute
- (calendar-absolute-from-gregorian
- (calendar-cursor-to-date t)))
- nil t))
- arg)))
-
-(defun insert-monthly-hebrew-diary-entry (arg)
- "Insert a monthly diary entry.
-For the day of the Hebrew month corresponding to the date indicated by point.
-Prefix arg will make the entry nonmarking."
- (interactive "P")
- (let* ((calendar-date-display-form
- (if european-calendar-style '(day " * ") '("* " day )))
- (calendar-month-name-array
- calendar-hebrew-month-name-array-leap-year))
- (make-diary-entry
- (concat
- hebrew-diary-entry-symbol
- (calendar-date-string
- (calendar-hebrew-from-absolute
- (calendar-absolute-from-gregorian
- (calendar-cursor-to-date t)))))
- arg)))
-
-(defun insert-yearly-hebrew-diary-entry (arg)
- "Insert an annual diary entry.
-For the day of the Hebrew year corresponding to the date indicated by point.
-Prefix arg will make the entry nonmarking."
- (interactive "P")
- (let* ((calendar-date-display-form
- (if european-calendar-style
- '(day " " monthname)
- '(monthname " " day)))
- (calendar-month-name-array
- calendar-hebrew-month-name-array-leap-year))
- (make-diary-entry
- (concat
- hebrew-diary-entry-symbol
- (calendar-date-string
- (calendar-hebrew-from-absolute
- (calendar-absolute-from-gregorian
- (calendar-cursor-to-date t)))))
- arg)))
-
-(defun insert-islamic-diary-entry (arg)
- "Insert a diary entry.
-For the Islamic date corresponding to the date indicated by point.
-Prefix arg will make the entry nonmarking."
- (interactive "P")
- (let* ((calendar-month-name-array calendar-islamic-month-name-array))
- (make-diary-entry
- (concat
- islamic-diary-entry-symbol
- (calendar-date-string
- (calendar-islamic-from-absolute
- (calendar-absolute-from-gregorian
- (calendar-cursor-to-date t)))
- nil t))
- arg)))
-
-(defun insert-monthly-islamic-diary-entry (arg)
- "Insert a monthly diary entry.
-For the day of the Islamic month corresponding to the date indicated by point.
-Prefix arg will make the entry nonmarking."
- (interactive "P")
- (let* ((calendar-date-display-form
- (if european-calendar-style '(day " * ") '("* " day )))
- (calendar-month-name-array calendar-islamic-month-name-array))
- (make-diary-entry
- (concat
- islamic-diary-entry-symbol
- (calendar-date-string
- (calendar-islamic-from-absolute
- (calendar-absolute-from-gregorian
- (calendar-cursor-to-date t)))))
- arg)))
-
-(defun insert-yearly-islamic-diary-entry (arg)
- "Insert an annual diary entry.
-For the day of the Islamic year corresponding to the date indicated by point.
-Prefix arg will make the entry nonmarking."
- (interactive "P")
- (let* ((calendar-date-display-form
- (if european-calendar-style
- '(day " " monthname)
- '(monthname " " day)))
- (calendar-month-name-array calendar-islamic-month-name-array))
- (make-diary-entry
- (concat
- islamic-diary-entry-symbol
- (calendar-date-string
- (calendar-islamic-from-absolute
- (calendar-absolute-from-gregorian
- (calendar-cursor-to-date t)))))
- arg)))
-
-(provide 'diary-ins)
-
-;;; diary-ins.el ends here
+++ /dev/null
-;;; diary-lib.el --- diary functions.
-
-;; Copyright (C) 1989, 1990, 1992, 1993, 1994 Free Software Foundation, Inc.
-
-;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
-;; Keywords: calendar
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to
-;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;;; Commentary:
-
-;; This collection of functions implements the diary features as described
-;; in calendar.el.
-
-;; 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@cs.uiuc.edu 1304 West Springfield Avenue
-;; Urbana, Illinois 61801
-
-;;; Code:
-
-(require 'calendar)
-
-;;;###autoload
-(defun diary (&optional arg)
- "Generate the diary window for ARG days starting with the current date.
-If no argument is provided, the number of days of diary entries is governed
-by the variable `number-of-diary-entries'. This function is suitable for
-execution in a `.emacs' file."
- (interactive "P")
- (let ((d-file (substitute-in-file-name diary-file))
- (date (calendar-current-date)))
- (if (and d-file (file-exists-p d-file))
- (if (file-readable-p d-file)
- (list-diary-entries
- date
- (cond
- (arg (prefix-numeric-value arg))
- ((vectorp number-of-diary-entries)
- (aref number-of-diary-entries (calendar-day-of-week date)))
- (t number-of-diary-entries)))
- (error "Your diary file is not readable!"))
- (error "You don't have a diary file!"))))
-
-(defun view-diary-entries (arg)
- "Prepare and display a buffer with diary entries.
-Searches the file named in `diary-file' for entries that
-match ARG days starting with the date indicated by the cursor position
-in the displayed three-month calendar."
- (interactive "p")
- (let ((d-file (substitute-in-file-name diary-file)))
- (if (and d-file (file-exists-p d-file))
- (if (file-readable-p d-file)
- (list-diary-entries (calendar-cursor-to-date t) arg)
- (error "Diary file is not readable!"))
- (error "You don't have a diary file!"))))
-
-(defun view-other-diary-entries (arg diary-file)
- "Prepare and display buffer of diary entries from an alternative diary file.
-Prompts for a file name and searches that file for entries that match ARG
-days starting with the date indicated by the cursor position in the displayed
-three-month calendar."
- (interactive
- (list (cond ((null current-prefix-arg) 1)
- ((listp current-prefix-arg) (car current-prefix-arg))
- (t current-prefix-arg))
- (setq diary-file (read-file-name "Enter diary file name: "
- default-directory nil t))))
- (view-diary-entries arg))
-
-(autoload 'check-calendar-holidays "holidays"
- "Check the list of holidays for any that occur on DATE.
-The value returned is a list of strings of relevant holiday descriptions.
-The holidays are those in the list `calendar-holidays'."
- t)
-
-(autoload 'calendar-holiday-list "holidays"
- "Form the list of holidays that occur on dates in the calendar window.
-The holidays are those in the list `calendar-holidays'."
- t)
-
-(autoload 'diary-french-date "cal-french"
- "French calendar equivalent of date diary entry."
- t)
-
-(autoload 'diary-mayan-date "cal-mayan"
- "Mayan calendar equivalent of date diary entry."
- t)
-
-(autoload 'diary-phases-of-moon "lunar" "Moon phases diary entry." t)
-
-(autoload 'diary-sunrise-sunset "solar"
- "Local time of sunrise and sunset as a diary entry."
- t)
-
-(autoload 'diary-sabbath-candles "solar"
- "Local time of candle lighting diary entry--applies if date is a Friday.
-No diary entry if there is no sunset on that date."
- t)
-
-(defvar diary-syntax-table (copy-syntax-table (standard-syntax-table))
- "The syntax table used when parsing dates in the diary file.
-It is the standard syntax table used in Fundamental mode, but with the
-syntax of `*' changed to be a word constituent.")
-
-(modify-syntax-entry ?* "w" diary-syntax-table)
-
-(defun list-diary-entries (date number)
- "Create and display a buffer containing the relevant lines in diary-file.
-The arguments are DATE and NUMBER; the entries selected are those
-for NUMBER days starting with date DATE. The other entries are hidden
-using selective display.
-
-Returns a list of all relevant diary entries found, if any, in order by date.
-The list entries have the form ((month day year) string). If the variable
-`diary-list-include-blanks' is t, this list includes a dummy diary entry
-\(consisting of the empty string) for a date with no diary entries.
-
-After the list is prepared, the hooks `nongregorian-diary-listing-hook',
-`list-diary-entries-hook', `diary-display-hook', and `diary-hook' are run.
-These hooks have the following distinct roles:
-
- `nongregorian-diary-listing-hook' can cull dates from the diary
- and each included file. Usually used for Hebrew or Islamic
- diary entries in files. Applied to *each* file.
-
- `list-diary-entries-hook' adds or manipulates diary entries from
- external sources. Used, for example, to include diary entries
- from other files or to sort the diary entries. Invoked *once* only,
- before the display hook is run.
-
- `diary-display-hook' does the actual display of information. If this is
- nil, simple-diary-display will be used. Use add-hook to set this to
- fancy-diary-display, if desired. If you want no diary display, use
- add-hook to set this to ignore.
-
- `diary-hook' is run last. This can be used for an appointment
- notification function."
-
- (if (< 0 number)
- (let* ((original-date date);; save for possible use in the hooks
- (old-diary-syntax-table)
- (diary-entries-list)
- (date-string (calendar-date-string date))
- (d-file (substitute-in-file-name diary-file)))
- (message "Preparing diary...")
- (save-excursion
- (let ((diary-buffer (get-file-buffer d-file)))
- (set-buffer (if diary-buffer
- diary-buffer
- (find-file-noselect d-file t))))
- (setq selective-display t)
- (setq selective-display-ellipses nil)
- (setq old-diary-syntax-table (syntax-table))
- (set-syntax-table diary-syntax-table)
- (unwind-protect
- (let ((buffer-read-only nil)
- (diary-modified (buffer-modified-p))
- (mark (regexp-quote diary-nonmarking-symbol)))
- (goto-char (1- (point-max)))
- (if (not (looking-at "\^M\\|\n"))
- (progn
- (forward-char 1)
- (insert-string "\^M")))
- (goto-char (point-min))
- (if (not (looking-at "\^M\\|\n"))
- (insert-string "\^M"))
- (subst-char-in-region (point-min) (point-max) ?\n ?\^M t)
- (calendar-for-loop i from 1 to number do
- (let ((d diary-date-forms)
- (month (extract-calendar-month date))
- (day (extract-calendar-day date))
- (year (extract-calendar-year date))
- (entry-found (list-sexp-diary-entries date)))
- (while d
- (let*
- ((date-form (if (equal (car (car d)) 'backup)
- (cdr (car d))
- (car d)))
- (backup (equal (car (car d)) 'backup))
- (dayname
- (concat
- (calendar-day-name date) "\\|"
- (substring (calendar-day-name date) 0 3) ".?"))
- (monthname
- (concat
- "\\*\\|"
- (calendar-month-name month) "\\|"
- (substring (calendar-month-name month) 0 3) ".?"))
- (month (concat "\\*\\|0*" (int-to-string month)))
- (day (concat "\\*\\|0*" (int-to-string day)))
- (year
- (concat
- "\\*\\|0*" (int-to-string year)
- (if abbreviated-calendar-year
- (concat "\\|" (int-to-string (% year 100)))
- "")))
- (regexp
- (concat
- "\\(\\`\\|\^M\\|\n\\)" mark "?\\("
- (mapconcat 'eval date-form "\\)\\(")
- "\\)"))
- (case-fold-search t))
- (goto-char (point-min))
- (while (re-search-forward regexp nil t)
- (if backup (re-search-backward "\\<" nil t))
- (if (and (or (char-equal (preceding-char) ?\^M)
- (char-equal (preceding-char) ?\n))
- (not (looking-at " \\|\^I")))
- ;; Diary entry that consists only of date.
- (backward-char 1)
- ;; Found a nonempty diary entry--make it visible and
- ;; add it to the list.
- (setq entry-found t)
- (let ((entry-start (point))
- (date-start))
- (re-search-backward "\^M\\|\n\\|\\`")
- (setq date-start (point))
- (re-search-forward "\^M\\|\n" nil t 2)
- (while (looking-at " \\|\^I")
- (re-search-forward "\^M\\|\n" nil t))
- (backward-char 1)
- (subst-char-in-region date-start
- (point) ?\^M ?\n t)
- (add-to-diary-list
- date (buffer-substring entry-start (point)))))))
- (setq d (cdr d)))
- (or entry-found
- (not diary-list-include-blanks)
- (setq diary-entries-list
- (append diary-entries-list
- (list (list date "")))))
- (setq date
- (calendar-gregorian-from-absolute
- (1+ (calendar-absolute-from-gregorian date))))
- (setq entry-found nil)))
- (set-buffer-modified-p diary-modified))
- (set-syntax-table old-diary-syntax-table))
- (goto-char (point-min))
- (run-hooks 'nongregorian-diary-listing-hook
- 'list-diary-entries-hook)
- (if diary-display-hook
- (run-hooks 'diary-display-hook)
- (simple-diary-display))
- (run-hooks 'diary-hook)
- diary-entries-list))))
-
-(defun include-other-diary-files ()
- "Include the diary entries from other diary files with those of diary-file.
-This function is suitable for use in `list-diary-entries-hook';
-it enables you to use shared diary files together with your own.
-The files included are specified in the diaryfile by lines of this form:
- #include \"filename\"
-This is recursive; that is, #include directives in diary files thus included
-are obeyed. You can change the `#include' to some other string by
-changing the variable `diary-include-string'."
- (goto-char (point-min))
- (while (re-search-forward
- (concat
- "\\(\\`\\|\^M\\|\n\\)"
- (regexp-quote diary-include-string)
- " \"\\([^\"]*\\)\"")
- nil t)
- (let ((diary-file (substitute-in-file-name
- (buffer-substring (match-beginning 2) (match-end 2))))
- (diary-list-include-blanks nil)
- (list-diary-entries-hook 'include-other-diary-files)
- (diary-display-hook 'ignore)
- (diary-hook nil))
- (if (file-exists-p diary-file)
- (if (file-readable-p diary-file)
- (unwind-protect
- (setq diary-entries-list
- (append diary-entries-list
- (list-diary-entries original-date number)))
- (kill-buffer (get-file-buffer diary-file)))
- (beep)
- (message "Can't read included diary file %s" diary-file)
- (sleep-for 2))
- (beep)
- (message "Can't find included diary file %s" diary-file)
- (sleep-for 2))))
- (goto-char (point-min)))
-
-(defun simple-diary-display ()
- "Display the diary buffer if there are any relevant entries or holidays."
- (let* ((holiday-list (if holidays-in-diary-buffer
- (check-calendar-holidays original-date)))
- (msg (format "No diary entries for %s %s"
- (concat date-string (if holiday-list ":" ""))
- (mapconcat 'identity holiday-list "; "))))
- (if (or (not diary-entries-list)
- (and (not (cdr diary-entries-list))
- (string-equal (car (cdr (car diary-entries-list))) "")))
- (if (<= (length msg) (frame-width))
- (message msg)
- (set-buffer (get-buffer-create holiday-buffer))
- (setq buffer-read-only nil)
- (calendar-set-mode-line date-string)
- (erase-buffer)
- (insert (mapconcat 'identity holiday-list "\n"))
- (goto-char (point-min))
- (set-buffer-modified-p nil)
- (setq buffer-read-only t)
- (display-buffer holiday-buffer)
- (message "No diary entries for %s" date-string))
- (calendar-set-mode-line
- (concat "Diary for " date-string
- (if holiday-list ": " "")
- (mapconcat 'identity holiday-list "; ")))
- (display-buffer (get-file-buffer d-file))
- (message "Preparing diary...done"))))
-
-(defun fancy-diary-display ()
- "Prepare a diary buffer with relevant entries in a fancy, noneditable form.
-This function is provided for optional use as the `diary-display-hook'."
- (save-excursion;; Turn off selective-display in the diary file's buffer.
- (set-buffer (get-file-buffer (substitute-in-file-name diary-file)))
- (let ((diary-modified (buffer-modified-p)))
- (subst-char-in-region (point-min) (point-max) ?\^M ?\n t)
- (setq selective-display nil)
- (kill-local-variable 'mode-line-format)
- (set-buffer-modified-p diary-modified)))
- (if (or (not diary-entries-list)
- (and (not (cdr diary-entries-list))
- (string-equal (car (cdr (car diary-entries-list))) "")))
- (let* ((holiday-list (if holidays-in-diary-buffer
- (check-calendar-holidays original-date)))
- (msg (format "No diary entries for %s %s"
- (concat date-string (if holiday-list ":" ""))
- (mapconcat 'identity holiday-list "; "))))
- (if (<= (length msg) (frame-width))
- (message msg)
- (set-buffer (get-buffer-create holiday-buffer))
- (setq buffer-read-only nil)
- (calendar-set-mode-line date-string)
- (erase-buffer)
- (insert (mapconcat 'identity holiday-list "\n"))
- (goto-char (point-min))
- (set-buffer-modified-p nil)
- (setq buffer-read-only t)
- (display-buffer holiday-buffer)
- (message "No diary entries for %s" date-string)))
- (save-excursion;; Prepare the fancy diary buffer.
- (set-buffer (make-fancy-diary-buffer))
- (setq buffer-read-only nil)
- (let ((entry-list diary-entries-list)
- (holiday-list)
- (holiday-list-last-month 1)
- (holiday-list-last-year 1)
- (date (list 0 0 0)))
- (while entry-list
- (if (not (calendar-date-equal date (car (car entry-list))))
- (progn
- (setq date (car (car entry-list)))
- (and holidays-in-diary-buffer
- (calendar-date-compare
- (list (list holiday-list-last-month
- (calendar-last-day-of-month
- holiday-list-last-month
- holiday-list-last-year)
- holiday-list-last-year))
- (list date))
- ;; We need to get the holidays for the next 3 months.
- (setq holiday-list-last-month
- (extract-calendar-month date))
- (setq holiday-list-last-year
- (extract-calendar-year date))
- (increment-calendar-month
- holiday-list-last-month holiday-list-last-year 1)
- (setq holiday-list
- (let ((displayed-month holiday-list-last-month)
- (displayed-year holiday-list-last-year))
- (calendar-holiday-list)))
- (increment-calendar-month
- holiday-list-last-month holiday-list-last-year 1))
- (let* ((date-string (calendar-date-string date))
- (date-holiday-list
- (let ((h holiday-list)
- (d))
- ;; Make a list of all holidays for date.
- (while h
- (if (calendar-date-equal date (car (car h)))
- (setq d (append d (cdr (car h)))))
- (setq h (cdr h)))
- d)))
- (insert (if (= (point) (point-min)) "" ?\n) date-string)
- (if date-holiday-list (insert ": "))
- (let ((l (current-column)))
- (insert (mapconcat 'identity date-holiday-list
- (concat "\n" (make-string l ? )))))
- (let ((l (current-column)))
- (insert ?\n (make-string l ?=) ?\n)))))
- (if (< 0 (length (car (cdr (car entry-list)))))
- (insert (car (cdr (car entry-list))) ?\n))
- (setq entry-list (cdr entry-list))))
- (set-buffer-modified-p nil)
- (goto-char (point-min))
- (setq buffer-read-only t)
- (display-buffer fancy-diary-buffer)
- (message "Preparing diary...done"))))
-
-(defun make-fancy-diary-buffer ()
- "Create and return the initial fancy diary buffer."
- (save-excursion
- (set-buffer (get-buffer-create fancy-diary-buffer))
- (setq buffer-read-only nil)
- (make-local-variable 'mode-line-format)
- (calendar-set-mode-line "Diary Entries")
- (erase-buffer)
- (set-buffer-modified-p nil)
- (setq buffer-read-only t)
- (get-buffer fancy-diary-buffer)))
-
-(defun print-diary-entries ()
- "Print a hard copy of the diary display.
-
-If the simple diary display is being used, prepare a temp buffer with the
-visible lines of the diary buffer, add a heading line composed from the mode
-line, print the temp buffer, and destroy it.
-
-If the fancy diary display is being used, just print the buffer.
-
-The hooks given by the variable `print-diary-entries-hook' are called to do
-the actual printing."
- (interactive)
- (if (bufferp (get-buffer fancy-diary-buffer))
- (save-excursion
- (set-buffer (get-buffer fancy-diary-buffer))
- (run-hooks 'print-diary-entries-hook))
- (let ((diary-buffer
- (get-file-buffer (substitute-in-file-name diary-file))))
- (if diary-buffer
- (let ((temp-buffer (get-buffer-create "*Printable Diary Entries*"))
- (heading))
- (save-excursion
- (set-buffer diary-buffer)
- (setq heading
- (if (not (stringp mode-line-format))
- "All Diary Entries"
- (string-match "^-*\\([^-].*[^-]\\)-*$" mode-line-format)
- (substring mode-line-format
- (match-beginning 1) (match-end 1))))
- (copy-to-buffer temp-buffer (point-min) (point-max))
- (set-buffer temp-buffer)
- (while (re-search-forward "\^M.*$" nil t)
- (replace-match ""))
- (goto-char (point-min))
- (insert heading "\n"
- (make-string (length heading) ?=) "\n")
- (run-hooks 'print-diary-entries-hook)
- (kill-buffer temp-buffer)))
- (error "You don't have a diary buffer!")))))
-
-(defun show-all-diary-entries ()
- "Show all of the diary entries in the diary file.
-This function gets rid of the selective display of the diary file so that
-all entries, not just some, are visible. If there is no diary buffer, one
-is created."
- (interactive)
- (let ((d-file (substitute-in-file-name diary-file)))
- (if (and d-file (file-exists-p d-file))
- (if (file-readable-p d-file)
- (save-excursion
- (let ((diary-buffer (get-file-buffer d-file)))
- (set-buffer (if diary-buffer
- diary-buffer
- (find-file-noselect d-file t)))
- (let ((buffer-read-only nil)
- (diary-modified (buffer-modified-p)))
- (subst-char-in-region (point-min) (point-max) ?\^M ?\n t)
- (setq selective-display nil)
- (make-local-variable 'mode-line-format)
- (setq mode-line-format default-mode-line-format)
- (display-buffer (current-buffer))
- (set-buffer-modified-p diary-modified))))
- (error "Your diary file is not readable!"))
- (error "You don't have a diary file!"))))
-
-(defun diary-name-pattern (string-array &optional fullname)
- "Convert an STRING-ARRAY, an array of strings to a pattern.
-The pattern will match any of the strings, either entirely or abbreviated
-to three characters. An abbreviated form will match with or without a period;
-If the optional FULLNAME is t, abbreviations will not match, just the full
-name."
- (let ((pattern ""))
- (calendar-for-loop i from 0 to (1- (length string-array)) do
- (setq pattern
- (concat
- pattern
- (if (string-equal pattern "") "" "\\|")
- (aref string-array i)
- (if fullname
- ""
- (concat
- "\\|"
- (substring (aref string-array i) 0 3) ".?")))))
- pattern))
-
-(defun mark-diary-entries ()
- "Mark days in the calendar window that have diary entries.
-Each entry in the diary file visible in the calendar window is marked.
-After the entries are marked, the hooks `nongregorian-diary-marking-hook' and
-`mark-diary-entries-hook' are run."
- (interactive)
- (setq mark-diary-entries-in-calendar t)
- (let ((d-file (substitute-in-file-name diary-file)))
- (if (and d-file (file-exists-p d-file))
- (if (file-readable-p d-file)
- (save-excursion
- (message "Marking diary entries...")
- (set-buffer (find-file-noselect d-file t))
- (let ((d diary-date-forms)
- (old-diary-syntax-table))
- (setq old-diary-syntax-table (syntax-table))
- (set-syntax-table diary-syntax-table)
- (while d
- (let*
- ((date-form (if (equal (car (car d)) 'backup)
- (cdr (car d))
- (car d)));; ignore 'backup directive
- (dayname (diary-name-pattern calendar-day-name-array))
- (monthname
- (concat
- (diary-name-pattern calendar-month-name-array)
- "\\|\\*"))
- (month "[0-9]+\\|\\*")
- (day "[0-9]+\\|\\*")
- (year "[0-9]+\\|\\*")
- (l (length date-form))
- (d-name-pos (- l (length (memq 'dayname date-form))))
- (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos)))
- (m-name-pos (- l (length (memq 'monthname date-form))))
- (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos)))
- (d-pos (- l (length (memq 'day date-form))))
- (d-pos (if (/= l d-pos) (+ 2 d-pos)))
- (m-pos (- l (length (memq 'month date-form))))
- (m-pos (if (/= l m-pos) (+ 2 m-pos)))
- (y-pos (- l (length (memq 'year date-form))))
- (y-pos (if (/= l y-pos) (+ 2 y-pos)))
- (regexp
- (concat
- "\\(\\`\\|\^M\\|\n\\)\\("
- (mapconcat 'eval date-form "\\)\\(")
- "\\)"))
- (case-fold-search t))
- (goto-char (point-min))
- (while (re-search-forward regexp nil t)
- (let* ((dd-name
- (if d-name-pos
- (buffer-substring
- (match-beginning d-name-pos)
- (match-end d-name-pos))))
- (mm-name
- (if m-name-pos
- (buffer-substring
- (match-beginning m-name-pos)
- (match-end m-name-pos))))
- (mm (string-to-int
- (if m-pos
- (buffer-substring
- (match-beginning m-pos)
- (match-end m-pos))
- "")))
- (dd (string-to-int
- (if d-pos
- (buffer-substring
- (match-beginning d-pos)
- (match-end d-pos))
- "")))
- (y-str (if y-pos
- (buffer-substring
- (match-beginning y-pos)
- (match-end y-pos))))
- (yy (if (not y-str)
- 0
- (if (and (= (length y-str) 2)
- abbreviated-calendar-year)
- (let* ((current-y
- (extract-calendar-year
- (calendar-current-date)))
- (y (+ (string-to-int y-str)
- (* 100
- (/ current-y 100)))))
- (if (> (- y current-y) 50)
- (- y 100)
- (if (> (- current-y y) 50)
- (+ y 100)
- y)))
- (string-to-int y-str)))))
- (if dd-name
- (mark-calendar-days-named
- (cdr (assoc (capitalize (substring dd-name 0 3))
- (calendar-make-alist
- calendar-day-name-array
- 0
- '(lambda (x) (substring x 0 3))))))
- (if mm-name
- (if (string-equal mm-name "*")
- (setq mm 0)
- (setq mm
- (cdr (assoc
- (capitalize
- (substring mm-name 0 3))
- (calendar-make-alist
- calendar-month-name-array
- 1
- '(lambda (x) (substring x 0 3)))
- )))))
- (mark-calendar-date-pattern mm dd yy))))
- (setq d (cdr d))))
- (mark-sexp-diary-entries)
- (run-hooks 'nongregorian-diary-marking-hook
- 'mark-diary-entries-hook)
- (set-syntax-table old-diary-syntax-table)
- (message "Marking diary entries...done")))
- (error "Your diary file is not readable!"))
- (error "You don't have a diary file!"))))
-
-(defun mark-sexp-diary-entries ()
- "Mark days in the calendar window that have sexp diary entries.
-Each entry in the diary file (or included files) visible in the calendar window
-is marked. See the documentation for the function `list-sexp-diary-entries'."
- (let* ((sexp-mark (regexp-quote sexp-diary-entry-symbol))
- (s-entry (concat "\\(\\`\\|\^M\\|\n\\)" sexp-mark "("))
- (m)
- (y)
- (first-date)
- (last-date))
- (save-excursion
- (set-buffer calendar-buffer)
- (setq m displayed-month)
- (setq y displayed-year))
- (increment-calendar-month m y -1)
- (setq first-date
- (calendar-absolute-from-gregorian (list m 1 y)))
- (increment-calendar-month m y 2)
- (setq last-date
- (calendar-absolute-from-gregorian
- (list m (calendar-last-day-of-month m y) y)))
- (goto-char (point-min))
- (while (re-search-forward s-entry nil t)
- (backward-char 1)
- (let ((sexp-start (point))
- (sexp)
- (entry)
- (entry-start)
- (line-start))
- (forward-sexp)
- (setq sexp (buffer-substring sexp-start (point)))
- (save-excursion
- (re-search-backward "\^M\\|\n\\|\\`")
- (setq line-start (point)))
- (forward-char 1)
- (if (and (or (char-equal (preceding-char) ?\^M)
- (char-equal (preceding-char) ?\n))
- (not (looking-at " \\|\^I")))
- (progn;; Diary entry consists only of the sexp
- (backward-char 1)
- (setq entry ""))
- (setq entry-start (point))
- (re-search-forward "\^M\\|\n" nil t)
- (while (looking-at " \\|\^I")
- (re-search-forward "\^M\\|\n" nil t))
- (backward-char 1)
- (setq entry (buffer-substring entry-start (point)))
- (while (string-match "[\^M]" entry)
- (aset entry (match-beginning 0) ?\n )))
- (calendar-for-loop date from first-date to last-date do
- (if (diary-sexp-entry sexp entry
- (calendar-gregorian-from-absolute date))
- (mark-visible-calendar-date
- (calendar-gregorian-from-absolute date))))))))
-
-(defun mark-included-diary-files ()
- "Mark the diary entries from other diary files with those of the diary file.
-This function is suitable for use as the `mark-diary-entries-hook'; it enables
-you to use shared diary files together with your own. The files included are
-specified in the diary-file by lines of this form:
- #include \"filename\"
-This is recursive; that is, #include directives in diary files thus included
-are obeyed. You can change the `#include' to some other string by
-changing the variable `diary-include-string'."
- (goto-char (point-min))
- (while (re-search-forward
- (concat
- "\\(\\`\\|\^M\\|\n\\)"
- (regexp-quote diary-include-string)
- " \"\\([^\"]*\\)\"")
- nil t)
- (let ((diary-file (substitute-in-file-name
- (buffer-substring (match-beginning 2) (match-end 2))))
- (mark-diary-entries-hook 'mark-included-diary-files))
- (if (file-exists-p diary-file)
- (if (file-readable-p diary-file)
- (progn
- (mark-diary-entries)
- (kill-buffer (get-file-buffer diary-file)))
- (beep)
- (message "Can't read included diary file %s" diary-file)
- (sleep-for 2))
- (beep)
- (message "Can't find included diary file %s" diary-file)
- (sleep-for 2))))
- (goto-char (point-min)))
-
-(defun mark-calendar-days-named (dayname)
- "Mark all dates in the calendar window that are day DAYNAME of the week.
-0 means all Sundays, 1 means all Mondays, and so on."
- (save-excursion
- (set-buffer calendar-buffer)
- (let ((prev-month displayed-month)
- (prev-year displayed-year)
- (succ-month displayed-month)
- (succ-year displayed-year)
- (last-day)
- (day))
- (increment-calendar-month succ-month succ-year 1)
- (increment-calendar-month prev-month prev-year -1)
- (setq day (calendar-absolute-from-gregorian
- (calendar-nth-named-day 1 dayname prev-month prev-year)))
- (setq last-day (calendar-absolute-from-gregorian
- (calendar-nth-named-day -1 dayname succ-month succ-year)))
- (while (<= day last-day)
- (mark-visible-calendar-date (calendar-gregorian-from-absolute day))
- (setq day (+ day 7))))))
-
-(defun mark-calendar-date-pattern (month day year)
- "Mark all dates in the calendar window that conform to MONTH/DAY/YEAR.
-A value of 0 in any position is a wildcard."
- (save-excursion
- (set-buffer calendar-buffer)
- (let ((m displayed-month)
- (y displayed-year))
- (increment-calendar-month m y -1)
- (calendar-for-loop i from 0 to 2 do
- (mark-calendar-month m y month day year)
- (increment-calendar-month m y 1)))))
-
-(defun mark-calendar-month (month year p-month p-day p-year)
- "Mark dates in the MONTH/YEAR that conform to pattern P-MONTH/P_DAY/P-YEAR.
-A value of 0 in any position of the pattern is a wildcard."
- (if (or (and (= month p-month)
- (or (= p-year 0) (= year p-year)))
- (and (= p-month 0)
- (or (= p-year 0) (= year p-year))))
- (if (= p-day 0)
- (calendar-for-loop
- i from 1 to (calendar-last-day-of-month month year) do
- (mark-visible-calendar-date (list month i year)))
- (mark-visible-calendar-date (list month p-day year)))))
-
-(defun sort-diary-entries ()
- "Sort the list of diary entries by time of day."
- (setq diary-entries-list (sort diary-entries-list 'diary-entry-compare)))
-
-(defun diary-entry-compare (e1 e2)
- "Returns t if E1 is earlier than E2."
- (or (calendar-date-compare e1 e2)
- (and (calendar-date-equal (car e1) (car e2))
- (< (diary-entry-time (car (cdr e1)))
- (diary-entry-time (car (cdr e2)))))))
-
-(defun diary-entry-time (s)
- "Time at the beginning of the string S in a military-style integer.
-For example, returns 1325 for 1:25pm. Returns -9999 if no time is recognized.
-The recognized forms are XXXX or X:XX or XX:XX (military time), XXam or XXpm,
-and XX:XXam or XX:XXpm."
- (cond ((string-match;; Military time
- "^[ \t]*\\([0-9]?[0-9]\\):?\\([0-9][0-9]\\)\\(\\>\\|[^ap]\\)" s)
- (+ (* 100 (string-to-int
- (substring s (match-beginning 1) (match-end 1))))
- (string-to-int (substring s (match-beginning 2) (match-end 2)))))
- ((string-match;; Hour only XXam or XXpm
- "^[ \t]*\\([0-9]?[0-9]\\)\\([ap]\\)m\\>" s)
- (+ (* 100 (% (string-to-int
- (substring s (match-beginning 1) (match-end 1)))
- 12))
- (if (string-equal "a"
- (substring s (match-beginning 2) (match-end 2)))
- 0 1200)))
- ((string-match;; Hour and minute XX:XXam or XX:XXpm
- "^[ \t]*\\([0-9]?[0-9]\\):\\([0-9][0-9]\\)\\([ap]\\)m\\>" s)
- (+ (* 100 (% (string-to-int
- (substring s (match-beginning 1) (match-end 1)))
- 12))
- (string-to-int (substring s (match-beginning 2) (match-end 2)))
- (if (string-equal "a"
- (substring s (match-beginning 3) (match-end 3)))
- 0 1200)))
- (t -9999)));; Unrecognizable
-
-(defun list-hebrew-diary-entries ()
- "Add any Hebrew date entries from the diary file to `diary-entries-list'.
-Hebrew date diary entries must be prefaced by `hebrew-diary-entry-symbol'
-\(normally an `H'). The same diary date forms govern the style of the Hebrew
-calendar entries, except that the Hebrew month names must be spelled in full.
-The Hebrew months are numbered from 1 to 13 with Nisan being 1, 12 being
-Adar I and 13 being Adar II; you must use `Adar I' if you want Adar of a
-common Hebrew year. If a Hebrew date diary entry begins with a
-`diary-nonmarking-symbol', the entry will appear in the diary listing, but will
-not be marked in the calendar. This function is provided for use with the
-`nongregorian-diary-listing-hook'."
- (if (< 0 number)
- (let ((buffer-read-only nil)
- (diary-modified (buffer-modified-p))
- (gdate original-date)
- (mark (regexp-quote diary-nonmarking-symbol)))
- (calendar-for-loop i from 1 to number do
- (let* ((d diary-date-forms)
- (hdate (calendar-hebrew-from-absolute
- (calendar-absolute-from-gregorian gdate)))
- (month (extract-calendar-month hdate))
- (day (extract-calendar-day hdate))
- (year (extract-calendar-year hdate)))
- (while d
- (let*
- ((date-form (if (equal (car (car d)) 'backup)
- (cdr (car d))
- (car d)))
- (backup (equal (car (car d)) 'backup))
- (dayname
- (concat
- (calendar-day-name gdate) "\\|"
- (substring (calendar-day-name gdate) 0 3) ".?"))
- (calendar-month-name-array
- calendar-hebrew-month-name-array-leap-year)
- (monthname
- (concat
- "\\*\\|"
- (calendar-month-name month)))
- (month (concat "\\*\\|0*" (int-to-string month)))
- (day (concat "\\*\\|0*" (int-to-string day)))
- (year
- (concat
- "\\*\\|0*" (int-to-string year)
- (if abbreviated-calendar-year
- (concat "\\|" (int-to-string (% year 100)))
- "")))
- (regexp
- (concat
- "\\(\\`\\|\^M\\|\n\\)" mark "?"
- (regexp-quote hebrew-diary-entry-symbol)
- "\\("
- (mapconcat 'eval date-form "\\)\\(")
- "\\)"))
- (case-fold-search t))
- (goto-char (point-min))
- (while (re-search-forward regexp nil t)
- (if backup (re-search-backward "\\<" nil t))
- (if (and (or (char-equal (preceding-char) ?\^M)
- (char-equal (preceding-char) ?\n))
- (not (looking-at " \\|\^I")))
- ;; Diary entry that consists only of date.
- (backward-char 1)
- ;; Found a nonempty diary entry--make it visible and
- ;; add it to the list.
- (let ((entry-start (point))
- (date-start))
- (re-search-backward "\^M\\|\n\\|\\`")
- (setq date-start (point))
- (re-search-forward "\^M\\|\n" nil t 2)
- (while (looking-at " \\|\^I")
- (re-search-forward "\^M\\|\n" nil t))
- (backward-char 1)
- (subst-char-in-region date-start (point) ?\^M ?\n t)
- (add-to-diary-list
- gdate (buffer-substring entry-start (point)))))))
- (setq d (cdr d))))
- (setq gdate
- (calendar-gregorian-from-absolute
- (1+ (calendar-absolute-from-gregorian gdate)))))
- (set-buffer-modified-p diary-modified))
- (goto-char (point-min))))
-
-(defun mark-hebrew-diary-entries ()
- "Mark days in the calendar window that have Hebrew date diary entries.
-Each entry in diary-file (or included files) visible in the calendar window
-is marked. Hebrew date entries are prefaced by a hebrew-diary-entry-symbol
-\(normally an `H'). The same diary-date-forms govern the style of the Hebrew
-calendar entries, except that the Hebrew month names must be spelled in full.
-The Hebrew months are numbered from 1 to 13 with Nisan being 1, 12 being
-Adar I and 13 being Adar II; you must use `Adar I' if you want Adar of a
-common Hebrew year. Hebrew date diary entries that begin with a
-diary-nonmarking symbol will not be marked in the calendar. This function
-is provided for use as part of the nongregorian-diary-marking-hook."
- (let ((d diary-date-forms))
- (while d
- (let*
- ((date-form (if (equal (car (car d)) 'backup)
- (cdr (car d))
- (car d)));; ignore 'backup directive
- (dayname (diary-name-pattern calendar-day-name-array))
- (monthname
- (concat
- (diary-name-pattern calendar-hebrew-month-name-array-leap-year t)
- "\\|\\*"))
- (month "[0-9]+\\|\\*")
- (day "[0-9]+\\|\\*")
- (year "[0-9]+\\|\\*")
- (l (length date-form))
- (d-name-pos (- l (length (memq 'dayname date-form))))
- (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos)))
- (m-name-pos (- l (length (memq 'monthname date-form))))
- (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos)))
- (d-pos (- l (length (memq 'day date-form))))
- (d-pos (if (/= l d-pos) (+ 2 d-pos)))
- (m-pos (- l (length (memq 'month date-form))))
- (m-pos (if (/= l m-pos) (+ 2 m-pos)))
- (y-pos (- l (length (memq 'year date-form))))
- (y-pos (if (/= l y-pos) (+ 2 y-pos)))
- (regexp
- (concat
- "\\(\\`\\|\^M\\|\n\\)"
- (regexp-quote hebrew-diary-entry-symbol)
- "\\("
- (mapconcat 'eval date-form "\\)\\(")
- "\\)"))
- (case-fold-search t))
- (goto-char (point-min))
- (while (re-search-forward regexp nil t)
- (let* ((dd-name
- (if d-name-pos
- (buffer-substring
- (match-beginning d-name-pos)
- (match-end d-name-pos))))
- (mm-name
- (if m-name-pos
- (buffer-substring
- (match-beginning m-name-pos)
- (match-end m-name-pos))))
- (mm (string-to-int
- (if m-pos
- (buffer-substring
- (match-beginning m-pos)
- (match-end m-pos))
- "")))
- (dd (string-to-int
- (if d-pos
- (buffer-substring
- (match-beginning d-pos)
- (match-end d-pos))
- "")))
- (y-str (if y-pos
- (buffer-substring
- (match-beginning y-pos)
- (match-end y-pos))))
- (yy (if (not y-str)
- 0
- (if (and (= (length y-str) 2)
- abbreviated-calendar-year)
- (let* ((current-y
- (extract-calendar-year
- (calendar-hebrew-from-absolute
- (calendar-absolute-from-gregorian
- (calendar-current-date)))))
- (y (+ (string-to-int y-str)
- (* 100 (/ current-y 100)))))
- (if (> (- y current-y) 50)
- (- y 100)
- (if (> (- current-y y) 50)
- (+ y 100)
- y)))
- (string-to-int y-str)))))
- (if dd-name
- (mark-calendar-days-named
- (cdr (assoc (capitalize (substring dd-name 0 3))
- (calendar-make-alist
- calendar-day-name-array
- 0
- '(lambda (x) (substring x 0 3))))))
- (if mm-name
- (if (string-equal mm-name "*")
- (setq mm 0)
- (setq
- mm
- (cdr
- (assoc
- (capitalize mm-name)
- (calendar-make-alist
- calendar-hebrew-month-name-array-leap-year))))))
- (mark-hebrew-calendar-date-pattern mm dd yy)))))
- (setq d (cdr d)))))
-
-(defun mark-hebrew-calendar-date-pattern (month day year)
- "Mark dates in calendar window that conform to Hebrew date MONTH/DAY/YEAR.
-A value of 0 in any position is a wildcard."
- (save-excursion
- (set-buffer calendar-buffer)
- (if (and (/= 0 month) (/= 0 day))
- (if (/= 0 year)
- ;; Fully specified Hebrew date.
- (let ((date (calendar-gregorian-from-absolute
- (calendar-absolute-from-hebrew
- (list month day year)))))
- (if (calendar-date-is-visible-p date)
- (mark-visible-calendar-date date)))
- ;; Month and day in any year--this taken from the holiday stuff.
- (if (memq displayed-month;; This test is only to speed things up a
- (list ;; bit; it works fine without the test too.
- (if (< 11 month) (- month 11) (+ month 1))
- (if (< 10 month) (- month 10) (+ month 2))
- (if (< 9 month) (- month 9) (+ month 3))
- (if (< 8 month) (- month 8) (+ month 4))
- (if (< 7 month) (- month 7) (+ month 5))))
- (let ((m1 displayed-month)
- (y1 displayed-year)
- (m2 displayed-month)
- (y2 displayed-year)
- (year))
- (increment-calendar-month m1 y1 -1)
- (increment-calendar-month m2 y2 1)
- (let* ((start-date (calendar-absolute-from-gregorian
- (list m1 1 y1)))
- (end-date (calendar-absolute-from-gregorian
- (list m2
- (calendar-last-day-of-month m2 y2)
- y2)))
- (hebrew-start
- (calendar-hebrew-from-absolute start-date))
- (hebrew-end (calendar-hebrew-from-absolute end-date))
- (hebrew-y1 (extract-calendar-year hebrew-start))
- (hebrew-y2 (extract-calendar-year hebrew-end)))
- (setq year (if (< 6 month) hebrew-y2 hebrew-y1))
- (let ((date (calendar-gregorian-from-absolute
- (calendar-absolute-from-hebrew
- (list month day year)))))
- (if (calendar-date-is-visible-p date)
- (mark-visible-calendar-date date)))))))
- ;; Not one of the simple cases--check all visible dates for match.
- ;; Actually, the following code takes care of ALL of the cases, but
- ;; it's much too slow to be used for the simple (common) cases.
- (let ((m displayed-month)
- (y displayed-year)
- (first-date)
- (last-date))
- (increment-calendar-month m y -1)
- (setq first-date
- (calendar-absolute-from-gregorian
- (list m 1 y)))
- (increment-calendar-month m y 2)
- (setq last-date
- (calendar-absolute-from-gregorian
- (list m (calendar-last-day-of-month m y) y)))
- (calendar-for-loop date from first-date to last-date do
- (let* ((h-date (calendar-hebrew-from-absolute date))
- (h-month (extract-calendar-month h-date))
- (h-day (extract-calendar-day h-date))
- (h-year (extract-calendar-year h-date)))
- (and (or (zerop month)
- (= month h-month))
- (or (zerop day)
- (= day h-day))
- (or (zerop year)
- (= year h-year))
- (mark-visible-calendar-date
- (calendar-gregorian-from-absolute date)))))))))
-
-(defun list-sexp-diary-entries (date)
- "Add sexp entries for DATE from the diary file to `diary-entries-list'.
-Also, Make them visible in the diary file. Returns t if any entries were
-found.
-
-Sexp diary entries must be prefaced by a `sexp-diary-entry-symbol' (normally
-`%%'). The form of a sexp diary entry is
-
- %%(SEXP) ENTRY
-
-Both ENTRY and DATE are globally available when the SEXP is evaluated. If the
-SEXP yields the value nil, the diary entry does not apply. If it yields a
-non-nil value, ENTRY will be taken to apply to DATE; if the non-nil value is a
-string, that string will be the diary entry in the fancy diary display.
-
-For example, the following diary entry will apply to the 21st of the month
-if it is a weekday and the Friday before if the 21st is on a weekend:
-
- &%%(let ((dayname (calendar-day-of-week date))
- (day (extract-calendar-day date)))
- (or
- (and (= day 21) (memq dayname '(1 2 3 4 5)))
- (and (memq day '(19 20)) (= dayname 5)))
- ) UIUC pay checks deposited
-
-A number of built-in functions are available for this type of diary entry:
-
- %%(diary-float MONTH DAYNAME N) text
- Entry will appear on the Nth DAYNAME of MONTH.
- (DAYNAME=0 means Sunday, 1 means Monday, and so on;
- if N is negative it counts backward from the end of
- the month. MONTH can be a list of months, a single
- month, or t to specify all months.
-
- %%(diary-block M1 D1 Y1 M2 D2 Y2) text
- Entry will appear on dates between M1/D1/Y1 and M2/D2/Y2,
- inclusive. (If `european-calendar-style' is t, the
- order of the parameters should be changed to D1, M1, Y1,
- D2, M2, Y2.)
-
- %%(diary-anniversary MONTH DAY YEAR) text
- Entry will appear on anniversary dates of MONTH DAY, YEAR.
- (If `european-calendar-style' is t, the order of the
- parameters should be changed to DAY, MONTH, YEAR.) Text
- can contain %d or %d%s; %d will be replaced by the number
- of years since the MONTH DAY, YEAR and %s will be replaced
- by the ordinal ending of that number (that is, `st', `nd',
- `rd' or `th', as appropriate. The anniversary of February
- 29 is considered to be March 1 in a non-leap year.
-
- %%(diary-cyclic N MONTH DAY YEAR) text
- Entry will appear every N days, starting MONTH DAY, YEAR.
- (If `european-calendar-style' is t, the order of the
- parameters should be changed to N, DAY, MONTH, YEAR.) Text
- can contain %d or %d%s; %d will be replaced by the number
- of repetitions since the MONTH DAY, YEAR and %s will
- be replaced by the ordinal ending of that number (that is,
- `st', `nd', `rd' or `th', as appropriate.
-
- %%(diary-day-of-year)
- Diary entries giving the day of the year and the number of
- days remaining in the year will be made every day. Note
- that since there is no text, it makes sense only if the
- fancy diary display is used.
-
- %%(diary-iso-date)
- Diary entries giving the corresponding ISO commercial date
- will be made every day. Note that since there is no text,
- it makes sense only if the fancy diary display is used.
-
- %%(diary-french-date)
- Diary entries giving the corresponding French Revolutionary
- date will be made every day. Note that since there is no
- text, it makes sense only if the fancy diary display is used.
-
- %%(diary-islamic-date)
- Diary entries giving the corresponding Islamic date will be
- made every day. Note that since there is no text, it
- makes sense only if the fancy diary display is used.
-
- %%(diary-hebrew-date)
- Diary entries giving the corresponding Hebrew date will be
- made every day. Note that since there is no text, it
- makes sense only if the fancy diary display is used.
-
- %%(diary-astro-day-number) Diary entries giving the corresponding
- astronomical (Julian) day number will be made every day.
- Note that since there is no text, it makes sense only if the
- fancy diary display is used.
-
- %%(diary-julian-date) Diary entries giving the corresponding
- Julian date will be made every day. Note that since
- there is no text, it makes sense only if the fancy diary
- display is used.
-
- %%(diary-sunrise-sunset)
- Diary entries giving the local times of sunrise and sunset
- will be made every day. Note that since there is no text,
- it makes sense only if the fancy diary display is used.
- Floating point required.
-
- %%(diary-phases-of-moon)
- Diary entries giving the times of the phases of the moon
- will be when appropriate. Note that since there is no text,
- it makes sense only if the fancy diary display is used.
- Floating point required.
-
- %%(diary-yahrzeit MONTH DAY YEAR) text
- Text is assumed to be the name of the person; the date is
- the date of death on the *civil* calendar. The diary entry
- will appear on the proper Hebrew-date anniversary and on the
- day before. (If `european-calendar-style' is t, the order
- of the parameters should be changed to DAY, MONTH, YEAR.)
-
- %%(diary-rosh-hodesh)
- Diary entries will be made on the dates of Rosh Hodesh on
- the Hebrew calendar. Note that since there is no text, it
- makes sense only if the fancy diary display is used.
-
- %%(diary-parasha)
- Diary entries giving the weekly parasha will be made on
- every Saturday. Note that since there is no text, it
- makes sense only if the fancy diary display is used.
-
- %%(diary-omer)
- Diary entries giving the omer count will be made every day
- from Passover to Shavuoth. Note that since there is no text,
- it makes sense only if the fancy diary display is used.
-
-Marking these entries is *extremely* time consuming, so these entries are
-best if they are nonmarking."
- (let* ((mark (regexp-quote diary-nonmarking-symbol))
- (sexp-mark (regexp-quote sexp-diary-entry-symbol))
- (s-entry (concat "\\(\\`\\|\^M\\|\n\\)" mark "?" sexp-mark "("))
- (entry-found))
- (goto-char (point-min))
- (while (re-search-forward s-entry nil t)
- (backward-char 1)
- (let ((sexp-start (point))
- (sexp)
- (entry)
- (entry-start)
- (line-start))
- (forward-sexp)
- (setq sexp (buffer-substring sexp-start (point)))
- (save-excursion
- (re-search-backward "\^M\\|\n\\|\\`")
- (setq line-start (point)))
- (forward-char 1)
- (if (and (or (char-equal (preceding-char) ?\^M)
- (char-equal (preceding-char) ?\n))
- (not (looking-at " \\|\^I")))
- (progn;; Diary entry consists only of the sexp
- (backward-char 1)
- (setq entry ""))
- (setq entry-start (point))
- (re-search-forward "\^M\\|\n" nil t)
- (while (looking-at " \\|\^I")
- (re-search-forward "\^M\\|\n" nil t))
- (backward-char 1)
- (setq entry (buffer-substring entry-start (point)))
- (while (string-match "[\^M]" entry)
- (aset entry (match-beginning 0) ?\n )))
- (let ((diary-entry (diary-sexp-entry sexp entry date)))
- (if diary-entry
- (subst-char-in-region line-start (point) ?\^M ?\n t))
- (add-to-diary-list date diary-entry)
- (setq entry-found (or entry-found diary-entry)))))
- entry-found))
-
-(defun diary-sexp-entry (sexp entry date)
- "Process a SEXP diary ENTRY for DATE."
- (let ((result (if calendar-debug-sexp
- (let ((stack-trace-on-error t))
- (eval (car (read-from-string sexp))))
- (condition-case nil
- (eval (car (read-from-string sexp)))
- (error
- (beep)
- (message "Bad sexp at line %d in %s: %s"
- (save-excursion
- (save-restriction
- (narrow-to-region 1 (point))
- (goto-char (point-min))
- (let ((lines 1))
- (while (re-search-forward "\n\\|\^M" nil t)
- (setq lines (1+ lines)))
- lines)))
- diary-file sexp)
- (sleep-for 2))))))
- (if (stringp result)
- result
- (if result
- entry
- nil))))
-
-(defun diary-block (m1 d1 y1 m2 d2 y2)
- "Block diary entry.
-Entry applies if date is between two dates. Order of the parameters is
-M1, D1, Y1, M2, D2, Y2 `european-calendar-style' is nil, and
-D1, M1, Y1, D2, M2, Y2 if `european-calendar-style' is t."
- (let ((date1 (calendar-absolute-from-gregorian
- (if european-calendar-style
- (list d1 m1 y1)
- (list m1 d1 y1))))
- (date2 (calendar-absolute-from-gregorian
- (if european-calendar-style
- (list d2 m2 y2)
- (list m2 d2 y2))))
- (d (calendar-absolute-from-gregorian date)))
- (if (and (<= date1 d) (<= d date2))
- entry)))
-
-(defun diary-float (month dayname n)
- "Floating diary entry--entry applies if date is the nth dayname of month.
-Parameters are MONTH, DAYNAME, N. MONTH can be a list of months, the constant
-t, or an integer. The constant t means all months. If N is negative, count
-backward from the end of the month."
- (let ((m (extract-calendar-month date))
- (y (extract-calendar-year date)))
- (if (and
- (or (and (listp month) (memq m month))
- (equal m month)
- (eq month t))
- (calendar-date-equal date (calendar-nth-named-day n dayname m y)))
- entry)))
-
-(defun diary-anniversary (month day year)
- "Anniversary diary entry.
-Entry applies if date is the anniversary of MONTH, DAY, YEAR if
-`european-calendar-style' is nil, and DAY, MONTH, YEAR if
-`european-calendar-style' is t. Diary entry can contain `%d' or `%d%s'; the
-%d will be replaced by the number of years since the MONTH DAY, YEAR and the
-%s will be replaced by the ordinal ending of that number (that is, `st', `nd',
-`rd' or `th', as appropriate. The anniversary of February 29 is considered
-to be March 1 in non-leap years."
- (let* ((d (if european-calendar-style
- month
- day))
- (m (if european-calendar-style
- day
- month))
- (y (extract-calendar-year date))
- (diff (- y year)))
- (if (and (= m 2) (= d 29) (not (calendar-leap-year-p y)))
- (setq m 3
- d 1))
- (if (and (> diff 0) (calendar-date-equal (list m d y) date))
- (format entry diff (diary-ordinal-suffix diff)))))
-
-(defun diary-cyclic (n month day year)
- "Cycle diary entry--entry applies every N days starting at MONTH, DAY, YEAR.
-If `european-calendar-style' is t, parameters are N, DAY, MONTH, YEAR.
-ENTRY can contain `%d' or `%d%s'; the %d will be replaced by the number of
-years since the MONTH DAY, YEAR and the %s will be replaced by the ordinal
-ending of that number (that is, `st', `nd', `rd' or `th', as appropriate."
- (let* ((d (if european-calendar-style
- month
- day))
- (m (if european-calendar-style
- day
- month))
- (diff (- (calendar-absolute-from-gregorian date)
- (calendar-absolute-from-gregorian
- (list m d year))))
- (cycle (/ diff n)))
- (if (and (>= diff 0) (zerop (% diff n)))
- (format entry cycle (diary-ordinal-suffix cycle)))))
-
-(defun diary-ordinal-suffix (n)
- "Ordinal suffix for N. (That is, `st', `nd', `rd', or `th', as appropriate.)"
- (if (or (memq (% n 100) '(11 12 13))
- (< 3 (% n 10)))
- "th"
- (aref ["th" "st" "nd" "rd"] (% n 10))))
-
-(defun diary-day-of-year ()
- "Day of year and number of days remaining in the year of date diary entry."
- (calendar-day-of-year-string date))
-
-(defun diary-iso-date ()
- "ISO calendar equivalent of date diary entry."
- (format "ISO date: %s" (calendar-iso-date-string date)))
-
-(defun diary-islamic-date ()
- "Islamic calendar equivalent of date diary entry."
- (let ((i (calendar-islamic-date-string (calendar-cursor-to-date t))))
- (if (string-equal i "")
- "Date is pre-Islamic"
- (format "Islamic date (until sunset): %s" i))))
-
-(defun diary-hebrew-date ()
- "Hebrew calendar equivalent of date diary entry."
- (format "Hebrew date (until sunset): %s" (calendar-hebrew-date-string date)))
-
-(defun diary-julian-date ()
- "Julian calendar equivalent of date diary entry."
- (format "Julian date: %s" (calendar-julian-date-string date)))
-
-(defun diary-astro-day-number ()
- "Astronomical (Julian) day number diary entry."
- (format "Astronomical (Julian) day number %s"
- (calendar-astro-date-string date)))
-
-(defun diary-omer ()
- "Omer count diary entry.
-Entry applies if date is within 50 days after Passover."
- (let* ((passover
- (calendar-absolute-from-hebrew
- (list 1 15 (+ (extract-calendar-year date) 3760))))
- (omer (- (calendar-absolute-from-gregorian date) passover))
- (week (/ omer 7))
- (day (% omer 7)))
- (if (and (> omer 0) (< omer 50))
- (format "Day %d%s of the omer (until sunset)"
- omer
- (if (zerop week)
- ""
- (format ", that is, %d week%s%s"
- week
- (if (= week 1) "" "s")
- (if (zerop day)
- ""
- (format " and %d day%s"
- day (if (= day 1) "" "s")))))))))
-
-(defun diary-yahrzeit (death-month death-day death-year)
- "Yahrzeit diary entry--entry applies if date is yahrzeit or the day before.
-Parameters are DEATH-MONTH, DEATH-DAY, DEATH-YEAR; the diary entry is assumed
-to be the name of the person. Date of death is on the *civil* calendar;
-although the date of death is specified by the civil calendar, the proper
-Hebrew calendar yahrzeit is determined. If `european-calendar-style' is t, the
-order of the parameters is changed to DEATH-DAY, DEATH-MONTH, DEATH-YEAR."
- (let* ((h-date (calendar-hebrew-from-absolute
- (calendar-absolute-from-gregorian
- (if european-calendar-style
- (list death-day death-month death-year)
- (list death-month death-day death-year)))))
- (h-month (extract-calendar-month h-date))
- (h-day (extract-calendar-day h-date))
- (h-year (extract-calendar-year h-date))
- (d (calendar-absolute-from-gregorian date))
- (yr (extract-calendar-year (calendar-hebrew-from-absolute d)))
- (diff (- yr h-year))
- (y (hebrew-calendar-yahrzeit h-date yr)))
- (if (and (> diff 0) (or (= y d) (= y (1+ d))))
- (format "Yahrzeit of %s%s: %d%s anniversary"
- entry
- (if (= y d) "" " (evening)")
- diff
- (cond ((= (% diff 10) 1) "st")
- ((= (% diff 10) 2) "nd")
- ((= (% diff 10) 3) "rd")
- (t "th"))))))
-
-(defun diary-rosh-hodesh ()
- "Rosh Hodesh diary entry.
-Entry applies if date is Rosh Hodesh, the day before, or the Saturday before."
- (let* ((d (calendar-absolute-from-gregorian date))
- (h-date (calendar-hebrew-from-absolute d))
- (h-month (extract-calendar-month h-date))
- (h-day (extract-calendar-day h-date))
- (h-year (extract-calendar-year h-date))
- (leap-year (hebrew-calendar-leap-year-p h-year))
- (last-day (hebrew-calendar-last-day-of-month h-month h-year))
- (h-month-names
- (if leap-year
- calendar-hebrew-month-name-array-leap-year
- calendar-hebrew-month-name-array-common-year))
- (this-month (aref h-month-names (1- h-month)))
- (h-yesterday (extract-calendar-day
- (calendar-hebrew-from-absolute (1- d)))))
- (if (or (= h-day 30) (and (= h-day 1) (/= h-month 7)))
- (format
- "Rosh Hodesh %s"
- (if (= h-day 30)
- (format
- "%s (first day)"
- ;; next month must be in the same year since this
- ;; month can't be the last month of the year since
- ;; it has 30 days
- (aref h-month-names h-month))
- (if (= h-yesterday 30)
- (format "%s (second day)" this-month)
- this-month)))
- (if (= (% d 7) 6);; Saturday--check for Shabbat Mevarhim
- (cond ((and (> h-day 22) (/= h-month 6) (= 29 last-day))
- (format "Mevarhim Rosh Hodesh %s (%s)"
- (aref h-month-names
- (if (= h-month
- (hebrew-calendar-last-month-of-year
- h-year))
- 0 h-month))
- (aref calendar-day-name-array (- 29 h-day))))
- ((and (< h-day 30) (> h-day 22) (= 30 last-day))
- (format "Mevarhim Rosh Hodesh %s (%s-%s)"
- (aref h-month-names h-month)
- (if (= h-day 29)
- "tomorrow"
- (aref calendar-day-name-array (- 29 h-day)))
- (aref calendar-day-name-array
- (% (- 30 h-day) 7)))))
- (if (and (= h-day 29) (/= h-month 6))
- (format "Erev Rosh Hodesh %s"
- (aref h-month-names
- (if (= h-month
- (hebrew-calendar-last-month-of-year
- h-year))
- 0 h-month))))))))
-
-(defun diary-parasha ()
- "Parasha diary entry--entry applies if date is a Saturday."
- (let ((d (calendar-absolute-from-gregorian date)))
- (if (= (% d 7) 6);; Saturday
- (let*
- ((h-year (extract-calendar-year
- (calendar-hebrew-from-absolute d)))
- (rosh-hashannah
- (calendar-absolute-from-hebrew (list 7 1 h-year)))
- (passover
- (calendar-absolute-from-hebrew (list 1 15 h-year)))
- (rosh-hashannah-day
- (aref calendar-day-name-array (% rosh-hashannah 7)))
- (passover-day
- (aref calendar-day-name-array (% passover 7)))
- (long-h (hebrew-calendar-long-heshvan-p h-year))
- (short-k (hebrew-calendar-short-kislev-p h-year))
- (type (cond ((and long-h (not short-k)) "complete")
- ((and (not long-h) short-k) "incomplete")
- (t "regular")))
- (year-format
- (symbol-value
- (intern (format "hebrew-calendar-year-%s-%s-%s";; keviah
- rosh-hashannah-day type passover-day))))
- (first-saturday;; of Hebrew year
- (calendar-dayname-on-or-before 6 (+ 6 rosh-hashannah)))
- (saturday;; which Saturday of the Hebrew year
- (/ (- d first-saturday) 7))
- (parasha (aref year-format saturday)))
- (if parasha
- (format
- "Parashat %s"
- (if (listp parasha);; Israel differs from diaspora
- (if (car parasha)
- (format "%s (diaspora), %s (Israel)"
- (hebrew-calendar-parasha-name (car parasha))
- (hebrew-calendar-parasha-name (cdr parasha)))
- (format "%s (Israel)"
- (hebrew-calendar-parasha-name (cdr parasha))))
- (hebrew-calendar-parasha-name parasha))))))))
-
-(defun add-to-diary-list (date string)
- "Add the entry (DATE STRING) to `diary-entries-list'.
-Do nothing if DATE or STRING is nil."
- (and date string
- (setq diary-entries-list
- (append diary-entries-list (list (list date string))))))
-
-(defvar hebrew-calendar-parashiot-names
-["Bereshith" "Noah" "Lech L'cha" "Vayera" "Hayei Sarah" "Toledoth"
- "Vayetze" "Vayishlah" "Vayeshev" "Mikketz" "Vayiggash" "Vayhi"
- "Shemoth" "Vaera" "Bo" "Beshallah" "Yithro" "Mishpatim"
- "Terumah" "Tetzavveh" "Ki Tissa" "Vayakhel" "Pekudei" "Vayikra"
- "Tzav" "Shemini" "Tazria" "Metzora" "Aharei Moth" "Kedoshim"
- "Emor" "Behar" "Behukkotai" "Bemidbar" "Naso" "Behaalot'cha"
- "Shelah L'cha" "Korah" "Hukkath" "Balak" "Pinhas" "Mattoth"
- "Masei" "Devarim" "Vaethanan" "Ekev" "Reeh" "Shofetim"
- "Ki Tetze" "Ki Tavo" "Nitzavim" "Vayelech" "Haazinu"]
- "The names of the parashiot in the Torah.")
-
-;; The seven ordinary year types (keviot)
-
-(defconst hebrew-calendar-year-Saturday-incomplete-Sunday
- [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
- 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
- 43 44 45 46 47 48 49 50]
- "The structure of the parashiot.
-Hebrew year starts on Saturday, is `incomplete' (Heshvan and Kislev each have
-29 days), and has Passover start on Sunday.")
-
-(defconst hebrew-calendar-year-Saturday-complete-Tuesday
- [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
- 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
- 43 44 45 46 47 48 49 [50 51]]
- "The structure of the parashiot.
-Hebrew year that starts on Saturday, is `complete' (Heshvan and Kislev each
-have 30 days), and has Passover start on Tuesday.")
-
-(defconst hebrew-calendar-year-Monday-incomplete-Tuesday
- [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
- 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
- 43 44 45 46 47 48 49 [50 51]]
- "The structure of the parashiot.
-Hebrew year that starts on Monday, is `incomplete' (Heshvan and Kislev each
-have 29 days), and has Passover start on Tuesday.")
-
-(defconst hebrew-calendar-year-Monday-complete-Thursday
- [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
- 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 (nil . 34) (34 . 35) (35 . 36)
- (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
- "The structure of the parashiot.
-Hebrew year that starts on Monday, is `complete' (Heshvan and Kislev each have
-30 days), and has Passover start on Thursday.")
-
-(defconst hebrew-calendar-year-Tuesday-regular-Thursday
- [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
- 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 (nil . 34) (34 . 35) (35 . 36)
- (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
- "The structure of the parashiot.
-Hebrew year that starts on Tuesday, is `regular' (Heshvan has 29 days and
-Kislev has 30 days), and has Passover start on Thursday.")
-
-(defconst hebrew-calendar-year-Thursday-regular-Saturday
- [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] 23
- 24 nil (nil . 25) (25 . [26 27]) ([26 27] . [28 29]) ([28 29] . 30)
- (30 . 31) ([31 32] . 32) 33 34 35 36 37 38 39 40 [41 42] 43 44 45 46 47 48
- 49 50]
- "The structure of the parashiot.
-Hebrew year that starts on Thursday, is `regular' (Heshvan has 29 days and
-Kislev has 30 days), and has Passover start on Saturday.")
-
-(defconst hebrew-calendar-year-Thursday-complete-Sunday
- [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
- 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
- 43 44 45 46 47 48 49 50]
- "The structure of the parashiot.
-Hebrew year that starts on Thursday, is `complete' (Heshvan and Kislev each
-have 30 days), and has Passover start on Sunday.")
-
-;; The seven leap year types (keviot)
-
-(defconst hebrew-calendar-year-Saturday-incomplete-Tuesday
- [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
- 23 24 25 26 27 nil 28 29 30 31 32 33 34 35 36 37 38 39 40 [41 42]
- 43 44 45 46 47 48 49 [50 51]]
- "The structure of the parashiot.
-Hebrew year that starts on Saturday, is `incomplete' (Heshvan and Kislev each
-have 29 days), and has Passover start on Tuesday.")
-
-(defconst hebrew-calendar-year-Saturday-complete-Thursday
- [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
- 23 24 25 26 27 nil 28 29 30 31 32 33 (nil . 34) (34 . 35) (35 . 36)
- (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
- "The structure of the parashiot.
-Hebrew year that starts on Saturday, is `complete' (Heshvan and Kislev each
-have 30 days), and has Passover start on Thursday.")
-
-(defconst hebrew-calendar-year-Monday-incomplete-Thursday
- [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
- 23 24 25 26 27 nil 28 29 30 31 32 33 (nil . 34) (34 . 35) (35 . 36)
- (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
- "The structure of the parashiot.
-Hebrew year that starts on Monday, is `incomplete' (Heshvan and Kislev each
-have 29 days), and has Passover start on Thursday.")
-
-(defconst hebrew-calendar-year-Monday-complete-Saturday
- [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
- 23 24 25 26 27 nil (nil . 28) (28 . 29) (29 . 30) (30 . 31) (31 . 32)
- (32 . 33) (33 . 34) (34 . 35) (35 . 36) (36 . 37) (37 . 38) (38 . 39)
- (39 . 40) (40 . 41) ([41 42] . 42) 43 44 45 46 47 48 49 50]
- "The structure of the parashiot.
-Hebrew year that starts on Monday, is `complete' (Heshvan and Kislev each have
-30 days), and has Passover start on Saturday.")
-
-(defconst hebrew-calendar-year-Tuesday-regular-Saturday
- [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
- 23 24 25 26 27 nil (nil . 28) (28 . 29) (29 . 30) (30 . 31) (31 . 32)
- (32 . 33) (33 . 34) (34 . 35) (35 . 36) (36 . 37) (37 . 38) (38 . 39)
- (39 . 40) (40 . 41) ([41 42] . 42) 43 44 45 46 47 48 49 50]
- "The structure of the parashiot.
-Hebrew year that starts on Tuesday, is `regular' (Heshvan has 29 days and
-Kislev has 30 days), and has Passover start on Saturday.")
-
-(defconst hebrew-calendar-year-Thursday-incomplete-Sunday
- [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
- 23 24 25 26 27 28 nil 29 30 31 32 33 34 35 36 37 38 39 40 41 42
- 43 44 45 46 47 48 49 50]
- "The structure of the parashiot.
-Hebrew year that starts on Thursday, is `incomplete' (Heshvan and Kislev both
-have 29 days), and has Passover start on Sunday.")
-
-(defconst hebrew-calendar-year-Thursday-complete-Tuesday
- [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
- 23 24 25 26 27 28 nil 29 30 31 32 33 34 35 36 37 38 39 40 41 42
- 43 44 45 46 47 48 49 [50 51]]
- "The structure of the parashiot.
-Hebrew year that starts on Thursday, is `complete' (Heshvan and Kislev both
-have 30 days), and has Passover start on Tuesday.")
-
-(defun hebrew-calendar-parasha-name (p)
- "Name(s) corresponding to parasha P."
- (if (arrayp p);; combined parasha
- (format "%s/%s"
- (aref hebrew-calendar-parashiot-names (aref p 0))
- (aref hebrew-calendar-parashiot-names (aref p 1)))
- (aref hebrew-calendar-parashiot-names p)))
-
-(defun list-islamic-diary-entries ()
- "Add any Islamic date entries from the diary file to `diary-entries-list'.
-Islamic date diary entries must be prefaced by an `islamic-diary-entry-symbol'
-\(normally an `I'). The same diary date forms govern the style of the Islamic
-calendar entries, except that the Islamic month names must be spelled in full.
-The Islamic months are numbered from 1 to 12 with Muharram being 1 and 12 being
-Dhu al-Hijjah. If an Islamic date diary entry begins with a
-`diary-nonmarking-symbol', the entry will appear in the diary listing, but will
-not be marked in the calendar. This function is provided for use with the
-`nongregorian-diary-listing-hook'."
- (if (< 0 number)
- (let ((buffer-read-only nil)
- (diary-modified (buffer-modified-p))
- (gdate original-date)
- (mark (regexp-quote diary-nonmarking-symbol)))
- (calendar-for-loop i from 1 to number do
- (let* ((d diary-date-forms)
- (idate (calendar-islamic-from-absolute
- (calendar-absolute-from-gregorian gdate)))
- (month (extract-calendar-month idate))
- (day (extract-calendar-day idate))
- (year (extract-calendar-year idate)))
- (while d
- (let*
- ((date-form (if (equal (car (car d)) 'backup)
- (cdr (car d))
- (car d)))
- (backup (equal (car (car d)) 'backup))
- (dayname
- (concat
- (calendar-day-name gdate) "\\|"
- (substring (calendar-day-name gdate) 0 3) ".?"))
- (calendar-month-name-array
- calendar-islamic-month-name-array)
- (monthname
- (concat
- "\\*\\|"
- (calendar-month-name month)))
- (month (concat "\\*\\|0*" (int-to-string month)))
- (day (concat "\\*\\|0*" (int-to-string day)))
- (year
- (concat
- "\\*\\|0*" (int-to-string year)
- (if abbreviated-calendar-year
- (concat "\\|" (int-to-string (% year 100)))
- "")))
- (regexp
- (concat
- "\\(\\`\\|\^M\\|\n\\)" mark "?"
- (regexp-quote islamic-diary-entry-symbol)
- "\\("
- (mapconcat 'eval date-form "\\)\\(")
- "\\)"))
- (case-fold-search t))
- (goto-char (point-min))
- (while (re-search-forward regexp nil t)
- (if backup (re-search-backward "\\<" nil t))
- (if (and (or (char-equal (preceding-char) ?\^M)
- (char-equal (preceding-char) ?\n))
- (not (looking-at " \\|\^I")))
- ;; Diary entry that consists only of date.
- (backward-char 1)
- ;; Found a nonempty diary entry--make it visible and
- ;; add it to the list.
- (let ((entry-start (point))
- (date-start))
- (re-search-backward "\^M\\|\n\\|\\`")
- (setq date-start (point))
- (re-search-forward "\^M\\|\n" nil t 2)
- (while (looking-at " \\|\^I")
- (re-search-forward "\^M\\|\n" nil t))
- (backward-char 1)
- (subst-char-in-region date-start (point) ?\^M ?\n t)
- (add-to-diary-list
- gdate (buffer-substring entry-start (point)))))))
- (setq d (cdr d))))
- (setq gdate
- (calendar-gregorian-from-absolute
- (1+ (calendar-absolute-from-gregorian gdate)))))
- (set-buffer-modified-p diary-modified))
- (goto-char (point-min))))
-
-(defun mark-islamic-diary-entries ()
- "Mark days in the calendar window that have Islamic date diary entries.
-Each entry in diary-file (or included files) visible in the calendar window
-is marked. Islamic date entries are prefaced by a islamic-diary-entry-symbol
-\(normally an `I'). The same diary-date-forms govern the style of the Islamic
-calendar entries, except that the Islamic month names must be spelled in full.
-The Islamic months are numbered from 1 to 12 with Muharram being 1 and 12 being
-Dhu al-Hijjah. Islamic date diary entries that begin with a
-diary-nonmarking-symbol will not be marked in the calendar. This function is
-provided for use as part of the nongregorian-diary-marking-hook."
- (let ((d diary-date-forms))
- (while d
- (let*
- ((date-form (if (equal (car (car d)) 'backup)
- (cdr (car d))
- (car d)));; ignore 'backup directive
- (dayname (diary-name-pattern calendar-day-name-array))
- (monthname
- (concat
- (diary-name-pattern calendar-islamic-month-name-array t)
- "\\|\\*"))
- (month "[0-9]+\\|\\*")
- (day "[0-9]+\\|\\*")
- (year "[0-9]+\\|\\*")
- (l (length date-form))
- (d-name-pos (- l (length (memq 'dayname date-form))))
- (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos)))
- (m-name-pos (- l (length (memq 'monthname date-form))))
- (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos)))
- (d-pos (- l (length (memq 'day date-form))))
- (d-pos (if (/= l d-pos) (+ 2 d-pos)))
- (m-pos (- l (length (memq 'month date-form))))
- (m-pos (if (/= l m-pos) (+ 2 m-pos)))
- (y-pos (- l (length (memq 'year date-form))))
- (y-pos (if (/= l y-pos) (+ 2 y-pos)))
- (regexp
- (concat
- "\\(\\`\\|\^M\\|\n\\)"
- (regexp-quote islamic-diary-entry-symbol)
- "\\("
- (mapconcat 'eval date-form "\\)\\(")
- "\\)"))
- (case-fold-search t))
- (goto-char (point-min))
- (while (re-search-forward regexp nil t)
- (let* ((dd-name
- (if d-name-pos
- (buffer-substring
- (match-beginning d-name-pos)
- (match-end d-name-pos))))
- (mm-name
- (if m-name-pos
- (buffer-substring
- (match-beginning m-name-pos)
- (match-end m-name-pos))))
- (mm (string-to-int
- (if m-pos
- (buffer-substring
- (match-beginning m-pos)
- (match-end m-pos))
- "")))
- (dd (string-to-int
- (if d-pos
- (buffer-substring
- (match-beginning d-pos)
- (match-end d-pos))
- "")))
- (y-str (if y-pos
- (buffer-substring
- (match-beginning y-pos)
- (match-end y-pos))))
- (yy (if (not y-str)
- 0
- (if (and (= (length y-str) 2)
- abbreviated-calendar-year)
- (let* ((current-y
- (extract-calendar-year
- (calendar-islamic-from-absolute
- (calendar-absolute-from-gregorian
- (calendar-current-date)))))
- (y (+ (string-to-int y-str)
- (* 100 (/ current-y 100)))))
- (if (> (- y current-y) 50)
- (- y 100)
- (if (> (- current-y y) 50)
- (+ y 100)
- y)))
- (string-to-int y-str)))))
- (if dd-name
- (mark-calendar-days-named
- (cdr (assoc (capitalize (substring dd-name 0 3))
- (calendar-make-alist
- calendar-day-name-array
- 0
- '(lambda (x) (substring x 0 3))))))
- (if mm-name
- (if (string-equal mm-name "*")
- (setq mm 0)
- (setq mm
- (cdr (assoc
- (capitalize mm-name)
- (calendar-make-alist
- calendar-islamic-month-name-array))))))
- (mark-islamic-calendar-date-pattern mm dd yy)))))
- (setq d (cdr d)))))
-
-(defun mark-islamic-calendar-date-pattern (month day year)
- "Mark dates in calendar window that conform to Islamic date MONTH/DAY/YEAR.
-A value of 0 in any position is a wildcard."
- (save-excursion
- (set-buffer calendar-buffer)
- (if (and (/= 0 month) (/= 0 day))
- (if (/= 0 year)
- ;; Fully specified Islamic date.
- (let ((date (calendar-gregorian-from-absolute
- (calendar-absolute-from-islamic
- (list month day year)))))
- (if (calendar-date-is-visible-p date)
- (mark-visible-calendar-date date)))
- ;; Month and day in any year--this taken from the holiday stuff.
- (let* ((islamic-date (calendar-islamic-from-absolute
- (calendar-absolute-from-gregorian
- (list displayed-month 15 displayed-year))))
- (m (extract-calendar-month islamic-date))
- (y (extract-calendar-year islamic-date))
- (date))
- (if (< m 1)
- nil;; Islamic calendar doesn't apply.
- (increment-calendar-month m y (- 10 month))
- (if (> m 7);; Islamic date might be visible
- (let ((date (calendar-gregorian-from-absolute
- (calendar-absolute-from-islamic
- (list month day y)))))
- (if (calendar-date-is-visible-p date)
- (mark-visible-calendar-date date)))))))
- ;; Not one of the simple cases--check all visible dates for match.
- ;; Actually, the following code takes care of ALL of the cases, but
- ;; it's much too slow to be used for the simple (common) cases.
- (let ((m displayed-month)
- (y displayed-year)
- (first-date)
- (last-date))
- (increment-calendar-month m y -1)
- (setq first-date
- (calendar-absolute-from-gregorian
- (list m 1 y)))
- (increment-calendar-month m y 2)
- (setq last-date
- (calendar-absolute-from-gregorian
- (list m (calendar-last-day-of-month m y) y)))
- (calendar-for-loop date from first-date to last-date do
- (let* ((i-date (calendar-islamic-from-absolute date))
- (i-month (extract-calendar-month i-date))
- (i-day (extract-calendar-day i-date))
- (i-year (extract-calendar-year i-date)))
- (and (or (zerop month)
- (= month i-month))
- (or (zerop day)
- (= day i-day))
- (or (zerop year)
- (= year i-year))
- (mark-visible-calendar-date
- (calendar-gregorian-from-absolute date)))))))))
-
-(provide 'diary-lib)
-
-;;; diary-lib.el ends here
+++ /dev/null
-;;; ftp.el --- file input and output over Internet using FTP
-
-;; Copyright (C) 1987 Free Software Foundation, Inc.
-
-;; Author: Richard Mlynarik <mly@prep.ai.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 2, or (at your option)
-;; any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to
-;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;;; Code:
-
-;; 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)
-(defvar ftp-password-alist () "Security sucks")
-
-(defun read-ftp-user-password (host user new)
- (let (tem)
- (if (and (not new)
- (listp ftp-password-alist)
- (setq tem (cdr (assoc host ftp-password-alist)))
- (or (null user)
- (string= user (car tem))))
- tem
- (or user
- (progn
- (setq tem (or (and (listp ftp-password-alist)
- (car (cdr (assoc host ftp-password-alist))))
- (user-login-name)))
- (setq user (read-string (format
- "User-name for %s (default \"%s\"): "
- host tem)))
- (if (equal user "") (setq user tem))))
- (setq tem (cons user
- ;; If you want to use some non-echoing string-reader,
- ;; feel free to write it yourself. I don't care enough.
- (read-string (format "Password for %s@%s: " user host)
- (if (not (listp ftp-password-alist))
- ""
- (or (cdr (cdr (assoc host ftp-password-alist)))
- (let ((l ftp-password-alist))
- (catch 'foo
- (while l
- (if (string= (car (cdr (car l))) user)
- (throw 'foo (cdr (cdr (car l))))
- (setq l (cdr l))))
- nil))
- "")))))
- (message "")
- (if (and (listp ftp-password-alist)
- (not (string= (cdr tem) "")))
- (setq ftp-password-alist (cons (cons host tem)
- ftp-password-alist)))
- tem)))
-
-(defun ftp-read-file-name (prompt)
- (let ((s ""))
- (while (not (string-match "\\`[ \t]*\\([^ \t:]+\\)[ \t]*:\\(.+\\)\\'" s))
- (setq s (read-string prompt s)))
- (list (substring s (match-beginning 1) (match-end 1))
- (substring s (match-beginning 2) (match-end 2)))))
-
-
-;;;###autoload
-(defun ftp-find-file (host file &optional user password)
- "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)"
- (interactive
- (append (ftp-read-file-name "FTP get host:file: ")
- (list nil (not (null current-prefix-arg)))))
- (ftp-find-file-or-directory host file t user password))
-
-;;;###autoload
-(defun ftp-list-directory (host file &optional user password)
- "FTP to HOST to list DIRECTORY, 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)"
- (interactive
- (append (ftp-read-file-name "FTP get host:directory: ")
- (list nil (not (null current-prefix-arg)))))
- (ftp-find-file-or-directory host file nil user password))
-
-(defun ftp-find-file-or-directory (host file filep &optional user password)
- "FTP to HOST to get FILE. Third arg is t for file, nil for directory.
-Log in as USER with PASSWORD. If USER is nil or PASSWORD is nil or t,
-we prompt for the user name and password."
- (or (and user password (not (eq password t)))
- (progn (setq user (read-ftp-user-password host user (eq password t))
- password (cdr user)
- user (car user))))
- (let ((buffer (get-buffer-create (format "*ftp%s %s:%s*"
- (if filep "" "-directory")
- host file))))
- (set-buffer buffer)
- (let ((process nil)
- (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)))))
- (message "Opening %s %s:%s..." (if filep "file" "directory")
- host file)
- (if (ftp-command process
- (format "%s \"%s\" -\nquit\n" (if filep "get" "dir")
- file)
- "\\(150\\|125\\).*\n"
- "200.*\n")
- (progn (forward-line 1)
- (let ((buffer-read-only nil))
- (delete-region (point-min) (point)))
- (message "Retrieving %s:%s in background. Bye!" host file)
- (set-process-sentinel process
- 'ftp-asynchronous-input-sentinel)
- process)
- (switch-to-buffer buffer)
- (let ((buffer-read-only nil))
- (insert-before-markers "<<<Ftp lost>>>"))
- (delete-process process)
- (error "Ftp %s:%s lost" host file)))))
-
-\f
-;;;###autoload
-(defun ftp-write-file (host file &optional user password)
- "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)"
- (interactive
- (append (ftp-read-file-name "FTP write host:file: ")
- (list nil (not (null current-prefix-arg)))))
- (or (and user password (not (eq password t)))
- (progn (setq user (read-ftp-user-password host user (eq password t))
- password (cdr user)
- user (car user))))
- (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")
- (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\\|125\\).*\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))))))
-
-\f
-(defun ftp-setup-buffer (host file)
- (fundamental-mode)
- (and (get-buffer-process (current-buffer))
- (progn (discard-input)
- (if (y-or-n-p (format "Kill process \"%s\" in %s? "
- (process-name (get-buffer-process
- (current-buffer)))
- (buffer-name (current-buffer))))
- (while (get-buffer-process (current-buffer))
- (kill-process (get-buffer-process (current-buffer))))
- (error "Foo"))))
- ;(buffer-disable-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"))
-
-
-(defun ftp-login (process host user password)
- (message "FTP logging in as %s@%s..." user host)
- (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")
- t
- (switch-to-buffer (process-buffer process))
- (delete-process process)
- (if (listp ftp-password-alist)
- (setq ftp-password-alist (delq (assoc host ftp-password-alist)
- ftp-password-alist)))
- nil))
-
-(defun ftp-command (process command win ignore)
- (process-send-string process command)
- (let ((p 1))
- (while (numberp p)
- (cond ;((not (bolp)))
- ((looking-at "^[0-9]+-")
- (while (not (re-search-forward "^[0-9]+ " nil t))
- (save-excursion
- (accept-process-output process)))
- (beginning-of-line))
- ((looking-at win)
- (goto-char (point-max))
- (setq p t))
- ((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)
- ;; is really really disgusting.
- (setq p (point))
- (condition-case ()
- (accept-process-output process)
- (error nil))
- (goto-char p))
- (t
- (setq p nil))))
- p))
-
-
-(defun ftp-asynchronous-input-sentinel (process msg)
- (ftp-sentinel process msg t t))
-(defun ftp-synchronous-input-sentinel (process msg)
- (ftp-sentinel process msg nil t))
-(defun ftp-asynchronous-output-sentinel (process msg)
- (ftp-sentinel process msg t nil))
-(defun ftp-synchronous-output-sentinel (process msg)
- (ftp-sentinel process msg nil nil))
-
-(defun ftp-sentinel (process msg asynchronous input)
- (cond ((null (buffer-name (process-buffer process)))
- ;; deleted buffer
- (set-process-buffer process nil))
- ((and (eq (process-status process) 'exit)
- (= (process-exit-status process) 0))
- (save-excursion
- (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.*$")))
- (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)).
- (if (not input)
- (progn
- (condition-case ()
- (and (boundp 'ftp-temp-file-name)
- 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)"
- ftp-host ftp-file))))
- (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)
- )
- (progn (message "%s" msg)
- (sleep-for 2))))))
- ((memq (process-status process) '(exit signal))
- (save-excursion
- (set-buffer (process-buffer process))
- (setq msg (format "Ftp died (buffer %s): %s"
- (buffer-name (current-buffer))
- msg))
- (let ((buffer-read-only nil))
- (goto-char (point-max))
- (insert ?\n ?\n msg))
- (delete-process proc)
- (set-buffer (get-buffer-create "*ftp log*"))
- (let ((buffer-read-only nil))
- (goto-char (point-max))
- (insert msg))
- (if (waiting-for-user-input-p)
- (error "%s" msg))))))
-
-(defun ftp-setup-write-file-hooks ()
- (let ((hooks write-file-hooks))
- (make-local-variable 'write-file-hooks)
- (setq write-file-hooks (append write-file-hooks
- '(ftp-write-file-hook))))
- (make-local-variable 'revert-buffer-function)
- (setq revert-buffer-function 'ftp-revert-buffer)
- (setq default-directory "/tmp/")
- (setq buffer-file-name (concat default-directory
- (make-temp-name
- (buffer-name (current-buffer)))))
- (setq buffer-read-only nil))
-
-(defun ftp-write-file-hook ()
- (let ((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))
- t)
-
-(defun ftp-revert-buffer (&rest ignore)
- (let ((process (ftp-find-file ftp-host ftp-file)))
- (set-process-sentinel process 'ftp-synchronous-input-sentinel)
- (message "FTP reverting %s:%s" ftp-host ftp-file)
- (while (eq (process-status process) 'run)
- (condition-case ()
- (accept-process-output process)
- (error nil)))
- (and (eq (process-status process) 'exit)
- (= (process-exit-status process) 0)
- (set-buffer-modified-p nil))
- (message "Reverted")))
-
-;;; ftp.el ends here
+++ /dev/null
-;;; md5.el -- MD5 Message Digest Algorithm
-;;; Gareth Rees <gdr11@cl.cam.ac.uk>
-
-;; LCD Archive Entry:
-;; md5|Gareth Rees|gdr11@cl.cam.ac.uk|
-;; MD5 cryptographic message digest algorithm|
-;; 13-Nov-95|1.0|~/misc/md5.el.Z|
-
-;;; Details: ------------------------------------------------------------------
-
-;; This is a direct translation into Emacs LISP of the reference C
-;; implementation of the MD5 Message-Digest Algorithm written by RSA
-;; Data Security, Inc.
-;;
-;; The algorithm takes a message (that is, a string of bytes) and
-;; computes a 16-byte checksum or "digest" for the message. This digest
-;; is supposed to be cryptographically strong in the sense that if you
-;; are given a 16-byte digest D, then there is no easier way to
-;; construct a message whose digest is D than to exhaustively search the
-;; space of messages. However, the robustness of the algorithm has not
-;; been proven, and a similar algorithm (MD4) was shown to be unsound,
-;; so treat with caution!
-;;
-;; The C algorithm uses 32-bit integers; because GNU Emacs
-;; implementations provide 28-bit integers (with 24-bit integers on
-;; versions prior to 19.29), the code represents a 32-bit integer as the
-;; cons of two 16-bit integers. The most significant word is stored in
-;; the car and the least significant in the cdr. The algorithm requires
-;; at least 17 bits of integer representation in order to represent the
-;; carry from a 16-bit addition.
-
-;;; Usage: --------------------------------------------------------------------
-
-;; To compute the MD5 Message Digest for a message M (represented as a
-;; string or as a vector of bytes), call
-;;
-;; (md5-encode M)
-;;
-;; which returns the message digest as a vector of 16 bytes. If you
-;; need to supply the message in pieces M1, M2, ... Mn, then call
-;;
-;; (md5-init)
-;; (md5-update M1)
-;; (md5-update M2)
-;; ...
-;; (md5-update Mn)
-;; (md5-final)
-
-;;; Copyright and licence: ----------------------------------------------------
-
-;; Copyright (C) 1995 by Gareth Rees
-;; Derived from the RSA Data Security, Inc. MD5 Message-Digest Algorithm
-;;
-;; md5.el is free software; you can redistribute it and/or modify it
-;; under the terms of the GNU General Public License as published by the
-;; Free Software Foundation; either version 2, or (at your option) any
-;; later version.
-;;
-;; md5.el 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.
-;;
-;; The original copyright notice is given below, as required by the
-;; licence for the original code. This code is distributed under *both*
-;; RSA's original licence and the GNU General Public Licence. (There
-;; should be no problems, as the former is more liberal than the
-;; latter).
-
-;;; Original copyright notice: ------------------------------------------------
-
-;; Copyright (C) 1990, RSA Data Security, Inc. All rights reserved.
-;;
-;; License to copy and use this software is granted provided that it is
-;; identified as the "RSA Data Security, Inc. MD5 Message- Digest
-;; Algorithm" in all material mentioning or referencing this software or
-;; this function.
-;;
-;; License is also granted to make and use derivative works provided
-;; that such works are identified as "derived from the RSA Data
-;; Security, Inc. MD5 Message-Digest Algorithm" in all material
-;; mentioning or referencing the derived work.
-;;
-;; RSA Data Security, Inc. makes no representations concerning either
-;; the merchantability of this software or the suitability of this
-;; software for any particular purpose. It is provided "as is" without
-;; express or implied warranty of any kind.
-;;
-;; These notices must be retained in any copies of any part of this
-;; documentation and/or software.
-
-;;; Code: ---------------------------------------------------------------------
-
-(defvar md5-program "md5"
- "*Program that reads a message on its standard input and writes an
-MD5 digest on its output.")
-
-(defvar md5-maximum-internal-length 4096
- "*The maximum size of a piece of data that should use the MD5 routines
-written in lisp. If a message exceeds this, it will be run through an
-external filter for processing. Also see the `md5-program' variable.
-This variable has no effect if you call the md5-init|update|final
-functions - only used by the `md5' function's simpler interface.")
-
-(defvar md5-bits (make-vector 4 0)
- "Number of bits handled, modulo 2^64.
-Represented as four 16-bit numbers, least significant first.")
-(defvar md5-buffer (make-vector 4 '(0 . 0))
- "Scratch buffer (four 32-bit integers).")
-(defvar md5-input (make-vector 64 0)
- "Input buffer (64 bytes).")
-
-(defun md5-unhex (x)
- (if (> x ?9)
- (if (>= x ?a)
- (+ 10 (- x ?a))
- (+ 10 (- x ?A)))
- (- x ?0)))
-
-(defun md5-encode (message)
- "Encodes MESSAGE using the MD5 message digest algorithm.
-MESSAGE must be a string or an array of bytes.
-Returns a vector of 16 bytes containing the message digest."
- (if (<= (length message) md5-maximum-internal-length)
- (progn
- (md5-init)
- (md5-update message)
- (md5-final))
- (save-excursion
- (set-buffer (get-buffer-create " *md5-work*"))
- (erase-buffer)
- (insert message)
- (call-process-region (point-min) (point-max)
- (or shell-file-name "/bin/sh")
- t (current-buffer) nil
- "-c" md5-program)
- ;; MD5 digest is 32 chars long
- ;; mddriver adds a newline to make neaten output for tty
- ;; viewing, make sure we leave it behind.
- (let ((data (buffer-substring (point-min) (+ (point-min) 32)))
- (vec (make-vector 16 0))
- (ctr 0))
- (while (< ctr 16)
- (aset vec ctr (+ (* 16 (md5-unhex (aref data (* ctr 2))))
- (md5-unhex (aref data (1+ (* ctr 2))))))
- (setq ctr (1+ ctr)))))))
-
-(defsubst md5-add (x y)
- "Return 32-bit sum of 32-bit integers X and Y."
- (let ((m (+ (car x) (car y)))
- (l (+ (cdr x) (cdr y))))
- (cons (logand 65535 (+ m (lsh l -16))) (logand l 65535))))
-
-;; FF, GG, HH and II are basic MD5 functions, providing transformations
-;; for rounds 1, 2, 3 and 4 respectively. Each function follows this
-;; pattern of computation (where ROTATE(x,y) means rotate 32-bit value x
-;; by y bits to the left):
-;;
-;; FF(a,b,c,d,x,s,ac) = ROTATE(a + F(b,c,d) + x + ac,s) + b
-;;
-;; so we use the macro `md5-make-step' to construct each one. The
-;; helper functions F, G, H and I operate on 16-bit numbers; the full
-;; operation splits its inputs, operates on the halves separately and
-;; then puts the results together.
-
-(defsubst md5-F (x y z) (logior (logand x y) (logand (lognot x) z)))
-(defsubst md5-G (x y z) (logior (logand x z) (logand y (lognot z))))
-(defsubst md5-H (x y z) (logxor x y z))
-(defsubst md5-I (x y z) (logxor y (logior x (logand 65535 (lognot z)))))
-
-(defmacro md5-make-step (name func)
- (`
- (defun (, name) (a b c d x s ac)
- (let*
- ((m1 (+ (car a) ((, func) (car b) (car c) (car d)) (car x) (car ac)))
- (l1 (+ (cdr a) ((, func) (cdr b) (cdr c) (cdr d)) (cdr x) (cdr ac)))
- (m2 (logand 65535 (+ m1 (lsh l1 -16))))
- (l2 (logand 65535 l1))
- (m3 (logand 65535 (if (> s 15)
- (+ (lsh m2 (- s 32)) (lsh l2 (- s 16)))
- (+ (lsh m2 s) (lsh l2 (- s 16))))))
- (l3 (logand 65535 (if (> s 15)
- (+ (lsh l2 (- s 32)) (lsh m2 (- s 16)))
- (+ (lsh l2 s) (lsh m2 (- s 16)))))))
- (md5-add (cons m3 l3) b)))))
-
-(md5-make-step md5-FF md5-F)
-(md5-make-step md5-GG md5-G)
-(md5-make-step md5-HH md5-H)
-(md5-make-step md5-II md5-I)
-
-(defun md5-init ()
- "Initialise the state of the message-digest routines."
- (aset md5-bits 0 0)
- (aset md5-bits 1 0)
- (aset md5-bits 2 0)
- (aset md5-bits 3 0)
- (aset md5-buffer 0 '(26437 . 8961))
- (aset md5-buffer 1 '(61389 . 43913))
- (aset md5-buffer 2 '(39098 . 56574))
- (aset md5-buffer 3 '( 4146 . 21622)))
-
-(defun md5-update (string)
- "Update the current MD5 state with STRING (an array of bytes)."
- (let ((len (length string))
- (i 0)
- (j 0))
- (while (< i len)
- ;; Compute number of bytes modulo 64
- (setq j (% (/ (aref md5-bits 0) 8) 64))
-
- ;; Store this byte (truncating to 8 bits to be sure)
- (aset md5-input j (logand 255 (aref string i)))
-
- ;; Update number of bits by 8 (modulo 2^64)
- (let ((c 8) (k 0))
- (while (and (> c 0) (< k 4))
- (let ((b (aref md5-bits k)))
- (aset md5-bits k (logand 65535 (+ b c)))
- (setq c (if (> b (- 65535 c)) 1 0)
- k (1+ k)))))
-
- ;; Increment number of bytes processed
- (setq i (1+ i))
-
- ;; When 64 bytes accumulated, pack them into sixteen 32-bit
- ;; integers in the array `in' and then tranform them.
- (if (= j 63)
- (let ((in (make-vector 16 (cons 0 0)))
- (k 0)
- (kk 0))
- (while (< k 16)
- (aset in k (md5-pack md5-input kk))
- (setq k (+ k 1) kk (+ kk 4)))
- (md5-transform in))))))
-
-(defun md5-pack (array i)
- "Pack the four bytes at ARRAY reference I to I+3 into a 32-bit integer."
- (cons (+ (lsh (aref array (+ i 3)) 8) (aref array (+ i 2)))
- (+ (lsh (aref array (+ i 1)) 8) (aref array (+ i 0)))))
-
-(defun md5-byte (array n b)
- "Unpack byte B (0 to 3) from Nth member of ARRAY of 32-bit integers."
- (let ((e (aref array n)))
- (cond ((eq b 0) (logand 255 (cdr e)))
- ((eq b 1) (lsh (cdr e) -8))
- ((eq b 2) (logand 255 (car e)))
- ((eq b 3) (lsh (car e) -8)))))
-
-(defun md5-final ()
- (let ((in (make-vector 16 (cons 0 0)))
- (j 0)
- (digest (make-vector 16 0))
- (padding))
-
- ;; Save the number of bits in the message
- (aset in 14 (cons (aref md5-bits 1) (aref md5-bits 0)))
- (aset in 15 (cons (aref md5-bits 3) (aref md5-bits 2)))
-
- ;; Compute number of bytes modulo 64
- (setq j (% (/ (aref md5-bits 0) 8) 64))
-
- ;; Pad out computation to 56 bytes modulo 64
- (setq padding (make-vector (if (< j 56) (- 56 j) (- 120 j)) 0))
- (aset padding 0 128)
- (md5-update padding)
-
- ;; Append length in bits and transform
- (let ((k 0) (kk 0))
- (while (< k 14)
- (aset in k (md5-pack md5-input kk))
- (setq k (+ k 1) kk (+ kk 4))))
- (md5-transform in)
-
- ;; Store the results in the digest
- (let ((k 0) (kk 0))
- (while (< k 4)
- (aset digest (+ kk 0) (md5-byte md5-buffer k 0))
- (aset digest (+ kk 1) (md5-byte md5-buffer k 1))
- (aset digest (+ kk 2) (md5-byte md5-buffer k 2))
- (aset digest (+ kk 3) (md5-byte md5-buffer k 3))
- (setq k (+ k 1) kk (+ kk 4))))
-
- ;; Return digest
- digest))
-
-;; It says in the RSA source, "Note that if the Mysterious Constants are
-;; arranged backwards in little-endian order and decrypted with the DES
-;; they produce OCCULT MESSAGES!" Security through obscurity?
-
-(defun md5-transform (in)
- "Basic MD5 step. Transform md5-buffer based on array IN."
- (let ((a (aref md5-buffer 0))
- (b (aref md5-buffer 1))
- (c (aref md5-buffer 2))
- (d (aref md5-buffer 3)))
- (setq
- a (md5-FF a b c d (aref in 0) 7 '(55146 . 42104))
- d (md5-FF d a b c (aref in 1) 12 '(59591 . 46934))
- c (md5-FF c d a b (aref in 2) 17 '( 9248 . 28891))
- b (md5-FF b c d a (aref in 3) 22 '(49597 . 52974))
- a (md5-FF a b c d (aref in 4) 7 '(62844 . 4015))
- d (md5-FF d a b c (aref in 5) 12 '(18311 . 50730))
- c (md5-FF c d a b (aref in 6) 17 '(43056 . 17939))
- b (md5-FF b c d a (aref in 7) 22 '(64838 . 38145))
- a (md5-FF a b c d (aref in 8) 7 '(27008 . 39128))
- d (md5-FF d a b c (aref in 9) 12 '(35652 . 63407))
- c (md5-FF c d a b (aref in 10) 17 '(65535 . 23473))
- b (md5-FF b c d a (aref in 11) 22 '(35164 . 55230))
- a (md5-FF a b c d (aref in 12) 7 '(27536 . 4386))
- d (md5-FF d a b c (aref in 13) 12 '(64920 . 29075))
- c (md5-FF c d a b (aref in 14) 17 '(42617 . 17294))
- b (md5-FF b c d a (aref in 15) 22 '(18868 . 2081))
- a (md5-GG a b c d (aref in 1) 5 '(63006 . 9570))
- d (md5-GG d a b c (aref in 6) 9 '(49216 . 45888))
- c (md5-GG c d a b (aref in 11) 14 '( 9822 . 23121))
- b (md5-GG b c d a (aref in 0) 20 '(59830 . 51114))
- a (md5-GG a b c d (aref in 5) 5 '(54831 . 4189))
- d (md5-GG d a b c (aref in 10) 9 '( 580 . 5203))
- c (md5-GG c d a b (aref in 15) 14 '(55457 . 59009))
- b (md5-GG b c d a (aref in 4) 20 '(59347 . 64456))
- a (md5-GG a b c d (aref in 9) 5 '( 8673 . 52710))
- d (md5-GG d a b c (aref in 14) 9 '(49975 . 2006))
- c (md5-GG c d a b (aref in 3) 14 '(62677 . 3463))
- b (md5-GG b c d a (aref in 8) 20 '(17754 . 5357))
- a (md5-GG a b c d (aref in 13) 5 '(43491 . 59653))
- d (md5-GG d a b c (aref in 2) 9 '(64751 . 41976))
- c (md5-GG c d a b (aref in 7) 14 '(26479 . 729))
- b (md5-GG b c d a (aref in 12) 20 '(36138 . 19594))
- a (md5-HH a b c d (aref in 5) 4 '(65530 . 14658))
- d (md5-HH d a b c (aref in 8) 11 '(34673 . 63105))
- c (md5-HH c d a b (aref in 11) 16 '(28061 . 24866))
- b (md5-HH b c d a (aref in 14) 23 '(64997 . 14348))
- a (md5-HH a b c d (aref in 1) 4 '(42174 . 59972))
- d (md5-HH d a b c (aref in 4) 11 '(19422 . 53161))
- c (md5-HH c d a b (aref in 7) 16 '(63163 . 19296))
- b (md5-HH b c d a (aref in 10) 23 '(48831 . 48240))
- a (md5-HH a b c d (aref in 13) 4 '(10395 . 32454))
- d (md5-HH d a b c (aref in 0) 11 '(60065 . 10234))
- c (md5-HH c d a b (aref in 3) 16 '(54511 . 12421))
- b (md5-HH b c d a (aref in 6) 23 '( 1160 . 7429))
- a (md5-HH a b c d (aref in 9) 4 '(55764 . 53305))
- d (md5-HH d a b c (aref in 12) 11 '(59099 . 39397))
- c (md5-HH c d a b (aref in 15) 16 '( 8098 . 31992))
- b (md5-HH b c d a (aref in 2) 23 '(50348 . 22117))
- a (md5-II a b c d (aref in 0) 6 '(62505 . 8772))
- d (md5-II d a b c (aref in 7) 10 '(17194 . 65431))
- c (md5-II c d a b (aref in 14) 15 '(43924 . 9127))
- b (md5-II b c d a (aref in 5) 21 '(64659 . 41017))
- a (md5-II a b c d (aref in 12) 6 '(25947 . 22979))
- d (md5-II d a b c (aref in 3) 10 '(36620 . 52370))
- c (md5-II c d a b (aref in 10) 15 '(65519 . 62589))
- b (md5-II b c d a (aref in 1) 21 '(34180 . 24017))
- a (md5-II a b c d (aref in 8) 6 '(28584 . 32335))
- d (md5-II d a b c (aref in 15) 10 '(65068 . 59104))
- c (md5-II c d a b (aref in 6) 15 '(41729 . 17172))
- b (md5-II b c d a (aref in 13) 21 '(19976 . 4513))
- a (md5-II a b c d (aref in 4) 6 '(63315 . 32386))
- d (md5-II d a b c (aref in 11) 10 '(48442 . 62005))
- c (md5-II c d a b (aref in 2) 15 '(10967 . 53947))
- b (md5-II b c d a (aref in 9) 21 '(60294 . 54161)))
-
- (aset md5-buffer 0 (md5-add (aref md5-buffer 0) a))
- (aset md5-buffer 1 (md5-add (aref md5-buffer 1) b))
- (aset md5-buffer 2 (md5-add (aref md5-buffer 2) c))
- (aset md5-buffer 3 (md5-add (aref md5-buffer 3) d))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Here begins the merger with the XEmacs API and the md5.el from the URL
-;;; package. Courtesy wmperry@spry.com
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defun md5 (object &optional start end)
- "Return the MD5 (a secure message digest algorithm) of an object.
-OBJECT is either a string or a buffer.
-Optional arguments START and END denote buffer positions for computing the
-hash of a portion of OBJECT."
- (let ((buffer nil))
- (unwind-protect
- (save-excursion
- (setq buffer (generate-new-buffer " *md5-work*"))
- (set-buffer buffer)
- (cond
- ((bufferp object)
- (insert-buffer-substring object start end))
- ((stringp object)
- (insert (if (or start end)
- (substring object start end)
- object)))
- (t nil))
- (prog1
- (if (<= (point-max) md5-maximum-internal-length)
- (mapconcat
- (function (lambda (node) (format "%02x" node)))
- (md5-encode (buffer-string))
- "")
- (call-process-region (point-min) (point-max)
- (or shell-file-name "/bin/sh")
- t buffer nil
- "-c" md5-program)
- ;; MD5 digest is 32 chars long
- ;; mddriver adds a newline to make neaten output for tty
- ;; viewing, make sure we leave it behind.
- (buffer-substring (point-min) (+ (point-min) 32)))
- (kill-buffer buffer)))
- (and buffer (kill-buffer buffer) nil))))
-
-(provide 'md5)
-
-;;; md5.el ends here ----------------------------------------------------------
+++ /dev/null
-;;; nnheaderxm.el --- making Gnus backends work under XEmacs
-;; Copyright (C) 1996,97 Free Software Foundation, Inc.
-
-;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
-;; Keywords: news
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;;; Commentary:
-
-;;; Code:
-
-(eval-and-compile
- (autoload 'nnheader-insert-file-contents "nnheader"))
-
-(defun nnheader-xmas-run-at-time (time repeat function &rest args)
- (start-itimer
- "nnheader-run-at-time"
- `(lambda ()
- (,function ,@args))
- time repeat))
-
-(defun nnheader-xmas-cancel-timer (timer)
- (delete-itimer timer))
-
-(defun nnheader-xmas-cancel-function-timers (function)
- )
-
-(defun nnheader-xmas-find-file-noselect (filename &optional nowarn rawfile)
- "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
- (abbreviate-file-name
- (expand-file-name filename)))
- (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))
- (truename (abbreviate-file-name (file-truename filename)))
- (number (nthcdr 10 (file-attributes truename)))
- ;; Find any buffer for a file which has same truename.
- (other (and (not buf)
- (get-file-buffer filename)))
- error)
- ;; Let user know if there is a buffer with the same truename.
- (when other
- (or nowarn
- (string-equal filename (buffer-file-name other))
- (message "%s and %s are the same file"
- filename (buffer-file-name other)))
- ;; Optionally also find that buffer.
- (when (or (and (boundp 'find-file-existing-other-name)
- find-file-existing-other-name)
- find-file-visit-truename)
- (setq buf other)))
- (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 (string= (file-name-nondirectory filename)
- (buffer-name buf))
- (format
- (if (buffer-modified-p buf)
- "File %s changed on disk. Discard your edits? "
- "File %s changed on disk. Reread from disk? ")
- (file-name-nondirectory filename))
- (format
- (if (buffer-modified-p buf)
- "File %s changed on disk. Discard your edits in %s? "
- "File %s changed on disk. Reread from disk into %s? ")
- (file-name-nondirectory filename)
- (buffer-name buf))))
- (save-excursion
- (set-buffer buf)
- (revert-buffer t t)))))
- (save-excursion
-;;; The truename stuff makes this obsolete.
-;;; (let* ((link-name (car (file-attributes filename)))
-;;; (linked-buf (and (stringp link-name)
-;;; (get-file-buffer link-name))))
-;;; (if (bufferp linked-buf)
-;;; (message "Symbolic link to file in buffer %s"
-;;; (buffer-name linked-buf))))
- (setq buf (create-file-buffer filename))
- ;; (set-buffer-major-mode buf)
- (set-buffer buf)
- (erase-buffer)
- (if rawfile
- (condition-case ()
- (nnheader-insert-file-contents filename t)
- (file-error
- ;; Unconditionally set error
- (setq error t)))
- (condition-case ()
- (insert-file-contents filename t)
- (file-error
- ;; Run find-file-not-found-hooks until one returns non-nil.
- (or t ; (run-hook-with-args-until-success 'find-file-not-found-hooks)
- ;; If they fail too, set error.
- (setq error t)))))
- ;; Find the file's truename, and maybe use that as visited name.
- (setq buffer-file-truename truename)
- (setq buffer-file-number number)
- ;; On VMS, we may want to remember which directory in a search list
- ;; the file was found in.
- (and (eq system-type 'vax-vms)
- (let (logical)
- (when (string-match ":" (file-name-directory filename))
- (setq logical (substring (file-name-directory filename)
- 0 (match-beginning 0))))
- (not (member logical find-file-not-true-dirname-list)))
- (setq buffer-file-name buffer-file-truename))
- (when find-file-visit-truename
- (setq buffer-file-name
- (setq filename
- (expand-file-name buffer-file-truename))))
- ;; Set buffer's default directory to that of the file.
- (setq default-directory (file-name-directory filename))
- ;; Turn off backup files for certain file names. Since
- ;; this is a permanent local, the major mode won't eliminate it.
- (when (not (funcall backup-enable-predicate buffer-file-name))
- (make-local-variable 'backup-inhibited)
- (setq backup-inhibited t))
- (if rawfile
- nil
- (after-find-file error (not nowarn)))))
- buf)))
-
-(fset 'nnheader-run-at-time 'nnheader-xmas-run-at-time)
-(fset 'nnheader-cancel-timer 'nnheader-xmas-cancel-timer)
-(fset 'nnheader-cancel-function-timers 'nnheader-xmas-cancel-function-timers)
-(fset 'nnheader-find-file-noselect 'nnheader-xmas-find-file-noselect)
-
-(provide 'nnheaderxm)
-
-;;; nnheaderxm.el ends here.
+++ /dev/null
-;;; gnusmail.el --- mail reply commands for GNUS newsreader
-
-;; Copyright (C) 1990, 1993 Free Software Foundation, Inc.
-
-;; Author: Masanobu UMEDA <umerin@mse.kyutech.ac.jp>
-;; Keywords: news
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to
-;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;;; Commentary:
-
-;; 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.
-
-;;; Code:
-
-(require 'gnus)
-
-(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 Summary Mode
-
-(defun gnus-summary-reply (yank)
- "Reply mail to news author.
-If prefix argument YANK is non-nil, original article is yanked automatically.
-Customize the variable gnus-mail-reply-method to use another mailer."
- (interactive "P")
- ;; Bug fix by jbw@bigbird.bu.edu (Joe Wells)
- ;; Stripping headers should be specified with mail-yank-ignored-headers.
- (gnus-summary-select-article t t)
- (switch-to-buffer gnus-article-buffer)
- (widen)
- (delete-other-windows)
- (bury-buffer gnus-article-buffer)
- (funcall gnus-mail-reply-method yank))
-
-(defun gnus-summary-reply-with-original ()
- "Reply mail to news author with original article.
-Customize the variable gnus-mail-reply-method to use another mailer."
- (interactive)
- (gnus-summary-reply t))
-
-(defun gnus-summary-mail-forward ()
- "Forward the current message to another user.
-Customize the variable gnus-mail-forward-method to use another mailer."
- (interactive)
- (gnus-summary-select-article)
- (switch-to-buffer gnus-article-buffer)
- (widen)
- (delete-other-windows)
- (bury-buffer gnus-article-buffer)
- (funcall gnus-mail-forward-method))
-
-(defun gnus-summary-mail-other-window ()
- "Compose mail in other window.
-Customize the variable gnus-mail-other-window-method to use another mailer."
- (interactive)
- (gnus-summary-select-article)
- (switch-to-buffer gnus-article-buffer)
- (widen)
- (delete-other-windows)
- (bury-buffer gnus-article-buffer)
- (funcall gnus-mail-other-window-method))
-
-\f
-;;; 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
- (mail-yank-original nil)))
-
-(defun gnus-mail-forward-using-mail ()
- "Forward the current message to another user using mail."
- ;; This is almost a carbon copy of rmail-forward in rmail.el.
- (let ((forward-buffer (current-buffer))
- (subject
- (concat "[" gnus-newsgroup-name "] "
- ;;(mail-strip-quoted-names (gnus-fetch-field "From")) ": "
- (or (gnus-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))
- (insert "------- Start of forwarded message -------\n")
- (insert-buffer forward-buffer)
- (goto-char (point-max))
- (insert "------- End of forwarded message -------\n")
- ;; You have a chance to arrange the message.
- (run-hooks 'gnus-mail-forward-hook)
- ))))
-
-(defun gnus-mail-other-window-using-mail ()
- "Compose mail other window using mail."
- (news-mail-other-window)
- (gnus-overload-functions))
-
-\f
-;;; 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] yank 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 (or (gnus-fetch-field "subject")
- "(None)")))
- (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)
- )))
-
-;; gnus-mail-forward-using-mhe is contributed by Jun-ichiro Itoh
-;; <itojun@ingram.mt.cs.keio.ac.jp>
-
-(defun gnus-mail-forward-using-mhe ()
- "Forward the current message to another user using mh-e."
- ;; First of all, prepare mhe mail buffer.
- (let ((to (read-string "To: "))
- (cc (read-string "Cc: "))
- (buffer (current-buffer))
- subject)
- ;;(gnus-article-show-all-headers)
- (setq subject
- (concat "[" gnus-newsgroup-name "] "
- ;;(mail-strip-quoted-names (gnus-fetch-field "From")) ": "
- (or (gnus-fetch-field "subject") "")))
- (setq mh-show-buffer buffer)
- (mh-find-path)
- (mh-send to (or cc "") subject)
- (save-excursion
- (goto-char (point-max))
- (insert "\n------- Forwarded Message\n\n")
- (insert-buffer buffer)
- (goto-char (point-max))
- (insert "\n------- End of Forwarded Message\n")
- (setq mh-sent-from-folder buffer)
- (setq mh-sent-from-msg 1))))
-
-(defun gnus-mail-other-window-using-mhe ()
- "Compose mail other window using mh-e."
- (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)))
-
-(provide 'gnusmail)
-
-;;; gnusmail.el ends here
+++ /dev/null
-;;; gnusmisc.el --- miscellaneous commands for GNUS newsreader
-
-;; Copyright (C) 1989, 1990, 1993 Free Software Foundation, Inc.
-
-;; Author: Masanobu UMEDA <umerin@mse.kyutech.ac.jp>
-;; Keywords: news
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to
-;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;;; Code:
-
-(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)
-
-(autoload 'timezone-make-date-arpa-standard "timezone")
-
-(put 'gnus-browse-killed-mode 'mode-class 'special)
-
-\f
-;;;
-;;; GNUS Browse-Killed Mode
-;;;
-
-;; Some ideas are due to roland@wheaties.ai.mit.edu (Roland McGrath).
-;; I'd like to thank him very much.
-
-;; 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-list-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 it against the options line in 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-list-killed-groups ()
- "List the killed newsgroups.
-The keys y and C-y yank 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 (gnus-gethash group gnus-killed-hashtb)))
- (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))
-
-\f
-;;;
-;;; kill/yank newsgroup commands of GNUS Group Mode
-;;;
-
-(defun gnus-group-transpose-groups (arg)
- "Exchange current newsgroup and previous newsgroup.
-With argument ARG, takes previous newsgroup and moves it past ARG newsgroup."
- (interactive "p")
- ;; BUG: last newsgroup and the last but one cannot be transposed
- ;; since gnus-group-search-forward does not move forward beyond the
- ;; last. If we instead use forward-line, no problem, but I don't
- ;; want to use it for later extension.
- (while (> arg 0)
- (gnus-group-search-forward t t)
- (gnus-group-kill-group 1)
- (gnus-group-search-forward nil t)
- (gnus-group-yank-group)
- (gnus-group-search-forward nil t)
- (setq arg (1- arg))
- ))
-
-(defun gnus-group-kill-region (begin end)
- "Kill newsgroups in current region (excluding current point).
-The killed newsgroups can be yanked by using \\[gnus-group-yank-group]."
- (interactive "r")
- (let ((lines
- ;; Exclude a line where current point is on.
- (1-
- ;; Count lines.
- (save-excursion
- (count-lines
- (progn
- (goto-char begin)
- (beginning-of-line)
- (point))
- (progn
- (goto-char end)
- (end-of-line)
- (point)))))))
- (goto-char begin)
- (beginning-of-line) ;Important when LINES < 1
- (gnus-group-kill-group lines)))
-
-(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 containing 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"))
- ;; Huuum. It this right?
- ;;(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)
- ))
-
-\f
-;;; Rewrite Date: field in GMT to local
-
-(defun gnus-gmt-to-local ()
- "Rewrite Date: field described in GMT to local in current buffer.
-The variable gnus-local-timezone is used for local time zone.
-Intended to be used with gnus-article-prepare-hook."
- (save-excursion
- (save-restriction
- (widen)
- (goto-char (point-min))
- (narrow-to-region (point-min)
- (progn (search-forward "\n\n" nil 'move) (point)))
- (goto-char (point-min))
- (if (re-search-forward "^Date:[ \t]\\(.*\\)$" nil t)
- (let ((buffer-read-only nil)
- (date (buffer-substring (match-beginning 1) (match-end 1))))
- (delete-region (match-beginning 1) (match-end 1))
- (insert
- (timezone-make-date-arpa-standard date nil gnus-local-timezone))
- ))
- )))
-
-(provide 'gnusmisc)
-
-;;; gnusmisc.el ends here
+++ /dev/null
-;;; gnuspost.el --- post news commands for GNUS newsreader
-
-;; Copyright (C) 1989, 1990, 1993, 1994 Free Software Foundation, Inc.
-
-;; Author: Masanobu UMEDA <umerin@mse.kyutech.ac.jp>
-;; Keywords: news
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to
-;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;;; Code:
-
-(require 'gnus)
-
-(defvar gnus-organization-file "/usr/lib/news/organization"
- "*Local news organization file.")
-
-(defvar gnus-post-news-buffer "*post-news*")
-(defvar gnus-winconf-post-news nil)
-
-(autoload 'news-reply-mode "rnewspost")
-(autoload 'timezone-make-date-arpa-standard "timezone")
-
-;;; Post news commands of GNUS Group Mode and Summary Mode
-
-(defun gnus-group-post-news ()
- "Post an article."
- (interactive)
- ;; Save window configuration.
- (setq gnus-winconf-post-news (current-window-configuration))
- (unwind-protect
- (gnus-post-news)
- (or (and (eq (current-buffer) (get-buffer gnus-post-news-buffer))
- (not (zerop (buffer-size))))
- ;; Restore last window configuration.
- (set-window-configuration gnus-winconf-post-news)))
- ;; We don't want to return to Summary buffer nor Article buffer later.
- (if (get-buffer gnus-summary-buffer)
- (bury-buffer gnus-summary-buffer))
- (if (get-buffer gnus-article-buffer)
- (bury-buffer gnus-article-buffer)))
-
-(defun gnus-summary-post-news ()
- "Post an article."
- (interactive)
- (gnus-summary-select-article t nil)
- ;; Save window configuration.
- (setq gnus-winconf-post-news (current-window-configuration))
- (unwind-protect
- (progn
- (switch-to-buffer gnus-article-buffer)
- (widen)
- (delete-other-windows)
- (gnus-post-news))
- (or (and (eq (current-buffer) (get-buffer gnus-post-news-buffer))
- (not (zerop (buffer-size))))
- ;; Restore last window configuration.
- (set-window-configuration gnus-winconf-post-news)))
- ;; We don't want to return to Article buffer later.
- (bury-buffer gnus-article-buffer))
-
-(defun gnus-summary-followup (yank)
- "Post a reply article.
-If prefix argument YANK is non-nil, original article is yanked automatically."
- (interactive "P")
- (gnus-summary-select-article t nil)
- ;; Check Followup-To: poster.
- (set-buffer gnus-article-buffer)
- (if (and gnus-use-followup-to
- (string-equal "poster" (gnus-fetch-field "followup-to"))
- (or (not (eq gnus-use-followup-to t))
- (not (y-or-n-p "Do you want to ignore `Followup-To: poster'? "))))
- ;; Mail to the poster. GNUS is now RFC1036 compliant.
- (gnus-summary-reply yank)
- ;; Save window configuration.
- (setq gnus-winconf-post-news (current-window-configuration))
- (unwind-protect
- (progn
- (switch-to-buffer gnus-article-buffer)
- (widen)
- (delete-other-windows)
- (gnus-news-reply yank))
- (or (and (eq (current-buffer) (get-buffer gnus-post-news-buffer))
- (not (zerop (buffer-size))))
- ;; Restore last window configuration.
- (set-window-configuration gnus-winconf-post-news)))
- ;; We don't want to return to Article buffer later.
- (bury-buffer gnus-article-buffer)))
-
-(defun gnus-summary-followup-with-original ()
- "Post a reply article with original article."
- (interactive)
- (gnus-summary-followup t))
-
-(defun gnus-summary-cancel-article ()
- "Cancel an article you posted."
- (interactive)
- (gnus-summary-select-article t nil)
- (gnus-eval-in-buffer-window gnus-article-buffer
- (gnus-cancel-news)))
-
-\f
-;;; Post a News using NNTP
-
-;;;###autoload
-(defalias 'sendnews 'gnus-post-news)
-
-;;;###autoload
-(defalias 'postnews 'gnus-post-news)
-
-;;;###autoload
-(defun gnus-post-news ()
- "Begin editing a new USENET news article to be posted.
-Type \\[describe-mode] once editing the article to get a list of commands."
- (interactive)
- (if (or (not gnus-novice-user)
- (y-or-n-p "Are you sure you want to post to all of USENET? "))
- (let ((artbuf (current-buffer))
- (newsgroups ;Default newsgroup.
- (if (eq major-mode 'gnus-article-mode) gnus-newsgroup-name))
- (subject nil)
- ;; Get default distribution.
- (distribution (car gnus-local-distributions))
- (followup-to nil))
- ;; Connect to NNTP server if not connected yet, and get
- ;; several information.
- (if (not (gnus-server-opened))
- (progn
- (gnus-start-news-server t) ;Confirm server.
- (gnus-setup-news)))
- ;; Get current article information.
- (save-restriction
- (and (not (zerop (buffer-size)))
- ;;(equal major-mode 'news-mode)
- (equal major-mode 'gnus-article-mode)
- (progn
- ;;(news-show-all-headers)
- (gnus-article-show-all-headers)
- (narrow-to-region (point-min)
- (progn (goto-char (point-min))
- (search-forward "\n\n")
- (point)))))
- (setq news-reply-yank-from (mail-fetch-field "from"))
- (setq news-reply-yank-message-id (mail-fetch-field "message-id")))
- (pop-to-buffer gnus-post-news-buffer)
- (news-reply-mode)
- (gnus-overload-functions)
- (if (and (buffer-modified-p)
- (> (buffer-size) 0)
- (not (y-or-n-p "Unsent article being composed; erase it? ")))
- ;; Continue composition.
- ;; Make news-reply-yank-original work on the current article.
- (setq mail-reply-buffer artbuf)
- (erase-buffer)
- (if gnus-interactive-post
- ;; Newsgroups, subject and distribution are asked for.
- ;; Suggested by yuki@flab.fujitsu.junet.
- (progn
- ;; Subscribed newsgroup names are required for
- ;; completing read of newsgroup.
- (or gnus-newsrc-assoc
- (gnus-read-newsrc-file))
- ;; Which do you like? (UMERIN)
- ;; (setq newsgroups (read-string "Newsgroups: " "general"))
- (or newsgroups ;Use the default newsgroup.
- (let (group)
- (while (not
- (string=
- (setq group
- (completing-read "Newsgroup: "
- gnus-newsrc-assoc
- nil 'require-match))
- ""))
- (or followup-to (setq followup-to group))
- (if newsgroups
- (setq newsgroups (concat newsgroups "," group))
- (setq newsgroups group)))))
- (setq subject (read-string "Subject: "))
- ;; Choose a distribution from gnus-distribution-list.
- ;; completing-read should not be used with
- ;; 'require-match functionality in order to allow use
- ;; of unknow distribution.
- (gnus-read-distributions-file)
- (setq distribution
- (if (consp gnus-distribution-list)
- (completing-read "Distribution: "
- gnus-distribution-list
- nil nil ;Never 'require-match
- distribution ;Default distribution.
- )
- (read-string "Distribution: ")))
- ;; Empty string is okay.
- ;;(if (string-equal distribution "")
- ;; (setq distribution nil))
- ))
- (news-setup () subject () newsgroups artbuf)
- ;; Make sure the article is posted by GNUS.
- ;;(mail-position-on-field "Posting-Software")
- ;;(insert "GNUS: NNTP-based News Reader for GNU Emacs")
- ;; Insert Distribution: field.
- ;; Suggested by ichikawa@flab.fujitsu.junet.
- (mail-position-on-field "Distribution")
- (insert (or distribution ""))
- ;; Add Followup-To header
- (if followup-to
- (progn
- (mail-position-on-field "Followup-To")
- (insert followup-to)))
- ;; Handle author copy using FCC field.
- (if gnus-author-copy
- (progn
- (mail-position-on-field "FCC")
- (insert gnus-author-copy)))
- (if gnus-interactive-post
- ;; All fields are filled in.
- (goto-char (point-max))
- ;; Move point to Newsgroup: field.
- (goto-char (point-min))
- (end-of-line))
- ))
- (message "")))
-
-(defun gnus-news-reply (&optional yank)
- "Compose and post a reply (aka a followup) to the current article on USENET.
-While composing the followup, use \\[news-reply-yank-original] to yank the
-original message into it."
- (interactive)
- (if (or (not gnus-novice-user)
- (y-or-n-p "Are you sure you want to followup to all of USENET? "))
- (let (from cc subject date to followup-to newsgroups message-of
- references distribution message-id
- (artbuf (current-buffer)))
- (save-restriction
- (and (not (zerop (buffer-size)))
- ;;(equal major-mode 'news-mode)
- (equal major-mode 'gnus-article-mode)
- (progn
- ;; (news-show-all-headers)
- (gnus-article-show-all-headers)
- (narrow-to-region (point-min)
- (progn (goto-char (point-min))
- (search-forward "\n\n")
- (point)))))
- (setq from (mail-fetch-field "from"))
- ;; Get reply-to working corrrectly for gnus-auto-mail-to-author (jpm)
- (setq reply-to (mail-fetch-field "reply-to"))
- (setq news-reply-yank-from from)
- (setq subject (mail-fetch-field "subject"))
- (setq date (mail-fetch-field "date"))
- (setq followup-to (mail-fetch-field "followup-to"))
- ;; Ignore Followup-To: poster.
- (if (or (null gnus-use-followup-to) ;Ignore followup-to: field.
- (string-equal "" followup-to) ;Bogus header.
- (string-equal "poster" followup-to))
- (setq followup-to nil))
- (setq newsgroups (or followup-to (mail-fetch-field "newsgroups")))
- (setq references (mail-fetch-field "references"))
- (setq distribution (mail-fetch-field "distribution"))
- (setq message-id (mail-fetch-field "message-id"))
- (setq news-reply-yank-message-id message-id))
- (pop-to-buffer gnus-post-news-buffer)
- (news-reply-mode)
- (gnus-overload-functions)
- (if (and (buffer-modified-p)
- (> (buffer-size) 0)
- (not (y-or-n-p "Unsent article being composed; erase it? ")))
- ;; Continue composition.
- ;; Make news-reply-yank-original work on current article.
- (setq mail-reply-buffer artbuf)
- (erase-buffer)
- (and subject
- (setq subject
- (concat "Re: " (gnus-simplify-subject subject 're-only))))
- (and from
- (progn
- (let ((stop-pos
- (string-match " *at \\| *@ \\| *(\\| *<" from)))
- (setq message-of
- (concat
- (if stop-pos (substring from 0 stop-pos) from)
- "'s message of "
- date)))))
- (news-setup nil subject message-of newsgroups artbuf)
- (if followup-to
- (progn (news-reply-followup-to)
- (insert followup-to)))
- ;; Fold long references line to follow RFC1036.
- (mail-position-on-field "References")
- (let ((begin (point))
- (fill-column 79)
- (fill-prefix "\t"))
- (if references
- (insert references))
- (if (and references message-id)
- (insert " "))
- (if message-id
- (insert message-id))
- ;; The region must end with a newline to fill the region
- ;; without inserting extra newline.
- (fill-region-as-paragraph begin (1+ (point))))
- ;; Make sure the article is posted by GNUS.
- ;;(mail-position-on-field "Posting-Software")
- ;;(insert "GNUS: NNTP-based News Reader for GNU Emacs")
- ;; Distribution must be the same as original article.
- (mail-position-on-field "Distribution")
- (insert (or distribution ""))
- ;; Handle author copy using FCC field.
- (if gnus-author-copy
- (progn
- (mail-position-on-field "FCC")
- (insert gnus-author-copy)))
- ;; Insert To: FROM field, which is expected to mail the
- ;; message to the author of the article too. Use Reply-To
- ;; field like gnus-mail-reply-using-m* (jpm).
- (if (and gnus-auto-mail-to-author (or reply-to from))
- (progn
- (goto-char (point-min))
- (insert "To: " (or reply-to from) "\n")))
- (goto-char (point-max)))
- ;; Yank original article automatically.
- (if yank
- (let ((last (point)))
- ;;(goto-char (point-max))
- ;; Insert at current point.
- (news-reply-yank-original nil)
- (goto-char last)))
- )
- (message "")))
-
-(defun gnus-inews-news ()
- "Send a news message."
- (interactive)
- (let* ((case-fold-search nil)
- (server-running (gnus-server-opened)))
- (save-excursion
- ;; Connect to default NNTP server if necessary.
- ;; Suggested by yuki@flab.fujitsu.junet.
- (gnus-start-news-server) ;Use default server.
- ;; NNTP server must be opened before current buffer is modified.
- (widen)
- (goto-char (point-min))
- (run-hooks 'news-inews-hook)
- (save-restriction
- (narrow-to-region
- (point-min)
- (progn
- (goto-char (point-min))
- (search-forward (concat "\n" mail-header-separator "\n"))
- (point)))
-
- ;; Correct newsgroups field: change sequence of spaces to comma and
- ;; eliminate spaces around commas. Eliminate imbedded line breaks.
- (goto-char (point-min))
- (if (search-forward-regexp "^Newsgroups: +" nil t)
- (save-restriction
- (narrow-to-region
- (point)
- (if (re-search-forward "^[^ \t]" nil 'end)
- (match-beginning 0)
- (point-max)))
- (goto-char (point-min))
- (replace-regexp "\n[ \t]+" " ") ;No line breaks (too confusing)
- (goto-char (point-min))
- (replace-regexp "[ \t\n]*,[ \t\n]*\\|[ \t]+" ",")
- ))
-
- ;; Mail the message too if To: or Cc: exists.
- (if (or (mail-fetch-field "to" nil t)
- (mail-fetch-field "cc" nil t))
- (if gnus-mail-send-method
- (progn
- (message "Sending via mail...")
- (widen)
- (funcall gnus-mail-send-method)
- (message "Sending via mail... done"))
- (ding)
- (message "No mailer defined. To: and/or Cc: fields ignored.")
- (sit-for 1))))
-
- ;; Send to NNTP server.
- (message "Posting to USENET...")
- (if (gnus-inews-article)
- (message "Posting to USENET... done")
- ;; We cannot signal an error.
- (ding) (message "Article rejected: %s" (gnus-status-message)))
- (set-buffer-modified-p nil))
- ;; If NNTP server is opened by gnus-inews-news, close it by myself.
- (or server-running
- (gnus-close-server))
- (and (fboundp 'bury-buffer) (bury-buffer))
- ;; Restore last window configuration.
- (and gnus-winconf-post-news
- (set-window-configuration gnus-winconf-post-news))
- (setq gnus-winconf-post-news nil)
- ))
-
-(defun gnus-cancel-news ()
- "Cancel an article you posted."
- (interactive)
- (if (yes-or-no-p "Do you really want to cancel this article? ")
- (let ((from nil)
- (newsgroups nil)
- (message-id nil)
- (distribution nil))
- (save-excursion
- ;; Get header info. from original article.
- (save-restriction
- (gnus-article-show-all-headers)
- (goto-char (point-min))
- (search-forward "\n\n" nil 'move)
- (narrow-to-region (point-min) (point))
- (setq from (mail-fetch-field "from"))
- (setq newsgroups (mail-fetch-field "newsgroups"))
- (setq message-id (mail-fetch-field "message-id"))
- (setq distribution (mail-fetch-field "distribution")))
- ;; Verify if the article is absolutely user's by comparing
- ;; user id with value of its From: field.
- (if (not
- (string-equal
- (downcase (mail-strip-quoted-names from))
- (downcase (mail-strip-quoted-names (gnus-inews-user-name)))))
- (progn
- (ding) (message "This article is not yours."))
- ;; Make control article.
- (set-buffer (get-buffer-create " *GNUS-canceling*"))
- (buffer-disable-undo (current-buffer))
- (erase-buffer)
- (insert "Newsgroups: " newsgroups "\n"
- "Subject: cancel " message-id "\n"
- "Control: cancel " message-id "\n"
- ;; We should not use the first value of
- ;; `gnus-distribution-list' as default value,
- ;; because distribution must be as same as original
- ;; article.
- "Distribution: " (or distribution "") "\n"
- mail-header-separator "\n"
- )
- ;; Send the control article to NNTP server.
- (message "Canceling your article...")
- (if (gnus-inews-article)
- (message "Canceling your article... done")
- (ding) (message "Failed to cancel your article"))
- ;; Kill the article buffer.
- (kill-buffer (current-buffer))
- )))
- ))
-
-\f
-;;; Lowlevel inews interface
-
-(defun gnus-inews-article ()
- "Post an article in current buffer using NNTP protocol."
- (let ((artbuf (current-buffer))
- (tmpbuf (get-buffer-create " *GNUS-posting*")))
- (save-excursion
- (set-buffer tmpbuf)
- (buffer-disable-undo (current-buffer))
- (erase-buffer)
- (insert-buffer-substring artbuf)
- ;; Remove the header separator.
- (goto-char (point-min))
- (search-forward (concat "\n" mail-header-separator "\n"))
- (replace-match "\n\n")
- (goto-char (point-max))
- ;; require a newline at the end for inews to append .signature to
- (or (= (preceding-char) ?\n)
- (insert ?\n))
- ;; This hook may insert a signature.
- (run-hooks 'gnus-prepare-article-hook)
- ;; Prepare article headers. All message body such as signature
- ;; must be inserted before Lines: field is prepared.
- (save-restriction
- (goto-char (point-min))
- (search-forward "\n\n")
- (narrow-to-region (point-min) (point))
- (gnus-inews-insert-headers))
- ;; Run final inews hooks. This hook may do FCC.
- ;; The article must be saved before being posted because
- ;; `gnus-request-post' modifies the buffer.
- (run-hooks 'gnus-inews-article-hook)
- ;; Post an article to NNTP server.
- ;; Return NIL if post failed.
- (prog1
- (gnus-request-post)
- (kill-buffer (current-buffer)))
- )))
-
-(defun gnus-inews-insert-headers ()
- "Prepare article headers.
-Fields already prepared in the buffer are not modified.
-Fields in gnus-required-headers will be generated."
- (save-excursion
- (let ((date (gnus-inews-date))
- (message-id (gnus-inews-message-id))
- (organization (gnus-inews-organization)))
- (goto-char (point-min))
- (or (mail-fetch-field "path")
- (and (memq 'Path gnus-required-headers)
- (insert "Path: " (gnus-inews-path) "\n")))
- (or (mail-fetch-field "from")
- (and (memq 'From gnus-required-headers)
- (insert "From: " (gnus-inews-user-name) "\n")))
- ;; If there is no subject, make Subject: field.
- (or (mail-fetch-field "subject")
- (and (memq 'Subject gnus-required-headers)
- (insert "Subject: \n")))
- ;; If there is no newsgroups, make Newsgroups: field.
- (or (mail-fetch-field "newsgroups")
- (and (memq 'Newsgroups gnus-required-headers)
- (insert "Newsgroups: \n")))
- (or (mail-fetch-field "message-id")
- (and message-id
- (memq 'Message-ID gnus-required-headers)
- (insert "Message-ID: " message-id "\n")))
- (or (mail-fetch-field "date")
- (and date
- (memq 'Date gnus-required-headers)
- (insert "Date: " date "\n")))
- ;; Optional fields in RFC977 and RFC1036
- (or (mail-fetch-field "organization")
- (and organization
- (memq 'Organization gnus-required-headers)
- (let ((begin (point))
- (fill-column 79)
- (fill-prefix "\t"))
- (insert "Organization: " organization "\n")
- (fill-region-as-paragraph begin (point)))))
- (or (mail-fetch-field "distribution")
- (and (memq 'Distribution gnus-required-headers)
- (insert "Distribution: \n")))
- (or (mail-fetch-field "lines")
- (and (memq 'Lines gnus-required-headers)
- (insert "Lines: " (gnus-inews-lines) "\n")))
- )))
-
-\f
-;; Utility functions.
-
-(defun gnus-inews-insert-signature ()
- "Insert signature file in current article buffer.
-If there is a file named .signature-DISTRIBUTION, it is used instead
-of usual .signature when the distribution of the article is
-DISTRIBUTION. Set the variable to nil to prevent appending the
-signature file automatically.
-Signature file is specified by the variable gnus-signature-file."
- (save-excursion
- (save-restriction
- ;; Change signature file by distribution.
- ;; Suggested by hyoko@flab.fujitsu.co.jp.
- (let ((signature
- (if gnus-signature-file
- (expand-file-name gnus-signature-file nil)))
- (distribution nil))
- (goto-char (point-min))
- (search-forward "\n\n")
- (narrow-to-region (point-min) (point))
- (setq distribution (mail-fetch-field "distribution"))
- (widen)
- (if signature
- (progn
- (if (file-exists-p (concat signature "-" distribution))
- (setq signature (concat signature "-" distribution)))
- ;; Insert signature.
- (if (file-exists-p signature)
- (progn
- (goto-char (point-max))
- (insert "-- \n")
- (insert-file-contents signature)))
- ))))))
-
-(defun gnus-inews-do-fcc ()
- "Process FCC: fields in current article buffer.
-Unless the first character of the field is `|', the article is saved
-to the specified file using the function specified by the variable
-gnus-author-copy-saver. The default function rmail-output saves in
-Unix mailbox format.
-If the first character is `|', the contents of the article is send to
-a program specified by the rest of the value."
- (let ((fcc-list nil)
- (fcc-file nil)
- (case-fold-search t)) ;Should ignore case.
- (save-excursion
- (save-restriction
- (goto-char (point-min))
- (search-forward "\n\n")
- (narrow-to-region (point-min) (point))
- (goto-char (point-min))
- (while (re-search-forward "^FCC:[ \t]*" nil 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))))
- ;; Process FCC operations.
- (widen)
- (while fcc-list
- (setq fcc-file (car fcc-list))
- (setq fcc-list (cdr fcc-list))
- (cond ((string-match "^[ \t]*|[ \t]*\\(.*\\)[ \t]*$" fcc-file)
- (let ((program (substring fcc-file
- (match-beginning 1) (match-end 1))))
- ;; Suggested by yuki@flab.fujitsu.junet.
- ;; Send article to named program.
- (call-process-region (point-min) (point-max) shell-file-name
- nil nil nil "-c" program)
- ))
- (t
- ;; Suggested by hyoko@flab.fujitsu.junet.
- ;; Save article in Unix mail format by default.
- (if (and gnus-author-copy-saver
- (not (eq gnus-author-copy-saver 'rmail-output)))
- (funcall gnus-author-copy-saver fcc-file)
- (if (and (file-readable-p fcc-file)
- (mail-file-babyl-p fcc-file))
- (gnus-output-to-rmail fcc-file)
- (rmail-output fcc-file 1 t t)))
- ))
- )
- ))
- ))
-
-(defun gnus-inews-path ()
- "Return uucp path."
- (let ((login-name (gnus-inews-login-name)))
- (cond ((null gnus-use-generic-path)
- (concat gnus-nntp-server "!" login-name))
- ((stringp gnus-use-generic-path)
- ;; Support GENERICPATH. Suggested by vixie@decwrl.dec.com.
- (concat gnus-use-generic-path "!" login-name))
- (t login-name))
- ))
-
-(defun gnus-inews-user-name ()
- "Return user's network address as `NAME@DOMAIN (FULLNAME)'."
- (let ((full-name (gnus-inews-full-name)))
- (concat (if (or gnus-user-login-name gnus-use-generic-from
- gnus-local-domain (getenv "DOMAINNAME"))
- (concat (gnus-inews-login-name) "@"
- (gnus-inews-domain-name gnus-use-generic-from))
- user-mail-address)
- ;; User's full name.
- (cond ((string-equal full-name "") "")
- ((string-equal full-name "&") ;Unix hack.
- (concat " (" login-name ")"))
- (t
- (concat " (" full-name ")")))
- )))
-
-(defun gnus-inews-login-name ()
- "Return user login name.
-Got from the variable `gnus-user-login-name' and the function
-`user-login-name'."
- (or gnus-user-login-name (user-login-name)))
-
-(defun gnus-inews-full-name ()
- "Return user full name.
-Got from the variable `gnus-user-full-name', the environment variable
-NAME, and the function `user-full-name'."
- (or gnus-user-full-name
- (getenv "NAME") (user-full-name)))
-
-(defun gnus-inews-domain-name (&optional genericfrom)
- "Return user's domain name.
-If optional argument GENERICFROM is a string, use it as the domain
-name; if it is non-nil, strip of local host name from the domain name.
-If the function `system-name' returns full internet name and the
-domain is undefined, the domain name is got from it."
- (and (null gnus-local-domain)
- (boundp 'gnus-your-domain)
- (setq gnus-local-domain gnus-your-domain))
- (if (or genericfrom gnus-local-domain (getenv "DOMAINNAME"))
- (let ((domain (or (if (stringp genericfrom) genericfrom)
- (getenv "DOMAINNAME")
- gnus-local-domain
- ;; Function `system-name' may return full internet name.
- ;; Suggested by Mike DeCorte <mrd@sun.soe.clarkson.edu>.
- (if (string-match "\\." (system-name))
- (substring (system-name) (match-end 0)))
- (read-string "Domain name (no host): ")))
- (host (or (if (string-match "\\." (system-name))
- (substring (system-name) 0 (match-beginning 0)))
- (system-name))))
- (if (string-equal "." (substring domain 0 1))
- (setq domain (substring domain 1)))
- ;; Support GENERICFROM as same as standard Bnews system.
- ;; Suggested by ohm@kaba.junet and vixie@decwrl.dec.com.
- (cond ((null genericfrom)
- (concat host "." domain))
- ;;((stringp genericfrom) genericfrom)
- (t domain)))
- (substring user-mail-address (1+ (string-match "@" user-mail-address)))))
-
-(defun gnus-inews-message-id ()
- "Generate unique Message-ID for user."
- ;; Message-ID should not contain a slash and should be terminated by
- ;; a number. I don't know the reason why it is so.
- (concat "<" (gnus-inews-unique-id) "@" (gnus-inews-domain-name) ">"))
-
-(defun gnus-inews-unique-id ()
- "Generate unique ID from user name and current time."
- (let ((date (current-time-string))
- (name (gnus-inews-login-name)))
- (if (string-match "^[^ ]+ \\([^ ]+\\)[ ]+\\([0-9]+\\) \\([0-9]+\\):\\([0-9]+\\):\\([0-9]+\\) [0-9][0-9]\\([0-9][0-9]\\)"
- date)
- (concat (upcase name) "."
- (substring date (match-beginning 6) (match-end 6)) ;Year
- (substring date (match-beginning 1) (match-end 1)) ;Month
- (substring date (match-beginning 2) (match-end 2)) ;Day
- (substring date (match-beginning 3) (match-end 3)) ;Hour
- (substring date (match-beginning 4) (match-end 4)) ;Minute
- (substring date (match-beginning 5) (match-end 5)) ;Second
- )
- (error "Cannot understand current-time-string: %s." date))
- ))
-
-(defun gnus-current-time-zone (time)
- "The local time zone in effect at TIME, or nil if not known."
- (let ((z (and (fboundp 'current-time-zone) (current-time-zone time))))
- (if (and z (car z)) z gnus-local-timezone)))
-
-(defun gnus-inews-date ()
- "Date string of today.
-If `current-time-zone' works, or if `gnus-local-timezone' is set correctly,
-this yields a date that conforms to RFC 822. Otherwise a buggy date will
-be generated; this might work with some older news servers."
- (let* ((now (and (fboundp 'current-time) (current-time)))
- (zone (gnus-current-time-zone now)))
- (if zone
- (gnus-inews-valid-date now zone)
- ;; No timezone info.
- (gnus-inews-buggy-date now))))
-
-(defun gnus-inews-valid-date (&optional time zone)
- "A date string that represents TIME and conforms to the Usenet standard.
-TIME is optional and defaults to the current time.
-Some older versions of Emacs always act as if TIME is nil.
-The optional argument ZONE specifies the local time zone (default GMT)."
- (timezone-make-date-arpa-standard
- (if (fboundp 'current-time)
- (current-time-string time)
- (current-time-string))
- zone "GMT"))
-
-(defun gnus-inews-buggy-date (&optional time)
- "A buggy date string that represents TIME.
-TIME is optional and defaults to the current time.
-Some older versions of Emacs always act as if TIME is nil."
- (let ((date (if (fboundp 'current-time)
- (current-time-string time)
- (current-time-string))))
- (if (string-match "^[^ ]+ \\([^ ]+\\)[ ]+\\([0-9]+\\) \\([0-9:]+\\) [0-9][0-9]\\([0-9][0-9]\\)"
- date)
- (concat (substring date (match-beginning 2) (match-end 2)) ;Day
- " "
- (substring date (match-beginning 1) (match-end 1)) ;Month
- " "
- (substring date (match-beginning 4) (match-end 4)) ;Year
- " "
- (substring date (match-beginning 3) (match-end 3))) ;Time
- (error "Cannot understand current-time-string: %s." date))
- ))
-
-(defun gnus-inews-organization ()
- "Return user's organization.
-The ORGANIZATION environment variable is used if defined.
-If not, the variable gnus-local-organization is used instead.
-If the value begins with a slash, it is taken as the name of a file
-containing the organization."
- ;; The organization must be got in this order since the ORGANIZATION
- ;; environment variable is intended for user specific while
- ;; gnus-local-organization is for machine or organization specific.
-
- ;; Note: compatibility hack. This will be removed in the next version.
- (and (null gnus-local-organization)
- (boundp 'gnus-your-organization)
- (setq gnus-local-organization gnus-your-organization))
- ;; End of compatibility hack.
- (let* ((private-file (expand-file-name "~/.organization" nil))
- (organization (or (getenv "ORGANIZATION")
- gnus-local-organization
- private-file)))
- (and (stringp organization)
- (> (length organization) 0)
- (string-equal (substring organization 0 1) "/")
- ;; Get it from the user and system file.
- ;; Suggested by roland@wheaties.ai.mit.edu (Roland McGrath).
- (let ((dist (mail-fetch-field "distribution")))
- (setq organization
- (cond ((file-exists-p (concat organization "-" dist))
- (concat organization "-" dist))
- ((file-exists-p organization) organization)
- ((file-exists-p gnus-organization-file)
- gnus-organization-file)
- (t organization)))
- ))
- (cond ((not (stringp organization)) nil)
- ((and (string-equal (substring organization 0 1) "/")
- (file-exists-p organization))
- ;; If the first character is `/', assume it is the name of
- ;; a file containing the organization.
- (save-excursion
- (let ((tmpbuf (get-buffer-create " *GNUS organization*")))
- (set-buffer tmpbuf)
- (erase-buffer)
- (insert-file-contents organization)
- (prog1 (buffer-string)
- (kill-buffer tmpbuf))
- )))
- ((string-equal organization private-file) nil) ;No such file
- (t organization))
- ))
-
-(defun gnus-inews-lines ()
- "Count the number of lines and return numeric string."
- (save-excursion
- (save-restriction
- (widen)
- (goto-char (point-min))
- (search-forward "\n\n" nil 'move)
- (int-to-string (count-lines (point) (point-max))))))
-
-(provide 'gnuspost)
-
-;;; gnuspost.el ends here
+++ /dev/null
-;;; gosmacs.el --- rebindings to imitate Gosmacs.
-
-;; Copyright (C) 1986 Free Software Foundation, Inc.
-
-;; Maintainer: FSF
-;; Keywords: emulations
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to
-;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;;; Commentary:
-
-;; Make GNU Emacs look like Gosling Emacs. `M-x set-gosmacs-bindings'
-;; does this change; `M-x set-gnu-bindings' undoes it.
-
-;;; Code:
-
-(require 'mlsupport)
-
-(defvar non-gosmacs-binding-alist nil)
-
-;;;###autoload
-(defun set-gosmacs-bindings ()
- "Rebind some keys globally to make GNU Emacs resemble Gosling Emacs.
-Use \\[set-gnu-bindings] to restore previous global bindings."
- (interactive)
- (setq non-gosmacs-binding-alist
- (rebind-and-record
- '(("\C-x\C-e" compile)
- ("\C-x\C-f" save-buffers-kill-emacs)
- ("\C-x\C-i" insert-file)
- ("\C-x\C-m" save-some-buffers)
- ("\C-x\C-n" next-error)
- ("\C-x\C-o" switch-to-buffer)
- ("\C-x\C-r" insert-file)
- ("\C-x\C-u" undo)
- ("\C-x\C-v" find-file-other-window)
- ("\C-x\C-z" shrink-window)
- ("\C-x!" shell-command)
- ("\C-xd" delete-window)
- ("\C-xn" gosmacs-next-window)
- ("\C-xp" gosmacs-previous-window)
- ("\C-xz" enlarge-window)
- ("\C-z" scroll-one-line-up)
- ("\e\C-c" save-buffers-kill-emacs)
- ("\e!" line-to-top-of-window)
- ("\e(" backward-paragraph)
- ("\e)" forward-paragraph)
- ("\e?" apropos)
- ("\eh" delete-previous-word)
- ("\ej" indent-sexp)
- ("\eq" query-replace)
- ("\er" replace-string)
- ("\ez" scroll-one-line-down)
- ("\C-_" suspend-emacs)))))
-
-(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
-but each with the old definition that was replaced,"
- (let (old)
- (while bindings
- (let* ((this (car bindings))
- (key (car this))
- (newdef (nth 1 this)))
- (setq old (cons (list key (lookup-key global-map key)) old))
- (global-set-key key newdef))
- (setq bindings (cdr bindings)))
- (nreverse old)))
-
-(defun set-gnu-bindings ()
- "Restore the global bindings that were changed by \\[set-gosmacs-bindings]."
- (interactive)
- (rebind-and-record non-gosmacs-binding-alist))
-
-(defun gosmacs-previous-window ()
- "Select the window above or to the left of the window now selected.
-From the window at the upper left corner, select the one at the lower right."
- (interactive)
- (select-window (previous-window)))
-
-(defun gosmacs-next-window ()
- "Select the window below or to the right of the window now selected.
-From the window at the lower right corner, select the one at the upper left."
- (interactive)
- (select-window (next-window)))
-
-(defun scroll-one-line-up (&optional arg)
- "Scroll the selected window up (forward in the text) one line (or N lines)."
- (interactive "p")
- (scroll-up (or arg 1)))
-
-(defun scroll-one-line-down (&optional arg)
- "Scroll the selected window down (backward in the text) one line (or N)."
- (interactive "p")
- (scroll-down (or arg 1)))
-
-(defun line-to-top-of-window ()
- "Scroll the selected window up so that the current line is at the top."
- (interactive)
- (recenter 0))
-
-;;; gosmacs.el ends here
+++ /dev/null
-;;; grow-vers.el --- increment Emacs version number
-
-;; Copyright (C) 1985 Free Software Foundation, Inc.
-
-;; Maintainer: FSF
-;; Keywords: internal
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to
-;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;;; Commentary:
-
-;; Load this file to add a new level (starting at zero)
-;; to the Emacs version number recorded in version.el.
-
-;;; Code:
-
-(insert-file-contents "lisp/version.el")
-
-(re-search-forward "emacs-version \"[0-9.]*")
-(insert ".0")
-
-;; Delete the share-link with the current version
-;; so that we do not alter the current version.
-(delete-file "lisp/version.el")
-(write-region (point-min) (point-max) "lisp/version.el" nil 'nomsg)
-
-;;; grow-vers.el ends here
+++ /dev/null
-;;; inc-vers.el --- load this to increment the recorded Emacs version number.
-
-;; Copyright (C) 1985, 1986 Free Software Foundation, Inc.
-
-;; Maintainer: FSF
-;; Keywords: internal
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to
-;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;;; Code:
-
-(insert-file-contents "../lisp/version.el")
-
-(re-search-forward "emacs-version \"[^\"]*[0-9]+\"")
-(forward-char -1)
-(save-excursion
- (save-restriction
- (narrow-to-region (point)
- (progn (skip-chars-backward "0-9") (point)))
- (goto-char (point-min))
- (let ((version (read (current-buffer))))
- (delete-region (point-min) (point-max))
- (prin1 (1+ version) (current-buffer)))))
-(skip-chars-backward "^\"")
-(message "New Emacs version will be %s"
- (buffer-substring (point)
- (progn (skip-chars-forward "^\"") (point))))
-
-
-(if (and (file-accessible-directory-p "../lisp/")
- (null (file-writable-p "../lisp/version.el")))
- (delete-file "../lisp/version.el"))
-(if (eq system-type 'ms-dos) (setq buffer-file-type t))
-(write-region (point-min) (point-max) "../lisp/version.el" nil 'nomsg)
-(erase-buffer)
-(set-buffer-modified-p nil)
-
-(kill-emacs)
-
-;;; inc-vers.el ends here
+++ /dev/null
-;;; isearch.el --- incremental search commands
-
-;; Copyright (C) 1985, 1986 Free Software Foundation, Inc.
-
-;; Maintainer: FSF
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to
-;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;;; Code:
-
-(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 ?\C-m "\
-*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-ring-advance-char ?\M-n "\
-*Character to pull next (more recent) search string from the ring of same.")
-(defconst search-ring-retreat-char ?\M-p "\
-*Character to pull previous (older) search string from the ring of same.")
-
-(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.")
-
-(defconst search-upper-case t
- "*Non-nil means an upper-case letter as search input means case-sensitive.
-Any upper-case letter given explicitly as input to the incremental search
-has the effect of turning off `case-fold-search' for the rest of this search.
-Deleting the letter from the search string cancels the effect.")
-
-(fset 'search-forward-regexp 're-search-forward)
-(fset 'search-backward-regexp 're-search-backward)
-
-(defvar search-ring nil
- "List of recent non-regexp incremental searches.
-Each element is a cons cell of the form (STRING . UPPERCASE-FLAG).")
-
-(defvar regexp-search-ring nil
- "List of recent regexp incremental searches.
-Each element is a cons cell of the form (STRING . UPPERCASE-FLAG).")
-
-(defconst search-ring-max 16
- "*Maximum length of search ring before oldest elements are thrown away.")
-
-(defvar search-ring-yank-pointer nil
- "The tail of the search ring whose car is the last thing searched for.")
-
-(defvar regexp-search-ring-yank-pointer nil
- "The tail of the regular expression search ring whose car is the last
-thing searched for.")
-
-
-(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 RET 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))
-(define-key global-map "\C-s" 'isearch-forward)
-
-(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))
-(define-key esc-map "\C-s" 'isearch-forward-regexp)
-
-(defun isearch-backward ()
- "Do incremental search backward.
-See \\[isearch-forward] for more information."
- (interactive)
- (isearch nil))
-(define-key global-map "\C-r" 'isearch-backward)
-
-(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))
-(define-key esc-map "\C-r" 'isearch-backward-regexp)
-
-
-;; 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.
-
-;; OP-FUN is a function to be called after each input character is processed.
-;; (It is not called after characters that exit the search.)
-
-(defun isearch (forward &optional regexp op-fun)
- (let ((search-string "")
- (search-message "")
- ;; List of previous states during this search.
- (history nil)
- ;; t means search is currently successful.
- (success t)
- ;; Set once the search has wrapped around the end of the buffer.
- (wrapped nil)
- ;; Nominal starting point for searching
- ;; Usually this is the same as the opoint,
- ;; but it is changed by wrapping
- ;; and also by repeating the search.
- (barrier (point))
- ;; Set temporarily when adding a character to a regexp
- ;; enables it to match more rather than fewer places in the buffer.
- liberalized
- ;; Set temporarily by yanking text into the search string.
- yank-flag
- (invalid-regexp nil)
- ;; non-nil means an explicit uppercase letter seen in the input
- (uppercase-flag nil)
- ;; Non-nil means start using a small window
- ;; if the search moves outside what is currently on the frame.
- (slow-terminal-mode (and (<= baud-rate search-slow-speed)
- (> (window-height)
- (* 4 search-slow-window-lines))))
- ;; t means a small window is currently in use.
- (small-window nil) ;if t, using a small window
- ;; These variables preserve information from the small window
- ;; through exit from the save-window-excursion.
- (found-point nil)
- (found-start nil)
- ;; Point is at one end of the last match.
- ;; This variable records the other end of that match.
- (other-end nil)
- ;; Value of point at start of search,
- ;; for moving the cursor back on quitting.
- (opoint (point))
- (inhibit-quit t) ;Prevent ^G from quitting, so we can read it.
- ;; The frame we're working on; if this changes, we exit isearch.
- (frame (if (fboundp 'selected-frame) (selected-frame))))
-
- (isearch-push-state)
- (save-window-excursion
- (catch 'search-done
- (while t
- (or (and (numberp unread-command-char) (>= 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-event))))
- (setq quit-flag nil liberalized nil yank-flag nil)
- (cond ((and (or (not (integerp char))
- (and (>= char 128)
- (not (= char search-ring-advance-char))
- (not (= char search-ring-retreat-char))))
- search-exit-option)
- (setq unread-command-char char)
- (throw 'search-done t))
-
- ;; If the user switches to a different frame, exit.
- ((not (eq frame last-event-frame))
- (setq unread-command-char char)
- (throw 'search-done t))
-
- ((eq char search-exit-char)
- ;; RET 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.
- (isearch-get-string-from-ring)
- ;; 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 "")
- (progn
- ;; If repeating a search that found an empty string,
- ;; ensure we advance. Test history to make sure we
- ;; actually have done a search already; otherwise,
- ;; the match data will be random.
- (if (and (cdr history)
- (= (match-end 0) (match-beginning 0)))
- (forward-char (if forward 1 -1)))
- (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 history))
- (ding)
- (isearch-pop)))
- ((= char search-ring-advance-char)
- (isearch-pop)
- (if regexp
- (let ((length (length regexp-search-ring)))
- (if (zerop length)
- ()
- (setq regexp-search-ring-yank-pointer
- (nthcdr (% (+ 1 (- length (length regexp-search-ring-yank-pointer)))
- length)
- regexp-search-ring))
- (isearch-get-string-from-ring)))
- (let ((length (length search-ring)))
- (if (zerop length)
- ()
- (setq search-ring-yank-pointer
- (nthcdr (% (+ 1 (- length (length search-ring-yank-pointer)))
- length)
- search-ring))
- (isearch-get-string-from-ring))))
- (isearch-push-state)
- (isearch-search))
- ((= char search-ring-retreat-char)
- (isearch-pop)
- (if regexp
- (let ((length (length regexp-search-ring)))
- (if (zerop length)
- ()
- (setq regexp-search-ring-yank-pointer
- (nthcdr (% (+ (- length (length regexp-search-ring-yank-pointer))
- (1- length))
- length)
- regexp-search-ring))
- (isearch-get-string-from-ring)))
- (let ((length (length search-ring)))
- (if (zerop length)
- ()
- (setq search-ring-yank-pointer
- (nthcdr (% (+ (- length (length search-ring-yank-pointer))
- (1- length))
- length)
- search-ring))
- (isearch-get-string-from-ring))))
- (isearch-push-state)
- (isearch-search))
- (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 ""))
- ;; Don't move cursor in reverse search.
- yank-flag t)))
- ;; 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 ?\n))))
- (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)
- ;; RET translates to newline.
- (setq char ?\n)))
- (setq search-string (concat search-string
- (char-to-string char))
- search-message (concat search-message
- (text-char-description char))
- uppercase-flag (or uppercase-flag
- (not (= char (downcase char)))))))
- (if (and (not success)
- ;; unsuccessful regexp search may become
- ;; successful by addition of characters which
- ;; make search-string valid
- (not regexp))
- nil
- ;; Check for chars that can make a regexp more liberal.
- ;; They can make a regexp match sooner
- ;; or make it succeed instead of failing.
- ;; So go back to place last successful search started
- ;; or to the last ^S/^R (barrier), whichever is nearer.
- (and regexp history
- (cond ((and (memq char '(?* ??))
- ;; Don't treat *, ? as special
- ;; within [] or after \.
- (not (nth 6 (car history))))
- (setq liberalized 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 history)))))
- ;; (car history) is after last search;
- ;; (car (cdr history)) is from before it.
- (setq cs (or cs barrier))
- (goto-char
- (if forward
- (max cs barrier)
- (min cs barrier)))))
- ((eq char ?\|)
- (setq liberalized t)
- (goto-char barrier))))
- ;; Turn off case-sensitivity if string requests it.
- (let ((case-fold-search
- (and case-fold-search
- (not (and uppercase-flag
- search-upper-case)))))
- ;; In reverse search, adding stuff at
- ;; the end may cause zero or many more chars to be
- ;; matched, in the string following point.
- ;; Allow all those possibilities without moving point as
- ;; long as the match does not extend past search origin.
- (if (and (not forward) (not liberalized)
- (condition-case ()
- (looking-at (if regexp search-string
- (regexp-quote search-string)))
- (error nil))
- (or yank-flag
- ;; Used to have (min opoint barrier)
- ;; instead of barrier.
- ;; This lost when wrapping.
- (<= (match-end 0) 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 liberalized))
- (goto-char (if forward other-end
- ;; Used to have opoint inside the min.
- ;; This lost when wrapping.
- (min barrier (1+ other-end)))))
- (isearch-search))))
- (isearch-push-state))))
- (if op-fun (funcall op-fun))))
- (setq found-start (window-start (selected-window)))
- (setq found-point (point)))
- (if (> (length search-string) 0)
- (if (and regexp (not (member search-string regexp-search-ring)))
- (progn
- (setq regexp-search-ring (cons (cons search-string uppercase-flag)
- regexp-search-ring)
- regexp-search-ring-yank-pointer regexp-search-ring)
- (if (> (length regexp-search-ring) search-ring-max)
- (setcdr (nthcdr (1- search-ring-max) regexp-search-ring) nil)))
- (if (not (member search-string search-ring))
- (progn
- (setq search-ring (cons (cons search-string uppercase-flag)
- search-ring)
- search-ring-yank-pointer search-ring)
- (if (> (length search-ring) search-ring-max)
- (setcdr (nthcdr (1- search-ring-max) search-ring) nil))))))
- ;; 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 (or (not case-fold-search)
- (and uppercase-flag search-upper-case))
- "case-sensitive ")
- (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)))))
-
-;; Get the search string from the "front" of the ring of previous searches.
-(defun isearch-get-string-from-ring ()
- (let ((elt (car (if regexp
- (or regexp-search-ring-yank-pointer regexp-search-ring)
- (or search-ring-yank-pointer search-ring)))))
- ;; ELT describes the most recent search or where we have rotated the ring.
- (if elt
- (setq search-string (car elt)
- uppercase-flag (cdr elt))
- (setq search-string "" uppercase-flag nil)))
- ;; Let's give this one the benefit of the doubt.
- (setq invalid-regexp nil)
- (setq search-message (mapconcat 'text-char-description search-string "")))
-
-(defun isearch-pop ()
- (setq history (cdr history))
- (let ((cmd (car history)))
- (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)
- uppercase-flag (nth 9 cmd))
- (goto-char (car (cdr (cdr cmd))))))
-
-(defun isearch-push-state ()
- (setq history (cons (list search-string search-message (point)
- success forward other-end invalid-regexp
- wrapped barrier uppercase-flag)
- history)))
-
-(defun isearch-search ()
- (let ((case-fold-search
- (and case-fold-search
- (not (and uppercase-flag
- search-upper-case)))))
- (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 history))
- (ding))
- (goto-char (nth 2 (car history))))))
-
-;; 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-event)))
- (if (and (numberp char) (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))
- ;; Empty means use default.
- (if (= 0 (length string))
- (setq string search-last-string)
- ;; Set last search string now so it is set even if we fail.
- (setq search-last-string 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)))
-
-;;; isearch.el ends here
+++ /dev/null
-;;; iso8859-1.el --- set up case-conversion and syntax tables for ISO 8859/1
-
-;; Copyright (C) 1988 Free Software Foundation, Inc.
-
-;; Author: Howard Gayle
-;; Maintainer: FSF
-;; Keywords: i18n
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to
-;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;;; Commentary:
-
-;; Written by Howard Gayle. See case-table.el for details.
-
-;;; Code:
-
-(require 'case-table)
-
-(let ((table (car (standard-case-table))))
- (set-case-syntax 160 " " table) ; NBSP (no-break space)
- (set-case-syntax 161 "." table) ; inverted exclamation mark
- (set-case-syntax 162 "w" table) ; cent sign
- (set-case-syntax 163 "w" table) ; pound sign
- (set-case-syntax 164 "w" table) ; general currency sign
- (set-case-syntax 165 "w" table) ; yen sign
- (set-case-syntax 166 "_" table) ; broken vertical line
- (set-case-syntax 167 "w" table) ; section sign
- (set-case-syntax 168 "w" table) ; diaeresis
- (set-case-syntax 169 "_" table) ; copyright sign
- (set-case-syntax 170 "w" table) ; ordinal indicator, feminine
- (set-case-syntax-delims 171 187 table) ; angle quotation marks
- (set-case-syntax 172 "_" table) ; not sign
- (set-case-syntax 173 "_" table) ; soft hyphen
- (set-case-syntax 174 "_" table) ; registered sign
- (set-case-syntax 175 "w" table) ; macron
- (set-case-syntax 176 "_" table) ; degree sign
- (set-case-syntax 177 "_" table) ; plus or minus sign
- (set-case-syntax 178 "w" table) ; superscript two
- (set-case-syntax 179 "w" table) ; superscript three
- (set-case-syntax 180 "w" table) ; acute accent
- (set-case-syntax 181 "_" table) ; micro sign
- (set-case-syntax 182 "w" table) ; pilcrow
- (set-case-syntax 183 "_" table) ; middle dot
- (set-case-syntax 184 "w" table) ; cedilla
- (set-case-syntax 185 "w" table) ; superscript one
- (set-case-syntax 186 "w" table) ; ordinal indicator, masculine
- ;; 187 ; See 171 above.
- (set-case-syntax 188 "_" table) ; fraction one-quarter
- (set-case-syntax 189 "_" table) ; fraction one-half
- (set-case-syntax 190 "_" table) ; fraction three-quarters
- (set-case-syntax 191 "." table) ; inverted question mark
- (set-case-syntax-pair 192 224 table) ; A with grave accent
- (set-case-syntax-pair 193 225 table) ; A with acute accent
- (set-case-syntax-pair 194 226 table) ; A with circumflex accent
- (set-case-syntax-pair 195 227 table) ; A with tilde
- (set-case-syntax-pair 196 228 table) ; A with diaeresis or umlaut mark
- (set-case-syntax-pair 197 229 table) ; A with ring
- (set-case-syntax-pair 198 230 table) ; AE diphthong
- (set-case-syntax-pair 199 231 table) ; C with cedilla
- (set-case-syntax-pair 200 232 table) ; E with grave accent
- (set-case-syntax-pair 201 233 table) ; E with acute accent
- (set-case-syntax-pair 202 234 table) ; E with circumflex accent
- (set-case-syntax-pair 203 235 table) ; E with diaeresis or umlaut mark
- (set-case-syntax-pair 204 236 table) ; I with grave accent
- (set-case-syntax-pair 205 237 table) ; I with acute accent
- (set-case-syntax-pair 206 238 table) ; I with circumflex accent
- (set-case-syntax-pair 207 239 table) ; I with diaeresis or umlaut mark
- (set-case-syntax-pair 208 240 table) ; D with stroke, Icelandic eth
- (set-case-syntax-pair 209 241 table) ; N with tilde
- (set-case-syntax-pair 210 242 table) ; O with grave accent
- (set-case-syntax-pair 211 243 table) ; O with acute accent
- (set-case-syntax-pair 212 244 table) ; O with circumflex accent
- (set-case-syntax-pair 213 245 table) ; O with tilde
- (set-case-syntax-pair 214 246 table) ; O with diaeresis or umlaut mark
- (set-case-syntax 215 "_" table) ; multiplication sign
- (set-case-syntax-pair 216 248 table) ; O with slash
- (set-case-syntax-pair 217 249 table) ; U with grave accent
- (set-case-syntax-pair 218 250 table) ; U with acute accent
- (set-case-syntax-pair 219 251 table) ; U with circumflex accent
- (set-case-syntax-pair 220 252 table) ; U with diaeresis or umlaut mark
- (set-case-syntax-pair 221 253 table) ; Y with acute accent
- (set-case-syntax-pair 222 254 table) ; thorn, Icelandic
- (set-case-syntax 223 "w" table) ; small sharp s, German
- (set-case-syntax 247 "_" table) ; division sign
- (set-case-syntax 255 "w" table) ; small y with diaeresis or umlaut mark
- (set-standard-case-table (list table)))
-
-(provide 'iso8859-1)
-
-;;; iso8859-1.el ends here
+++ /dev/null
-;;; libc.el -- lookup C symbols in the GNU C Library Reference Manual.
-
-;; Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc.
-
-;;; Author: Ralph Schleicher <rs@purple.UL.BaWue.DE>
-;;; Keywords: local c info
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;;; Commentary:
-
-;; This code has a long history. It started as a minor
-;; mode for C mode. This era ended with the release of version 2
-;; of the GNU C Library in 1997. The code was therefore rewritten
-;; more or less from scratch so that all lookups are performed via
-;; indices. Not finding an existing symbol in an index means that
-;; there is an error in the manual. Long missed features like a
-;; separate input history, symbol name completion in the mini-buffer,
-;; highlighting of looked up symbol names in the Info buffer, and
-;; implicitly prepending `struct', `union' or `enum' to data types
-;; were added in this phase too.
-
-;;; Code:
-
-(require 'info)
-
-\f
-(defvar libc-info-file-name "libc"
- "Basename of the Info file of the GNU C Library Reference Manual.")
-
-(defvar libc-highlight-face 'highlight
- "*Face for highlighting looked up symbol names in the Info buffer.
-`nil' disables highlighting.")
-
-(defvar libc-highlight-overlay nil
- "Overlay object used for highlighting.")
-
-(defconst libc-symbol-completions nil
- "Alist of documented C symbols.")
-
-(defconst libc-file-completions nil
- "Alist of documented programs or files.")
-
-(defvar libc-history nil
- "History of previous input lines.")
-
-;;;###autoload
-(defun libc-describe-symbol (symbol-name)
- "Display the documentation of a C symbol in another window.
-SYMBOL-NAME must be documented in the GNU C Library Reference Manual.
-
-If called interactively, SYMBOL-NAME will be read from the mini-buffer.
-Optional prefix argument means insert the default symbol (if any) into
-the mini-buffer so that it can be edited. The default symbol is the
-one found at point.
-
-If SYMBOL-NAME is a public function, variable, or data type of the GNU
-C Library but `libc-describe-symbol' fails to display it's documentation,
-then you have found a bug in the manual. Please report that to the mail
-address `bug-glibc-manual@prep.ai.mit.edu' so that it can be fixed."
- (interactive
- (let* ((completion-ignore-case nil)
- (enable-recursive-minibuffers t)
- (symbol (libc-symbol-at-point))
- (value (completing-read
- (if symbol
- (format "Describe symbol (default %s): " symbol)
- (format "Describe symbol: "))
- libc-symbol-completions nil nil
- (and current-prefix-arg symbol) 'libc-history)))
- (list (if (equal value "") symbol value))))
- (or (assoc symbol-name libc-symbol-completions)
- (error "Not documented as a C symbol: %s" (or symbol-name "")))
- (or (libc-lookup-function symbol-name)
- (libc-lookup-variable symbol-name)
- (libc-lookup-type symbol-name)))
-
-;;;###autoload
-(defun libc-describe-file (file-name)
- "Display the documentation of a program or file in another window.
-FILE-NAME must be documented in the GNU C Library Reference Manual."
- (interactive
- (let* ((completion-ignore-case nil)
- (enable-recursive-minibuffers t))
- (list (completing-read
- "Describe program or file: "
- libc-file-completions nil nil nil 'libc-history))))
- (or (assoc file-name libc-file-completions)
- (error "Not documented as a program or file: %s" (or file-name "")))
- (libc-lookup-file file-name))
-
-;;;###autoload
-(defun libc-search (regexp &optional arg)
- "Search in the GNU C Library Reference Manual for REGEXP.
-Prefix argument means search should ignore case."
- (interactive "sSearch `libc.info' for regexp: \nP")
- (or (get-buffer "*info*")
- (save-window-excursion
- (info)))
- (switch-to-buffer-other-window "*info*")
- (Info-goto-node (concat "(" libc-info-file-name ")"))
- (let ((case-fold-search arg))
- (Info-search regexp)))
-
-\f
-(defun libc-make-completion-alist (info-nodes &optional regexp)
- "Create a unique alist from all menu items in the Info nodes INFO-NODES
-of the GNU C Reference Manual.
-
-Optional second argument REGEXP means include only menu items matching the
-regular expression REGEXP."
- (condition-case nil
- (let (completions item)
- (save-window-excursion
- (info libc-info-file-name)
- (while info-nodes
- (Info-goto-node (car info-nodes))
- (goto-char (point-min))
- (and (search-forward "\n* Menu:" nil t)
- (while (re-search-forward "\n\\* \\([^:\t\n]*\\):" nil t)
- (setq item (buffer-substring
- (match-beginning 1) (match-end 1)))
- (and (not (assoc item completions))
- (if regexp (string-match regexp item) t)
- (setq completions (cons (cons item nil)
- completions)))))
- (setq info-nodes (cdr info-nodes)))
- (Info-directory))
- completions)
- (error nil)))
-
-(defun libc-after-manual-update ()
- "This function must only be called after a new version of the
-GNU C Library Reference Manual was installed on your system."
- (setq libc-symbol-completions (libc-make-completion-alist
- '("Function Index"
- "Variable Index"
- "Type Index"))
- libc-file-completions (libc-make-completion-alist
- '("File Index") "^[^ \t]+$")))
-
-(or (and libc-symbol-completions
- libc-file-completions)
- (libc-after-manual-update))
-
-(defun libc-symbol-at-point ()
- "Get the C symbol at point."
- (condition-case nil
- (save-excursion
- (backward-sexp)
- (let ((start (point))
- prefix name)
- ;; Test for a leading `struct', `union', or `enum' keyword
- ;; but ignore names like `foo_struct'.
- (setq prefix (and (< (skip-chars-backward " \t\n") 0)
- (< (skip-chars-backward "_a-zA-Z0-9") 0)
- (looking-at "\\(struct\\|union\\|enum\\)\\s ")
- (concat (buffer-substring
- (match-beginning 1) (match-end 1))
- " ")))
- (goto-char start)
- (and (looking-at "[_a-zA-Z][_a-zA-Z0-9]*")
- (setq name (buffer-substring
- (match-beginning 0) (match-end 0))))
- ;; Caveat! Look forward if point is at `struct' etc.
- (and (not prefix)
- (or (string-equal name "struct")
- (string-equal name "union")
- (string-equal name "enum"))
- (looking-at "[a-z]+\\s +\\([_a-zA-Z][_a-zA-Z0-9]*\\)")
- (setq prefix (concat name " ")
- name (buffer-substring
- (match-beginning 1) (match-end 1))))
- (and (or prefix name)
- (concat prefix name))))
- (error nil)))
-
-(defun libc-lookup-function (function)
- (libc-search-index "Function Index" function
- "^[ \t]+- \\(Function\\|Macro\\): .*\\<" "\\>"))
-
-(defun libc-lookup-variable (variable)
- (libc-search-index "Variable Index" variable
- "^[ \t]+- \\(Variable\\|Macro\\): .*\\<" "\\>"))
-
-(defun libc-lookup-type (data-type)
- (libc-search-index "Type Index" data-type
- "^[ \t]+- Data Type: \\<" "\\>"))
-
-(defun libc-lookup-file (file-name)
- (libc-search-index "File Index" file-name))
-
-(defun libc-search-index (index item &optional prefix suffix)
- "Search ITEM in the Info index INDEX and go to that Info node.
-
-Value is ITEM or `nil' if an error occurs.
-
-If PREFIX and/or SUFFIX are non-`nil', then search the Info node for
-the first occurrence of the regular expression `PREFIX ITEM SUFFIX' and
-leave point at the beginning of the first line of the match. ITEM will
-be highlighted with `libc-highlight-face' iff `libc-highlight-face' is
-not `nil'."
- (condition-case nil
- (save-selected-window
- (or (get-buffer "*info*")
- (save-window-excursion
- (info)))
- (switch-to-buffer-other-window "*info*")
- (Info-goto-node (concat "(" libc-info-file-name ")" index))
- (Info-menu item)
- (if (or prefix suffix)
- (let ((case-fold-search nil)
- (buffer-read-only nil))
- (goto-char (point-min))
- (re-search-forward
- (concat prefix (regexp-quote item) suffix))
- (goto-char (match-beginning 0))
- (and window-system libc-highlight-face
- ;; Search again for ITEM so that the first
- ;; occurence of ITEM will be highlighted.
- (save-excursion
- (re-search-forward (regexp-quote item))
- (let ((start (match-beginning 0))
- (end (match-end 0)))
- (if (overlayp libc-highlight-overlay)
- (move-overlay libc-highlight-overlay
- start end (current-buffer))
- (setq libc-highlight-overlay
- (make-overlay start end))))
- (overlay-put libc-highlight-overlay
- 'face libc-highlight-face)))
- (beginning-of-line)))
- item)
- (error nil)))
-
-\f
-(provide 'libc)
-
-;;; libc.el ends here
+++ /dev/null
-;;; man.el --- browse UNIX manual pages
-
-;; Copyright (C) 1993, 1994, 1996, 1997 Free Software Foundation, Inc.
-
-;; Author: Barry A. Warsaw <bwarsaw@cen.com>
-;; Maintainer: FSF
-;; Keywords: help
-;; Adapted-By: ESR, pot
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;;; Commentary:
-
-;; This code provides a function, `man', with which you can browse
-;; UNIX manual pages. Formatting is done in background so that you
-;; can continue to use your Emacs while processing is going on.
-;;
-;; The mode also supports hypertext-like following of manual page SEE
-;; ALSO references, and other features. See below or do `?' in a
-;; manual page buffer for details.
-
-;; ========== Credits and History ==========
-;; In mid 1991, several people posted some interesting improvements to
-;; man.el from the standard emacs 18.57 distribution. I liked many of
-;; these, but wanted everything in one single package, so I decided
-;; to incorporate them into a single manual browsing mode. While
-;; much of the code here has been rewritten, and some features added,
-;; these folks deserve lots of credit for providing the initial
-;; excellent packages on which this one is based.
-
-;; Nick Duffek <duffek@chaos.cs.brandeis.edu>, posted a very nice
-;; improvement which retrieved and cleaned the manpages in a
-;; background process, and which correctly deciphered such options as
-;; man -k.
-
-;; Eric Rose <erose@jessica.stanford.edu>, submitted manual.el which
-;; provided a very nice manual browsing mode.
-
-;; This package was available as `superman.el' from the LCD package
-;; for some time before it was accepted into Emacs 19. The entry
-;; point and some other names have been changed to make it a drop-in
-;; replacement for the old man.el package.
-
-;; Francesco Potorti` <pot@cnuce.cnr.it> cleaned it up thoroughly,
-;; making it faster, more robust and more tolerant of different
-;; systems' man idiosyncrasies.
-
-;; ========== Features ==========
-;; + Runs "man" in the background and pipes the results through a
-;; series of sed and awk scripts so that all retrieving and cleaning
-;; is done in the background. The cleaning commands are configurable.
-;; + Syntax is the same as Un*x man
-;; + Functionality is the same as Un*x man, including "man -k" and
-;; "man <section>", etc.
-;; + Provides a manual browsing mode with keybindings for traversing
-;; the sections of a manpage, following references in the SEE ALSO
-;; section, and more.
-;; + Multiple manpages created with the same man command are put into
-;; a narrowed buffer circular list.
-
-;; ============= TODO ===========
-;; - Add a command for printing.
-;; - The awk script deletes multiple blank lines. This behaviour does
-;; not allow to understand if there was indeed a blank line at the
-;; end or beginning of a page (after the header, or before the
-;; footer). A different algorithm should be used. It is easy to
-;; compute how many blank lines there are before and after the page
-;; headers, and after the page footer. But it is possible to compute
-;; the number of blank lines before the page footer by euristhics
-;; only. Is it worth doing?
-;; - Allow a user option to mean that all the manpages should go in
-;; the same buffer, where they can be browsed with M-n and M-p.
-;; - Allow completion on the manpage name when calling man. This
-;; requires a reliable list of places where manpages can be found. The
-;; drawback would be that if the list is not complete, the user might
-;; be led to believe that the manpages in the missing directories do
-;; not exist.
-
-\f
-;;; Code:
-
-(require 'assoc)
-
-;; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
-;; empty defvars (keep the compiler quiet)
-
-(defgroup man nil
- "Browse UNIX manual pages."
- :prefix "Man-"
- :group 'help)
-
-
-(defvar Man-notify)
-(defvar Man-current-page)
-(defvar Man-page-list)
-(defcustom Man-filter-list nil
- "*Manpage cleaning filter command phrases.
-This variable contains a list of the following form:
-
-'((command-string phrase-string*)*)
-
-Each phrase-string is concatenated onto the command-string to form a
-command filter. The (standard) output (and standard error) of the Un*x
-man command is piped through each command filter in the order the
-commands appear in the association list. The final output is placed in
-the manpage buffer."
- :type '(repeat (list (string :tag "Command String")
- (repeat :inline t
- (string :tag "Phrase String"))))
- :group 'man)
-
-(defvar Man-original-frame)
-(defvar Man-arguments)
-(defvar Man-sections-alist)
-(defvar Man-refpages-alist)
-(defvar Man-uses-untabify-flag t
- "Non-nil means use `untabify' instead of `Man-untabify-command'.")
-(defvar Man-page-mode-string)
-(defvar Man-sed-script nil
- "Script for sed to nuke backspaces and ANSI codes from manpages.")
-
-;; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
-;; user variables
-
-(defcustom Man-fontify-manpage-flag t
- "*Non-nil means make up the manpage with fonts."
- :type 'boolean
- :group 'man)
-
-(defcustom Man-overstrike-face 'bold
- "*Face to use when fontifying overstrike."
- :type 'face
- :group 'man)
-
-(defcustom Man-underline-face 'underline
- "*Face to use when fontifying underlining."
- :type 'face
- :group 'man)
-
-;; Use the value of the obsolete user option Man-notify, if set.
-(defcustom Man-notify-method (if (boundp 'Man-notify) Man-notify 'friendly)
- "*Selects the behavior when manpage is ready.
-This variable may have one of the following values, where (sf) means
-that the frames are switched, so the manpage is displayed in the frame
-where the man command was called from:
-
-newframe -- put the manpage in its own frame (see `Man-frame-parameters')
-pushy -- make the manpage the current buffer in the current window
-bully -- make the manpage the current buffer and only window (sf)
-aggressive -- make the manpage the current buffer in the other window (sf)
-friendly -- display manpage in the other window but don't make current (sf)
-polite -- don't display manpage, but prints message and beep when ready
-quiet -- like `polite', but don't beep
-meek -- make no indication that the manpage is ready
-
-Any other value of `Man-notify-method' is equivalent to `meek'."
- :type '(radio (const newframe) (const pushy) (const bully)
- (const aggressive) (const friendly)
- (const polite) (const quiet) (const meek))
- :group 'man)
-
-(defcustom Man-frame-parameters nil
- "*Frame parameter list for creating a new frame for a manual page."
- :type 'sexp
- :group 'man)
-
-(defcustom Man-downcase-section-letters-flag t
- "*Non-nil means letters in sections are converted to lower case.
-Some Un*x man commands can't handle uppercase letters in sections, for
-example \"man 2V chmod\", but they are often displayed in the manpage
-with the upper case letter. When this variable is t, the section
-letter (e.g., \"2V\") is converted to lowercase (e.g., \"2v\") before
-being sent to the man background process."
- :type 'boolean
- :group 'man)
-
-(defcustom Man-circular-pages-flag t
- "*Non-nil means the manpage list is treated as circular for traversal."
- :type 'boolean
- :group 'man)
-
-(defcustom Man-section-translations-alist
- (list
- '("3C++" . "3")
- ;; Some systems have a real 3x man section, so let's comment this.
- ;; '("3X" . "3") ; Xlib man pages
- '("3X11" . "3")
- '("1-UCB" . ""))
- "*Association list of bogus sections to real section numbers.
-Some manpages (e.g. the Sun C++ 2.1 manpages) have section numbers in
-their references which Un*x `man' does not recognize. This
-association list is used to translate those sections, when found, to
-the associated section number."
- :type '(repeat (cons (string :tag "Bogus Section")
- (string :tag "Real Section")))
- :group 'man)
-
-(defvar manual-program "man"
- "The name of the program that produces man pages.")
-
-(defvar Man-untabify-command "pr"
- "Command used for untabifying.")
-
-(defvar Man-untabify-command-args (list "-t" "-e")
- "List of arguments to be passed to `Man-untabify-command' (which see).")
-
-(defvar Man-sed-command "sed"
- "Command used for processing sed scripts.")
-
-(defvar Man-awk-command "awk"
- "Command used for processing awk scripts.")
-
-(defvar Man-mode-line-format
- '("-"
- mode-line-mule-info
- mode-line-modified
- mode-line-frame-identification
- mode-line-buffer-identification " "
- global-mode-string
- " " Man-page-mode-string
- " %[(" mode-name mode-line-process minor-mode-alist "%n)%]--"
- (line-number-mode "L%l--")
- (column-number-mode "C%c--")
- (-3 . "%p") "-%-")
- "Mode line format for manual mode buffer.")
-
-(defvar Man-mode-map nil
- "Keymap for Man mode.")
-
-(defvar Man-mode-hook nil
- "Hook run when Man mode is enabled.")
-
-(defvar Man-cooked-hook nil
- "Hook run after removing backspaces but before `Man-mode' processing.")
-
-(defvar Man-name-regexp "[-a-zA-Z0-9_][-a-zA-Z0-9_.]*"
- "Regular expression describing the name of a manpage (without section).")
-
-(defvar Man-section-regexp "[0-9][a-zA-Z+]*\\|[LNln]"
- "Regular expression describing a manpage section within parentheses.")
-
-(defvar Man-page-header-regexp
- (if (and (string-match "-solaris2\\." system-configuration)
- (not (string-match "-solaris2\\.[123435]$" system-configuration)))
- (concat "^[-A-Za-z0-9_].*[ \t]\\(" Man-name-regexp
- "(\\(" Man-section-regexp "\\))\\)$")
- (concat "^[ \t]*\\(" Man-name-regexp
- "(\\(" Man-section-regexp "\\))\\).*\\1"))
- "Regular expression describing the heading of a page.")
-
-(defvar Man-heading-regexp "^\\([A-Z][A-Z ]+\\)$"
- "Regular expression describing a manpage heading entry.")
-
-(defvar Man-see-also-regexp "SEE ALSO"
- "Regular expression for SEE ALSO heading (or your equivalent).
-This regexp should not start with a `^' character.")
-
-(defvar Man-first-heading-regexp "^[ \t]*NAME$\\|^[ \t]*No manual entry fo.*$"
- "Regular expression describing first heading on a manpage.
-This regular expression should start with a `^' character.")
-
-(defvar Man-reference-regexp
- (concat "\\(" Man-name-regexp "\\)(\\(" Man-section-regexp "\\))")
- "Regular expression describing a reference to another manpage.")
-
-;; This includes the section as an optional part to catch hyphenated
-;; refernces to manpages.
-(defvar Man-hyphenated-reference-regexp
- (concat "\\(" Man-name-regexp "\\)\\((\\(" Man-section-regexp "\\))\\)?")
- "Regular expression describing a reference in the SEE ALSO section.")
-
-(defvar Man-switches ""
- "Switches passed to the man command, as a single string.")
-
-(defvar Man-specified-section-option
- (if (string-match "-solaris[0-9.]*$" system-configuration)
- "-s"
- "")
- "Option that indicates a specified a manual section name.")
-
-;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-;; end user variables
-\f
-;; other variables and keymap initializations
-(make-variable-buffer-local 'Man-sections-alist)
-(make-variable-buffer-local 'Man-refpages-alist)
-(make-variable-buffer-local 'Man-page-list)
-(make-variable-buffer-local 'Man-current-page)
-(make-variable-buffer-local 'Man-page-mode-string)
-(make-variable-buffer-local 'Man-original-frame)
-(make-variable-buffer-local 'Man-arguments)
-
-(setq-default Man-sections-alist nil)
-(setq-default Man-refpages-alist nil)
-(setq-default Man-page-list nil)
-(setq-default Man-current-page 0)
-(setq-default Man-page-mode-string "1 of 1")
-
-(defconst Man-sysv-sed-script "\
-/\b/ { s/_\b//g
- s/\b_//g
- s/o\b+/o/g
- s/+\bo/o/g
- :ovstrk
- s/\\(.\\)\b\\1/\\1/g
- t ovstrk
- }
-/\e\\[[0-9][0-9]*m/ s///g"
- "Script for sysV-like sed to nuke backspaces and ANSI codes from manpages.")
-
-(defconst Man-berkeley-sed-script "\
-/\b/ { s/_\b//g\\
- s/\b_//g\\
- s/o\b+/o/g\\
- s/+\bo/o/g\\
- :ovstrk\\
- s/\\(.\\)\b\\1/\\1/g\\
- t ovstrk\\
- }\\
-/\e\\[[0-9][0-9]*m/ s///g"
- "Script for berkeley-like sed to nuke backspaces and ANSI codes from manpages.")
-
-(defvar man-mode-syntax-table
- (let ((table (copy-syntax-table (standard-syntax-table))))
- (modify-syntax-entry ?. "w" table)
- (modify-syntax-entry ?_ "w" table)
- table)
- "Syntax table used in Man mode buffers.")
-
-(if Man-mode-map
- nil
- (setq Man-mode-map (make-keymap))
- (suppress-keymap Man-mode-map)
- (define-key Man-mode-map " " 'scroll-up)
- (define-key Man-mode-map "\177" 'scroll-down)
- (define-key Man-mode-map "n" 'Man-next-section)
- (define-key Man-mode-map "p" 'Man-previous-section)
- (define-key Man-mode-map "\en" 'Man-next-manpage)
- (define-key Man-mode-map "\ep" 'Man-previous-manpage)
- (define-key Man-mode-map ">" 'end-of-buffer)
- (define-key Man-mode-map "<" 'beginning-of-buffer)
- (define-key Man-mode-map "." 'beginning-of-buffer)
- (define-key Man-mode-map "r" 'Man-follow-manual-reference)
- (define-key Man-mode-map "g" 'Man-goto-section)
- (define-key Man-mode-map "s" 'Man-goto-see-also-section)
- (define-key Man-mode-map "k" 'Man-kill)
- (define-key Man-mode-map "q" 'Man-quit)
- (define-key Man-mode-map "m" 'man)
- (define-key Man-mode-map "\r" 'man-follow)
- (define-key Man-mode-map "?" 'describe-mode)
- )
-
-\f
-;; ======================================================================
-;; utilities
-
-(defun Man-init-defvars ()
- "Used for initialising variables based on display's color support.
-This is necessary if one wants to dump man.el with Emacs."
-
- ;; Avoid possible error in call-process by using a directory that must exist.
- (let ((default-directory "/"))
- (setq Man-sed-script
- (cond
- (Man-fontify-manpage-flag
- nil)
- ((= 0 (call-process Man-sed-command nil nil nil Man-sysv-sed-script))
- Man-sysv-sed-script)
- ((= 0 (call-process Man-sed-command nil nil nil Man-berkeley-sed-script))
- Man-berkeley-sed-script)
- (t
- nil))))
-
- (setq Man-filter-list
- ;; Avoid trailing nil which confuses customize.
- (apply 'list
- (cons
- Man-sed-command
- (list
- (if Man-sed-script
- (concat "-e '" Man-sed-script "'")
- "")
- "-e '/^[\001-\032][\001-\032]*$/d'"
- "-e '/\e[789]/s///g'"
- "-e '/Reformatting page. Wait/d'"
- "-e '/Reformatting entry. Wait/d'"
- "-e '/^[ \t]*Hewlett-Packard[ \t]Company[ \t]*-[ \t][0-9]*[ \t]-/d'"
- "-e '/^[ \t]*Hewlett-Packard[ \t]*-[ \t][0-9]*[ \t]-.*$/d'"
- "-e '/^[ \t][ \t]*-[ \t][0-9]*[ \t]-[ \t]*Formatted:.*[0-9]$/d'"
- "-e '/^[ \t]*Page[ \t][0-9]*.*(printed[ \t][0-9\\/]*)$/d'"
- "-e '/^Printed[ \t][0-9].*[0-9]$/d'"
- "-e '/^[ \t]*X[ \t]Version[ \t]1[01].*Release[ \t][0-9]/d'"
- "-e '/^[A-Za-z].*Last[ \t]change:/d'"
- "-e '/^Sun[ \t]Release[ \t][0-9].*[0-9]$/d'"
- "-e '/[ \t]*Copyright [0-9]* UNIX System Laboratories, Inc.$/d'"
- "-e '/^[ \t]*Rev\\..*Page [0-9][0-9]*$/d'"
- ))
- (cons
- Man-awk-command
- (list
- "'\n"
- "BEGIN { blankline=0; anonblank=0; }\n"
- "/^$/ { if (anonblank==0) next; }\n"
- "{ anonblank=1; }\n"
- "/^$/ { blankline++; next; }\n"
- "{ if (blankline>0) { print \"\"; blankline=0; } print $0; }\n"
- "'"
- ))
- (if (not Man-uses-untabify-flag)
- ;; The outer list will be stripped off by apply.
- (list (cons
- Man-untabify-command
- Man-untabify-command-args))
- )))
-)
-
-(defsubst Man-match-substring (&optional n string)
- "Return the substring matched by the last search.
-Optional arg N means return the substring matched by the Nth paren
-grouping. Optional second arg STRING means return a substring from
-that string instead of from the current buffer."
- (if (null n) (setq n 0))
- (if string
- (substring string (match-beginning n) (match-end n))
- (buffer-substring (match-beginning n) (match-end n))))
-
-(defsubst Man-make-page-mode-string ()
- "Formats part of the mode line for Man mode."
- (format "%s page %d of %d"
- (or (nth 2 (nth (1- Man-current-page) Man-page-list))
- "")
- Man-current-page
- (length Man-page-list)))
-
-(defsubst Man-build-man-command ()
- "Builds the entire background manpage and cleaning command."
- (let ((command (concat manual-program " " Man-switches
- ; Stock MS-DOS shells cannot redirect stderr;
- ; `call-process' below sends it to /dev/null,
- ; so we don't need `2>' even with DOS shells
- ; which do support stderr redirection.
- (if (not (fboundp 'start-process))
- " %s"
- (concat " %s 2>" null-device))))
- (flist Man-filter-list))
- (while (and flist (car flist))
- (let ((pcom (car (car flist)))
- (pargs (cdr (car flist))))
- (setq command
- (concat command " | " pcom " "
- (mapconcat (lambda (phrase)
- (if (not (stringp phrase))
- (error "Malformed Man-filter-list"))
- phrase)
- pargs " ")))
- (setq flist (cdr flist))))
- command))
-
-(defun Man-translate-references (ref)
- "Translates REF from \"chmod(2V)\" to \"2v chmod\" style.
-Leave it as is if already in that style. Possibly downcase and
-translate the section (see the Man-downcase-section-letters-flag
-and the Man-section-translations-alist variables)."
- (let ((name "")
- (section "")
- (slist Man-section-translations-alist))
- (cond
- ;; "chmod(2V)" case ?
- ((string-match (concat "^" Man-reference-regexp "$") ref)
- (setq name (Man-match-substring 1 ref)
- section (Man-match-substring 2 ref)))
- ;; "2v chmod" case ?
- ((string-match (concat "^\\(" Man-section-regexp
- "\\) +\\(" Man-name-regexp "\\)$") ref)
- (setq name (Man-match-substring 2 ref)
- section (Man-match-substring 1 ref))))
- (if (string= name "")
- ref ; Return the reference as is
- (if Man-downcase-section-letters-flag
- (setq section (downcase section)))
- (while slist
- (let ((s1 (car (car slist)))
- (s2 (cdr (car slist))))
- (setq slist (cdr slist))
- (if Man-downcase-section-letters-flag
- (setq s1 (downcase s1)))
- (if (not (string= s1 section)) nil
- (setq section (if Man-downcase-section-letters-flag
- (downcase s2)
- s2)
- slist nil))))
- (concat Man-specified-section-option section " " name))))
-
-\f
-;; ======================================================================
-;; default man entry: get word under point
-
-(defsubst Man-default-man-entry ()
- "Make a guess at a default manual entry.
-This guess is based on the text surrounding the cursor."
- (let (word)
- (save-excursion
- ;; Default man entry title is any word the cursor is on, or if
- ;; cursor not on a word, then nearest preceding word.
- (setq word (current-word))
- (if (string-match "[._]+$" word)
- (setq word (substring word 0 (match-beginning 0))))
- ;; If looking at something like ioctl(2) or brc(1M), include the
- ;; section number in the returned value. Remove text properties.
- (forward-word 1)
- ;; Use `format' here to clear any text props from `word'.
- (format "%s%s"
- word
- (if (looking-at
- (concat "[ \t]*([ \t]*\\(" Man-section-regexp "\\)[ \t]*)"))
- (format "(%s)" (Man-match-substring 1))
- "")))))
-
-\f
-;; ======================================================================
-;; Top level command and background process sentinel
-
-;; For compatibility with older versions.
-;;;###autoload
-(defalias 'manual-entry 'man)
-
-;;;###autoload
-(defun man (man-args)
- "Get a Un*x manual page and put it in a buffer.
-This command is the top-level command in the man package. It runs a Un*x
-command to retrieve and clean a manpage in the background and places the
-results in a Man mode (manpage browsing) buffer. See variable
-`Man-notify-method' for what happens when the buffer is ready.
-If a buffer already exists for this man page, it will display immediately.
-
-To specify a man page from a certain section, type SUBJECT(SECTION) or
-SECTION SUBJECT when prompted for a manual entry."
- (interactive
- (list (let* ((default-entry (Man-default-man-entry))
- (input (read-string
- (format "Manual entry%s: "
- (if (string= default-entry "")
- ""
- (format " (default %s)" default-entry))))))
- (if (string= input "")
- (if (string= default-entry "")
- (error "No man args given")
- default-entry)
- input))))
-
- ;; Possibly translate the "subject(section)" syntax into the
- ;; "section subject" syntax and possibly downcase the section.
- (setq man-args (Man-translate-references man-args))
-
- (Man-getpage-in-background man-args))
-
-;;;###autoload
-(defun man-follow (man-args)
- "Get a Un*x manual page of the item under point and put it in a buffer."
- (interactive (list (Man-default-man-entry)))
- (if (or (not man-args)
- (string= man-args ""))
- (error "No item under point")
- (man man-args)))
-
-(defun Man-getpage-in-background (topic)
- "Use TOPIC to build and fire off the manpage and cleaning command."
- (let* ((man-args topic)
- (bufname (concat "*Man " man-args "*"))
- (buffer (get-buffer bufname)))
- (if buffer
- (Man-notify-when-ready buffer)
- (require 'env)
- (message "Invoking %s %s in the background" manual-program man-args)
- (setq buffer (generate-new-buffer bufname))
- (save-excursion
- (set-buffer buffer)
- (setq Man-original-frame (selected-frame))
- (setq Man-arguments man-args))
- (let ((process-environment (copy-sequence process-environment))
- ;; The following is so Awk script gets \n intact
- ;; But don't prevent decoding of the outside.
- (coding-system-for-write 'raw-text-unix)
- ;; We must decode the output by a coding system that the
- ;; system's locale suggests in multibyte mode.
- (coding-system-for-read
- (if default-enable-multibyte-characters
- locale-coding-system 'raw-text-unix))
- ;; Avoid possible error by using a directory that always exists.
- (default-directory "/"))
- ;; Prevent any attempt to use display terminal fanciness.
- (setenv "TERM" "dumb")
- (if (fboundp 'start-process)
- (set-process-sentinel
- (start-process manual-program buffer "sh" "-c"
- (format (Man-build-man-command) man-args))
- 'Man-bgproc-sentinel)
- (progn
- (let ((exit-status
- (call-process shell-file-name nil (list buffer nil) nil "-c"
- (format (Man-build-man-command) man-args)))
- (msg ""))
- (or (and (numberp exit-status)
- (= exit-status 0))
- (and (numberp exit-status)
- (setq msg
- (format "exited abnormally with code %d"
- exit-status)))
- (setq msg exit-status))
- (Man-bgproc-sentinel bufname msg))))))))
-
-(defun Man-notify-when-ready (man-buffer)
- "Notify the user when MAN-BUFFER is ready.
-See the variable `Man-notify-method' for the different notification behaviors."
- (let ((saved-frame (save-excursion
- (set-buffer man-buffer)
- Man-original-frame)))
- (cond
- ((eq Man-notify-method 'newframe)
- ;; Since we run asynchronously, perhaps while Emacs is waiting
- ;; for input, we must not leave a different buffer current. We
- ;; can't rely on the editor command loop to reselect the
- ;; selected window's buffer.
- (save-excursion
- (let ((frame (make-frame Man-frame-parameters)))
- (set-window-buffer (frame-selected-window frame) man-buffer)
- (set-window-dedicated-p (frame-selected-window frame) t)
- (or (display-multi-frame-p frame)
- (select-frame frame)))))
- ((eq Man-notify-method 'pushy)
- (switch-to-buffer man-buffer))
- ((eq Man-notify-method 'bully)
- (and (frame-live-p saved-frame)
- (select-frame saved-frame))
- (pop-to-buffer man-buffer)
- (delete-other-windows))
- ((eq Man-notify-method 'aggressive)
- (and (frame-live-p saved-frame)
- (select-frame saved-frame))
- (pop-to-buffer man-buffer))
- ((eq Man-notify-method 'friendly)
- (and (frame-live-p saved-frame)
- (select-frame saved-frame))
- (display-buffer man-buffer 'not-this-window))
- ((eq Man-notify-method 'polite)
- (beep)
- (message "Manual buffer %s is ready" (buffer-name man-buffer)))
- ((eq Man-notify-method 'quiet)
- (message "Manual buffer %s is ready" (buffer-name man-buffer)))
- ((or (eq Man-notify-method 'meek)
- t)
- (message ""))
- )))
-
-(defun Man-softhyphen-to-minus ()
- ;; \255 is some kind of dash in Latin-N. Versions of Debian man, at
- ;; least, emit it even when not in a Latin-N locale.
- (unless (eq t (compare-strings "latin-" 0 nil
- current-language-environment 0 6 t))
- (goto-char (point-min))
- (let ((str "\255"))
- (if enable-multibyte-characters
- (setq str (string-as-multibyte str)))
- (while (search-forward str nil t) (replace-match "-")))))
-
-(defun Man-fontify-manpage ()
- "Convert overstriking and underlining to the correct fonts.
-Same for the ANSI bold and normal escape sequences."
- (interactive)
- (message "Please wait: making up the %s man page..." Man-arguments)
- (goto-char (point-min))
- (while (search-forward "\e[1m" nil t)
- (delete-backward-char 4)
- (put-text-property (point)
- (progn (if (search-forward "\e[0m" nil 'move)
- (delete-backward-char 4))
- (point))
- 'face Man-overstrike-face))
- (if (< (buffer-size) (position-bytes (point-max)))
- ;; Multibyte characters exist.
- (progn
- (goto-char (point-min))
- (while (search-forward "__\b\b" nil t)
- (backward-delete-char 4)
- (put-text-property (point) (1+ (point)) 'face Man-underline-face))
- (goto-char (point-min))
- (while (search-forward "\b\b__" nil t)
- (backward-delete-char 4)
- (put-text-property (1- (point)) (point) 'face Man-underline-face))))
- (goto-char (point-min))
- (while (search-forward "_\b" nil t)
- (backward-delete-char 2)
- (put-text-property (point) (1+ (point)) 'face Man-underline-face))
- (goto-char (point-min))
- (while (search-forward "\b_" nil t)
- (backward-delete-char 2)
- (put-text-property (1- (point)) (point) 'face Man-underline-face))
- (goto-char (point-min))
- (while (re-search-forward "\\(.\\)\\(\b+\\1\\)+" nil t)
- (replace-match "\\1")
- (put-text-property (1- (point)) (point) 'face Man-overstrike-face))
- (goto-char (point-min))
- (while (re-search-forward "o\b\\+\\|\\+\bo" nil t)
- (replace-match "o")
- (put-text-property (1- (point)) (point) 'face 'bold))
- (goto-char (point-min))
- (while (re-search-forward "[-|]\\(\b[-|]\\)+" nil t)
- (replace-match "+")
- (put-text-property (1- (point)) (point) 'face 'bold))
- (Man-softhyphen-to-minus)
- (message "%s man page made up" Man-arguments))
-
-(defun Man-cleanup-manpage ()
- "Remove overstriking and underlining from the current buffer."
- (interactive)
- (message "Please wait: cleaning up the %s man page..."
- Man-arguments)
- (if (or (interactive-p) (not Man-sed-script))
- (progn
- (goto-char (point-min))
- (while (search-forward "_\b" nil t) (backward-delete-char 2))
- (goto-char (point-min))
- (while (search-forward "\b_" nil t) (backward-delete-char 2))
- (goto-char (point-min))
- (while (re-search-forward "\\(.\\)\\(\b\\1\\)+" nil t)
- (replace-match "\\1"))
- (goto-char (point-min))
- (while (re-search-forward "\e\\[[0-9]+m" nil t) (replace-match ""))
- (goto-char (point-min))
- (while (re-search-forward "o\b\\+\\|\\+\bo" nil t) (replace-match "o"))
- ))
- (goto-char (point-min))
- (while (re-search-forward "[-|]\\(\b[-|]\\)+" nil t) (replace-match "+"))
- (Man-softhyphen-to-minus)
- (message "%s man page cleaned up" Man-arguments))
-
-(defun Man-bgproc-sentinel (process msg)
- "Manpage background process sentinel.
-When manpage command is run asynchronously, PROCESS is the process
-object for the manpage command; when manpage command is run
-synchronously, PROCESS is the name of the buffer where the manpage
-command is run. Second argument MSG is the exit message of the
-manpage command."
- (let ((Man-buffer (if (stringp process) (get-buffer process)
- (process-buffer process)))
- (delete-buff nil)
- (err-mess nil))
-
- (if (null (buffer-name Man-buffer)) ;; deleted buffer
- (or (stringp process)
- (set-process-buffer process nil))
-
- (save-excursion
- (set-buffer Man-buffer)
- (let ((case-fold-search nil))
- (goto-char (point-min))
- (cond ((or (looking-at "No \\(manual \\)*entry for")
- (looking-at "[^\n]*: nothing appropriate$"))
- (setq err-mess (buffer-substring (point)
- (progn
- (end-of-line) (point)))
- delete-buff t))
- ((or (stringp process)
- (not (and (eq (process-status process) 'exit)
- (= (process-exit-status process) 0))))
- (or (zerop (length msg))
- (progn
- (setq err-mess
- (concat (buffer-name Man-buffer)
- ": process "
- (let ((eos (1- (length msg))))
- (if (= (aref msg eos) ?\n)
- (substring msg 0 eos) msg))))
- (goto-char (point-max))
- (insert (format "\nprocess %s" msg))))
- ))
- (if delete-buff
- (kill-buffer Man-buffer)
- (if Man-fontify-manpage-flag
- (Man-fontify-manpage)
- (Man-cleanup-manpage))
- (run-hooks 'Man-cooked-hook)
- (Man-mode)
- (set-buffer-modified-p nil)
- ))
- ;; Restore case-fold-search before calling
- ;; Man-notify-when-ready because it may switch buffers.
-
- (if (not delete-buff)
- (Man-notify-when-ready Man-buffer))
-
- (if err-mess
- (error err-mess))
- ))))
-
-\f
-;; ======================================================================
-;; set up manual mode in buffer and build alists
-
-(defun Man-mode ()
- "A mode for browsing Un*x manual pages.
-
-The following man commands are available in the buffer. Try
-\"\\[describe-key] <key> RET\" for more information:
-
-\\[man] Prompt to retrieve a new manpage.
-\\[Man-follow-manual-reference] Retrieve reference in SEE ALSO section.
-\\[Man-next-manpage] Jump to next manpage in circular list.
-\\[Man-previous-manpage] Jump to previous manpage in circular list.
-\\[Man-next-section] Jump to next manpage section.
-\\[Man-previous-section] Jump to previous manpage section.
-\\[Man-goto-section] Go to a manpage section.
-\\[Man-goto-see-also-section] Jumps to the SEE ALSO manpage section.
-\\[Man-quit] Deletes the manpage window, bury its buffer.
-\\[Man-kill] Deletes the manpage window, kill its buffer.
-\\[describe-mode] Prints this help text.
-
-The following variables may be of some use. Try
-\"\\[describe-variable] <variable-name> RET\" for more information:
-
-`Man-notify-method' What happens when manpage formatting is done.
-`Man-downcase-section-letters-flag' Force section letters to lower case.
-`Man-circular-pages-flag' Treat multiple manpage list as circular.
-`Man-section-translations-alist' List of section numbers and their Un*x equiv.
-`Man-filter-list' Background manpage filter command.
-`Man-mode-line-format' Mode line format for Man mode buffers.
-`Man-mode-map' Keymap bindings for Man mode buffers.
-`Man-mode-hook' Normal hook run on entry to Man mode.
-`Man-section-regexp' Regexp describing manpage section letters.
-`Man-heading-regexp' Regexp describing section headers.
-`Man-see-also-regexp' Regexp for SEE ALSO section (or your equiv).
-`Man-first-heading-regexp' Regexp for first heading on a manpage.
-`Man-reference-regexp' Regexp matching a references in SEE ALSO.
-`Man-switches' Background `man' command switches.
-
-The following key bindings are currently in effect in the buffer:
-\\{Man-mode-map}"
- (interactive)
- (setq major-mode 'Man-mode
- mode-name "Man"
- buffer-auto-save-file-name nil
- mode-line-format Man-mode-line-format
- truncate-lines t
- buffer-read-only t)
- (buffer-disable-undo (current-buffer))
- (auto-fill-mode -1)
- (use-local-map Man-mode-map)
- (set-syntax-table man-mode-syntax-table)
- (Man-build-page-list)
- (Man-strip-page-headers)
- (Man-unindent)
- (Man-goto-page 1)
- (run-hooks 'Man-mode-hook))
-
-(defsubst Man-build-section-alist ()
- "Build the association list of manpage sections."
- (setq Man-sections-alist nil)
- (goto-char (point-min))
- (let ((case-fold-search nil))
- (while (re-search-forward Man-heading-regexp (point-max) t)
- (aput 'Man-sections-alist (Man-match-substring 1))
- (forward-line 1))))
-
-(defsubst Man-build-references-alist ()
- "Build the association list of references (in the SEE ALSO section)."
- (setq Man-refpages-alist nil)
- (save-excursion
- (if (Man-find-section Man-see-also-regexp)
- (let ((start (progn (forward-line 1) (point)))
- (end (progn
- (Man-next-section 1)
- (point)))
- hyphenated
- (runningpoint -1))
- (save-restriction
- (narrow-to-region start end)
- (goto-char (point-min))
- (back-to-indentation)
- (while (and (not (eobp)) (/= (point) runningpoint))
- (setq runningpoint (point))
- (if (re-search-forward Man-hyphenated-reference-regexp end t)
- (let* ((word (Man-match-substring 0))
- (len (1- (length word))))
- (if hyphenated
- (setq word (concat hyphenated word)
- hyphenated nil
- ;; Update len, in case a reference spans
- ;; more than two lines (paranoia).
- len (1- (length word))))
- (if (= (aref word len) ?-)
- (setq hyphenated (substring word 0 len)))
- (if (string-match Man-reference-regexp word)
- (aput 'Man-refpages-alist word))))
- (skip-chars-forward " \t\n,"))))))
- (setq Man-refpages-alist (nreverse Man-refpages-alist)))
-
-(defun Man-build-page-list ()
- "Build the list of separate manpages in the buffer."
- (setq Man-page-list nil)
- (let ((page-start (point-min))
- (page-end (point-max))
- (header ""))
- (goto-char page-start)
- ;; (switch-to-buffer (current-buffer))(debug)
- (while (not (eobp))
- (setq header
- (if (looking-at Man-page-header-regexp)
- (Man-match-substring 1)
- nil))
- ;; Go past both the current and the next Man-first-heading-regexp
- (if (re-search-forward Man-first-heading-regexp nil 'move 2)
- (let ((p (progn (beginning-of-line) (point))))
- ;; We assume that the page header is delimited by blank
- ;; lines and that it contains at most one blank line. So
- ;; if we back by three blank lines we will be sure to be
- ;; before the page header but not before the possible
- ;; previous page header.
- (search-backward "\n\n" nil t 3)
- (if (re-search-forward Man-page-header-regexp p 'move)
- (beginning-of-line))))
- (setq page-end (point))
- (setq Man-page-list (append Man-page-list
- (list (list (copy-marker page-start)
- (copy-marker page-end)
- header))))
- (setq page-start page-end)
- )))
-
-(defun Man-strip-page-headers ()
- "Strip all the page headers but the first from the manpage."
- (let ((buffer-read-only nil)
- (case-fold-search nil)
- (page-list Man-page-list)
- (page ())
- (header ""))
- (while page-list
- (setq page (car page-list))
- (and (nth 2 page)
- (goto-char (car page))
- (re-search-forward Man-first-heading-regexp nil t)
- (setq header (buffer-substring (car page) (match-beginning 0)))
- ;; Since the awk script collapses all successive blank
- ;; lines into one, and since we don't want to get rid of
- ;; the fast awk script, one must choose between adding
- ;; spare blank lines between pages when there were none and
- ;; deleting blank lines at page boundaries when there were
- ;; some. We choose the first, so we comment the following
- ;; line.
- ;; (setq header (concat "\n" header)))
- (while (search-forward header (nth 1 page) t)
- (replace-match "")))
- (setq page-list (cdr page-list)))))
-
-(defun Man-unindent ()
- "Delete the leading spaces that indent the manpage."
- (let ((buffer-read-only nil)
- (case-fold-search nil)
- (page-list Man-page-list))
- (while page-list
- (let ((page (car page-list))
- (indent "")
- (nindent 0))
- (narrow-to-region (car page) (car (cdr page)))
- (if Man-uses-untabify-flag
- (untabify (point-min) (point-max)))
- (if (catch 'unindent
- (goto-char (point-min))
- (if (not (re-search-forward Man-first-heading-regexp nil t))
- (throw 'unindent nil))
- (beginning-of-line)
- (setq indent (buffer-substring (point)
- (progn
- (skip-chars-forward " ")
- (point))))
- (setq nindent (length indent))
- (if (zerop nindent)
- (throw 'unindent nil))
- (setq indent (concat indent "\\|$"))
- (goto-char (point-min))
- (while (not (eobp))
- (if (looking-at indent)
- (forward-line 1)
- (throw 'unindent nil)))
- (goto-char (point-min)))
- (while (not (eobp))
- (or (eolp)
- (delete-char nindent))
- (forward-line 1)))
- (setq page-list (cdr page-list))
- ))))
-
-\f
-;; ======================================================================
-;; Man mode commands
-
-(defun Man-next-section (n)
- "Move point to Nth next section (default 1)."
- (interactive "p")
- (let ((case-fold-search nil))
- (if (looking-at Man-heading-regexp)
- (forward-line 1))
- (if (re-search-forward Man-heading-regexp (point-max) t n)
- (beginning-of-line)
- (goto-char (point-max)))))
-
-(defun Man-previous-section (n)
- "Move point to Nth previous section (default 1)."
- (interactive "p")
- (let ((case-fold-search nil))
- (if (looking-at Man-heading-regexp)
- (forward-line -1))
- (if (re-search-backward Man-heading-regexp (point-min) t n)
- (beginning-of-line)
- (goto-char (point-min)))))
-
-(defun Man-find-section (section)
- "Move point to SECTION if it exists, otherwise don't move point.
-Returns t if section is found, nil otherwise."
- (let ((curpos (point))
- (case-fold-search nil))
- (goto-char (point-min))
- (if (re-search-forward (concat "^" section) (point-max) t)
- (progn (beginning-of-line) t)
- (goto-char curpos)
- nil)
- ))
-
-(defun Man-goto-section ()
- "Query for section to move point to."
- (interactive)
- (aput 'Man-sections-alist
- (let* ((default (aheadsym Man-sections-alist))
- (completion-ignore-case t)
- chosen
- (prompt (concat "Go to section: (default " default ") ")))
- (setq chosen (completing-read prompt Man-sections-alist))
- (if (or (not chosen)
- (string= chosen ""))
- default
- chosen)))
- (Man-find-section (aheadsym Man-sections-alist)))
-
-(defun Man-goto-see-also-section ()
- "Move point the the \"SEE ALSO\" section.
-Actually the section moved to is described by `Man-see-also-regexp'."
- (interactive)
- (if (not (Man-find-section Man-see-also-regexp))
- (error (concat "No " Man-see-also-regexp
- " section found in the current manpage"))))
-
-(defun Man-possibly-hyphenated-word ()
- "Return a possibly hyphenated word at point.
-If the word starts at the first non-whitespace column, and the
-previous line ends with a hyphen, return the last word on the previous
-line instead. Thus, if a reference to \"tcgetpgrp(3V)\" is hyphenated
-as \"tcgetp-grp(3V)\", and point is at \"grp(3V)\", we return
-\"tcgetp-\" instead of \"grp\"."
- (save-excursion
- (skip-syntax-backward "w()")
- (skip-chars-forward " \t")
- (let ((beg (point))
- (word (current-word)))
- (when (eq beg (save-excursion
- (back-to-indentation)
- (point)))
- (end-of-line 0)
- (if (eq (char-before) ?-)
- (setq word (current-word))))
- word)))
-
-(defun Man-follow-manual-reference (reference)
- "Get one of the manpages referred to in the \"SEE ALSO\" section.
-Specify which REFERENCE to use; default is based on word at point."
- (interactive
- (if (not Man-refpages-alist)
- (error "There are no references in the current man page")
- (list (let* ((default (or
- (car (all-completions
- (let ((word (Man-possibly-hyphenated-word)))
- ;; strip a trailing '-':
- (if (string-match "-$" word)
- (substring word 0
- (match-beginning 0))
- word))
- Man-refpages-alist))
- (aheadsym Man-refpages-alist)))
- chosen
- (prompt (concat "Refer to: (default " default ") ")))
- (setq chosen (completing-read prompt Man-refpages-alist nil t))
- (if (or (not chosen)
- (string= chosen ""))
- default
- chosen)))))
- (if (not Man-refpages-alist)
- (error "Can't find any references in the current manpage")
- (aput 'Man-refpages-alist reference)
- (Man-getpage-in-background
- (Man-translate-references (aheadsym Man-refpages-alist)))))
-
-(defun Man-kill ()
- "Kill the buffer containing the manpage."
- (interactive)
- (quit-window t))
-
-(defun Man-quit ()
- "Bury the buffer containing the manpage."
- (interactive)
- (quit-window))
-
-(defun Man-goto-page (page)
- "Go to the manual page on page PAGE."
- (interactive
- (if (not Man-page-list)
- (let ((args Man-arguments))
- (kill-buffer (current-buffer))
- (error "Can't find the %s manpage" args))
- (if (= (length Man-page-list) 1)
- (error "You're looking at the only manpage in the buffer")
- (list (read-minibuffer (format "Go to manpage [1-%d]: "
- (length Man-page-list)))))))
- (if (not Man-page-list)
- (let ((args Man-arguments))
- (kill-buffer (current-buffer))
- (error "Can't find the %s manpage" args)))
- (if (or (< page 1)
- (> page (length Man-page-list)))
- (error "No manpage %d found" page))
- (let* ((page-range (nth (1- page) Man-page-list))
- (page-start (car page-range))
- (page-end (car (cdr page-range))))
- (setq Man-current-page page
- Man-page-mode-string (Man-make-page-mode-string))
- (widen)
- (goto-char page-start)
- (narrow-to-region page-start page-end)
- (Man-build-section-alist)
- (Man-build-references-alist)
- (goto-char (point-min))))
-
-
-(defun Man-next-manpage ()
- "Find the next manpage entry in the buffer."
- (interactive)
- (if (= (length Man-page-list) 1)
- (error "This is the only manpage in the buffer"))
- (if (< Man-current-page (length Man-page-list))
- (Man-goto-page (1+ Man-current-page))
- (if Man-circular-pages-flag
- (Man-goto-page 1)
- (error "You're looking at the last manpage in the buffer"))))
-
-(defun Man-previous-manpage ()
- "Find the previous manpage entry in the buffer."
- (interactive)
- (if (= (length Man-page-list) 1)
- (error "This is the only manpage in the buffer"))
- (if (> Man-current-page 1)
- (Man-goto-page (1- Man-current-page))
- (if Man-circular-pages-flag
- (Man-goto-page (length Man-page-list))
- (error "You're looking at the first manpage in the buffer"))))
-\f
-;; Init the man package variables, if not already done.
-(Man-init-defvars)
-
-(add-to-list 'debug-ignored-errors "^No manpage [0-9]* found$")
-(add-to-list 'debug-ignored-errors "^Can't find the .* manpage$")
-
-(provide 'man)
-
-;;; man.el ends here
+++ /dev/null
-;;; medit.el --- front-end to the MEDIT package for editing MDL
-
-;; Copyright (C) 1985 Free Software Foundation, Inc.
-
-;; Author: K. Shane Hartman
-;; Maintainer: FSF
-;; Keywords: languages
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to
-;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;;; Commentary:
-
-;; >> This package depends on two MDL packages: MEDIT and FORKS which
-;; >> can be obtained from the public (network) library at mit-ajax.
-
-;;; Code:
-
-(require 'mim-mode)
-
-(defconst medit-zap-file (concat "/tmp/" (user-login-name) ".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.")
-(defconst medit-save-files t
- "If non-nil, Medit offers to save files on return to MDL.")
-
-(defun medit-save-define ()
- "Mark the previous or surrounding toplevel object to be sent back to MDL."
- (interactive)
- (save-excursion
- (beginning-of-DEFINE)
- (let ((start (point)))
- (forward-mim-object 1)
- (append-to-buffer medit-buffer start (point))
- (goto-char start)
- (message "%s" (buffer-substring start (progn (end-of-line) (point)))))))
-
-(defun medit-save-region (start end)
- "Mark the current region to be sent to back to MDL."
- (interactive "r")
- (append-to-buffer medit-buffer start end)
- (message "Current region saved for MDL."))
-
-(defun medit-save-buffer ()
- "Mark the current buffer to be sent back to MDL."
- (interactive)
- (append-to-buffer medit-buffer (point-min) (point-max))
- (message "Current buffer saved for MDL."))
-
-(defun medit-zap-define-to-mdl ()
- "Return to MDL with surrounding or previous toplevel MDL object."
- (interactive)
- (medit-save-define)
- (medit-goto-mdl))
-
-(defun medit-zap-region-mdl (start end)
- "Return to MDL with current region."
- (interactive)
- (medit-save-region start end)
- (medit-goto-mdl))
-
-(defun medit-zap-buffer ()
- "Return to MDL with current buffer."
- (interactive)
- (medit-save-buffer)
- (medit-goto-mdl))
-
-(defun medit-goto-mdl ()
- "Return from Emacs to superior MDL, sending saved code.
-Optionally, offers to save changed files."
- (interactive)
- (let ((buffer (get-buffer medit-buffer)))
- (if buffer
- (save-excursion
- (set-buffer buffer)
- (if (buffer-modified-p buffer)
- (write-region (point-min) (point-max) medit-zap-file))
- (set-buffer-modified-p nil)
- (erase-buffer)))
- (if medit-save-files (save-some-buffers))
- ;; Note could handle parallel fork by giving argument "%xmdl". Then
- ;; mdl would have to invoke with "%emacs".
- (suspend-emacs)))
-
-(defconst medit-mode-map nil)
-(if (not medit-mode-map)
- (progn
- (setq medit-mode-map (copy-keymap 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)
- (define-key medit-mode-map "\^xs" 'medit-zap-buffer)))
-
-(defconst medit-mode-hook (and (boundp 'mim-mode-hook) mim-mode-hook) "")
-(setq mim-mode-hook '(lambda () (medit-mode)))
-
-(defun medit-mode (&optional state)
- "Major mode for editing text and returning it to a superior MDL.
-Like Mim mode, plus these special commands:
-\\{medit-mode-map}"
- (interactive)
- (use-local-map medit-mode-map)
- (run-hooks 'medit-mode-hook)
- (setq major-mode 'medit-mode)
- (setq mode-name "Medit"))
-
-(mim-mode)
-
-;;; medit.el ends here
+++ /dev/null
-;;; mh-e.el --- GNU Emacs interface to the MH mail system
-
-;;; Copyright (C) 1985, 86, 87, 88, 90, 92, 93 Free Software Foundation
-
-(defconst mh-e-time-stamp "Time-stamp: <93/05/30 18:37:43 gildea>")
-
-;; Maintainer: Stephen Gildea <gildea@lcs.mit.edu>
-;; Version: 3.8.2
-;; Keywords: mail
-
-;; 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.
-
-;;; Commentary:
-
-;;; mh-e works with Emacs 18 or 19, and MH 5 or 6.
-
-;;; 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-cr" 'mh-rmail)
-
-;;; MH (Message Handler) is a powerful mail reader. The MH newsgroup
-;;; is comp.mail.mh; the mailing list is mh-users@ics.uci.edu (send to
-;;; mh-users-request to be added). See the monthly Frequently Asked
-;;; Questions posting there for information on getting MH.
-
-;;; 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.
-
-;;; 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 1988. gildea@bbn.com
-(defconst mh-e-RCS-id "$Header: /home/fsf/rms/e19/lisp/RCS/mh-e.el,v 1.15 1993/07/20 04:35:00 rms Exp rms $")
-
-;;; Code:
-
-\f
-
-;;; 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 t))
- (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.")
-
-(defvar mh-signature-file-name "~/.signature"
- "*Name of file containing the user's signature.
-Inserted into message by \\<mh-letter-mode-map>\\[mh-insert-signature].")
-
-
-;;; 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 specifying 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-searching-folder nil
- "Folder this pick is searching.")
-
-(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))))
-
-\f
-
-;;; 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))
-
-\f
-
-;;; 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))
-
-\f
-
-;;; 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 t)))))
-
-
-(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)))
-
-\f
-
-;;; The folder data abstraction.
-
-(defvar mh-current-folder nil "Name of current folder, a string.")
-(defvar mh-show-buffer nil "Buffer that displays message 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))
-
-\f
-
-;;; 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.
-
- mh-signature-file-name (\"~/.signature\")
- File to be inserted into message by \\[mh-insert-signature].
-
-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 (and (boundp 'auto-fill-hook) auto-fill-hook) ;emacs 18
- (make-local-variable 'auto-fill-hook)
- (setq auto-fill-hook 'mh-auto-fill-for-letter))
- (mh-when (and (boundp 'auto-fill-function) auto-fill-function) ;emacs 19
- (make-local-variable 'auto-fill-function)
- (setq auto-fill-function '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 (point-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 (point-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 named by mh-signature-file-name at the current point."
- (interactive)
- (insert-file-contents mh-signature-file-name)
- (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")))
-
-\f
-
-;;; 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 msgs
- (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))))
-
-\f
-
-;;; 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-active
- (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)))))
-
-\f
-
-;;; 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)))
-
-\f
-
-;;; 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)))
-
-\f
-
-;;; 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)))))
-
-\f
-
-;;; 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)))
-
-\f
-
-;;; 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)))
-
-\f
-
-;;; 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 "\en" 'mh-unshar-msg)
-(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)
-
-\f
-
-;;; For Gnu Emacs.
-;;; Local Variables: ***
-;;; eval: (put 'mh-when 'lisp-indent-hook 1) ***
-;;; eval: (put 'with-mh-folder-updating 'lisp-indent-hook 1) ***
-;;; End: ***
-
-(provide 'mh-e)
-
-;;; mh-e.el ends here
+++ /dev/null
-;;; mhspool.el --- MH folder access using NNTP for GNU Emacs
-
-;; Copyright (C) 1988, 1989, 1990, 1993 Free Software Foundation, Inc.
-
-;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
-;; Maintainer: FSF
-;; Keywords: mail, news
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to
-;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;;; Commentary:
-
-;; 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'.
-
-;;; Code:
-
-(require 'nntp)
-
-(defvar mhspool-list-folders-method
- (function mhspool-list-folders-using-sh)
- "*Function to list files in folders.
-The function should accept a directory as its argument, and fill the
-current buffer with file and directory names. The output format must
-be the same as that of 'ls -R1'. Two functions
-mhspool-list-folders-using-ls and mhspool-list-folders-using-sh are
-provided now. I suppose the later is faster.")
-
-(defvar mhspool-list-directory-switches '("-R")
- "*Switches for mhspool-list-folders-using-ls to pass to `ls' for getting file lists.
-One entry should appear on one line. You may need to add `-1' option.")
-
-\f
-
-(defconst mhspool-version "MHSPOOL 1.8"
- "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] ...)'.
-If there is no References: field, In-Reply-To: field is used instead.
-Reader macros for the vector are defined as `nntp-header-FIELD'.
-Writer macros for the vector are defined as `nntp-set-header-FIELD'.
-Newsgroup must be selected before calling this."
- (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)))))
- ;; Count lines since there is no lines field in most cases.
- (setq lines
- (save-restriction
- (goto-char (point-max))
- (widen)
- (count-lines (point) (point-max)))))
- ;; 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))
- ;; Collect valid article only.
- (and article
- message-id
- (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: Receiving headers... %d%%"
- (/ (* count 100) number)))
- )
- (and (numberp nntp-large-newsgroup)
- (> number nntp-large-newsgroup)
- (message "MHSPOOL: Receiving headers... done"))
- (nreverse headers)
- )))
-
-\f
-;;;
-;;; 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-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-string
- (format "No such directory: %s. Goodbye."
- mhspool-spool-directory)))
- ((null host)
- (setq nntp-status-string "NNTP server is not specified."))
- (t
- (setq nntp-status-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-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)."
- (setq nntp-status-string "MHSPOOL: STAT is not implemented.")
- nil
- )
-
-(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 active 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 " *MHSPOOL File List*")))
- (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)))
- (funcall mhspool-list-folders-method 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-list-newsgroups ()
- "List newsgoups (defined in NNTP2)."
- (setq nntp-status-string "MHSPOOL: LIST NEWSGROUPS is not implemented.")
- nil
- )
-
-(defun mhspool-request-list-distributions ()
- "List distributions (defined in NNTP2)."
- (setq nntp-status-string "MHSPOOL: LIST DISTRIBUTIONS is not implemented.")
- nil
- )
-
-(defun mhspool-request-last ()
- "Set current article pointer to the previous article
-in the current news group."
- (setq nntp-status-string "MHSPOOL: LAST is not implemented.")
- nil
- )
-
-(defun mhspool-request-next ()
- "Advance current article pointer."
- (setq nntp-status-string "MHSPOOL: NEXT is not implemented.")
- nil
- )
-
-(defun mhspool-request-post ()
- "Post a new news in current buffer."
- (setq nntp-status-string "MHSPOOL: POST: what do you mean?")
- nil
- )
-
-\f
-;;;
-;;; 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 occurrences of FROM with TO.
- (while (< idx len)
- (if (= (aref string idx) from)
- (aset string idx to))
- (setq idx (1+ idx)))
- string
- ))
-
-\f
-;; Methods for listing files in folders.
-
-(defun mhspool-list-folders-using-ls (directory)
- "List files in folders under DIRECTORY using 'ls'."
- (apply 'call-process
- "ls" nil t nil
- (append mhspool-list-directory-switches (list directory))))
-
-;; Basic ideas by tanaka@flab.fujitsu.co.jp (Hiroshi TANAKA)
-
-(defun mhspool-list-folders-using-sh (directory)
- "List files in folders under DIRECTORY using '/bin/sh'."
- (let ((buffer (current-buffer))
- (script (get-buffer-create " *MHSPOOL Shell Script Buffer*")))
- (save-excursion
- (save-restriction
- (set-buffer script)
- (erase-buffer)
- ;; /bin/sh script which does 'ls -R'.
- (insert
- "PS2=
- ffind() {
- cd $1; echo $1:
- ls -1
- echo
- for j in `echo *[a-zA-Z]*`
- do
- if [ -d $1/$j ]; then
- ffind $1/$j
- fi
- done
- }
- cd " directory "; ffind `pwd`; exit 0\n")
- (call-process-region (point-min) (point-max) "sh" nil buffer nil)
- ))
- (kill-buffer script)
- ))
-
-(provide 'mhspool)
-
-;;; mhspool.el ends here
+++ /dev/null
-;;; mim-mode.el --- Mim (MDL in MDL) mode.
-
-;; Copyright (C) 1985 Free Software Foundation, Inc.
-
-;; Author: K. Shane Hartman
-;; Maintainer: FSF
-;; Keywords: languages
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to
-;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;;; Code:
-
-(autoload 'fast-syntax-check-mim "mim-syntax"
- "Checks Mim syntax quickly.
-Answers correct or incorrect, cannot point out the error context."
- t)
-
-(autoload 'slow-syntax-check-mim "mim-syntax"
- "Check Mim syntax slowly.
-Points out the context of the error, if the syntax is incorrect."
- t)
-
-(defvar mim-mode-hysterical-bindings t
- "*Non-nil means bind list manipulation commands to Meta keys as well as
-Control-Meta keys for historical reasons. Otherwise, only the latter keys
-are bound.")
-
-(defvar mim-mode-map nil)
-
-(defvar mim-mode-syntax-table nil)
-
-(if mim-mode-syntax-table
- ()
- (let ((i -1))
- (setq mim-mode-syntax-table (make-syntax-table))
- (while (< i ?\ )
- (modify-syntax-entry (setq i (1+ i)) " " mim-mode-syntax-table))
- (while (< i 127)
- (modify-syntax-entry (setq i (1+ i)) "_ " mim-mode-syntax-table))
- (setq i (1- ?a))
- (while (< i ?z)
- (modify-syntax-entry (setq i (1+ i)) "w " mim-mode-syntax-table))
- (setq i (1- ?A))
- (while (< i ?Z)
- (modify-syntax-entry (setq i (1+ i)) "w " mim-mode-syntax-table))
- (setq i (1- ?0))
- (while (< i ?9)
- (modify-syntax-entry (setq i (1+ i)) "w " mim-mode-syntax-table))
- (modify-syntax-entry ?: " " mim-mode-syntax-table) ; make : symbol delimiter
- (modify-syntax-entry ?, "' " mim-mode-syntax-table)
- (modify-syntax-entry ?. "' " mim-mode-syntax-table)
- (modify-syntax-entry ?' "' " mim-mode-syntax-table)
- (modify-syntax-entry ?` "' " mim-mode-syntax-table)
- (modify-syntax-entry ?~ "' " mim-mode-syntax-table)
- (modify-syntax-entry ?\; "' " mim-mode-syntax-table) ; comments are prefixed objects
- (modify-syntax-entry ?# "' " mim-mode-syntax-table)
- (modify-syntax-entry ?% "' " mim-mode-syntax-table)
- (modify-syntax-entry ?! "' " mim-mode-syntax-table)
- (modify-syntax-entry ?\" "\" " mim-mode-syntax-table)
- (modify-syntax-entry ?\\ "\\ " mim-mode-syntax-table)
- (modify-syntax-entry ?\( "\() " mim-mode-syntax-table)
- (modify-syntax-entry ?\< "\(> " mim-mode-syntax-table)
- (modify-syntax-entry ?\{ "\(} " mim-mode-syntax-table)
- (modify-syntax-entry ?\[ "\(] " mim-mode-syntax-table)
- (modify-syntax-entry ?\) "\)( " mim-mode-syntax-table)
- (modify-syntax-entry ?\> "\)< " mim-mode-syntax-table)
- (modify-syntax-entry ?\} "\){ " mim-mode-syntax-table)
- (modify-syntax-entry ?\] "\)[ " mim-mode-syntax-table)))
-
-(defconst mim-whitespace "\000- ")
-
-(defvar mim-mode-hook nil
- "*User function run after mim mode initialization. Usage:
-\(setq mim-mode-hook '(lambda () ... your init forms ...)).")
-
-(define-abbrev-table 'mim-mode-abbrev-table nil)
-
-(defconst indent-mim-function 'indent-mim-function
- "Controls (via properties) indenting of special forms.
-\(put 'FOO 'indent-mim-function 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
-value of mim-body-indent as offset from start of form.
-\(put 'FOO 'indent-mim-function <cons>\) where <cons> is a list or pointed 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\)\)
-<FROBIT
- <CHOMP-IT>
- <CHOMP-SOME-MORE>
- <DIGEST>
- <BELCH>
- ...>
-Finally, the property can be a function name (read the code).")
-
-(defvar indent-mim-comment t
- "*Non-nil means indent string comments.")
-
-(defvar mim-body-indent 2
- "*Amount to indent in special forms which have DEFINE property on
-`indent-mim-function'.")
-
-(defvar indent-mim-arglist t
- "*nil means indent arglists like ordinary lists.
-t means strings stack under start of arglist and variables stack to
-right of them. Otherwise, strings stack under last string (or start
-of arglist if none) and variables stack to right of them.
-Examples (for values 'stack, t, nil):
-
-\(FOO \"OPT\" BAR \(FOO \"OPT\" BAR \(FOO \"OPT\" BAR
- BAZ MUMBLE BAZ MUMBLE BAZ MUMBLE
- \"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))
-
-(defvar mim-down-parens-only t
- "*nil means treat ADECLs and ATOM trailers like structures when
-moving down a level of structure.")
-
-(defvar mim-stop-for-slop t
- "*Non-nil means {next previous}-mim-object consider any
-non-whitespace character in column 0 to be a toplevel object, otherwise
-only open paren syntax characters will be considered.")
-
-(defalias 'mdl-mode 'mim-mode)
-
-(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).
-The default action is bind the escape keys.
-\\{mim-mode-map}
-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-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."
- (interactive)
- (kill-all-local-variables)
- (if (not mim-mode-map)
- (progn
- (setq mim-mode-map (make-sparse-keymap))
- (define-key mim-mode-map "\e\^o" 'open-mim-line)
- (define-key mim-mode-map "\e\^q" 'indent-mim-object)
- (define-key mim-mode-map "\e\^p" 'previous-mim-object)
- (define-key mim-mode-map "\e\^n" 'next-mim-object)
- (define-key mim-mode-map "\e\^a" 'beginning-of-DEFINE)
- (define-key mim-mode-map "\e\^e" 'end-of-DEFINE)
- (define-key mim-mode-map "\e\^t" 'transpose-mim-objects)
- (define-key mim-mode-map "\e\^u" 'backward-up-mim-object)
- (define-key mim-mode-map "\e\^d" 'forward-down-mim-object)
- (define-key mim-mode-map "\e\^h" 'mark-mim-object)
- (define-key mim-mode-map "\e\^k" 'forward-kill-mim-object)
- (define-key mim-mode-map "\e\^f" 'forward-mim-object)
- (define-key mim-mode-map "\e\^b" 'backward-mim-object)
- (define-key mim-mode-map "\e^" 'raise-mim-line)
- (define-key mim-mode-map "\e\\" 'fixup-whitespace)
- (define-key mim-mode-map "\177" 'backward-delete-char-untabify)
- (define-key mim-mode-map "\e\177" 'backward-kill-mim-object)
- (define-key mim-mode-map "\^j" 'newline-and-mim-indent)
- (define-key mim-mode-map "\e;" 'begin-mim-comment)
- (define-key mim-mode-map "\t" 'indent-mim-line)
- (define-key mim-mode-map "\e\t" 'indent-mim-object)
- (if (not mim-mode-hysterical-bindings)
- nil
- ;; i really hate this but too many people are accustomed to these.
- (define-key mim-mode-map "\e!" 'line-to-top-of-window)
- (define-key mim-mode-map "\eo" 'open-mim-line)
- (define-key mim-mode-map "\ep" 'previous-mim-object)
- (define-key mim-mode-map "\en" 'next-mim-object)
- (define-key mim-mode-map "\ea" 'beginning-of-DEFINE)
- (define-key mim-mode-map "\ee" 'end-of-DEFINE)
- (define-key mim-mode-map "\et" 'transpose-mim-objects)
- (define-key mim-mode-map "\eu" 'backward-up-mim-object)
- (define-key mim-mode-map "\ed" 'forward-down-mim-object)
- (define-key mim-mode-map "\ek" 'forward-kill-mim-object)
- (define-key mim-mode-map "\ef" 'forward-mim-object)
- (define-key mim-mode-map "\eb" 'backward-mim-object))))
- (use-local-map mim-mode-map)
- (set-syntax-table mim-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)
- ;; Most people use string comments.
- (make-local-variable 'comment-start)
- (setq comment-start ";\"")
- (make-local-variable 'comment-start-skip)
- (setq comment-start-skip ";\"")
- (make-local-variable 'comment-end)
- (setq comment-end "\"")
- (make-local-variable 'comment-column)
- (setq comment-column 40)
- (make-local-variable 'comment-indent-function)
- (setq comment-indent-function 'indent-mim-comment)
- ;; tell generic indenter how to indent.
- (make-local-variable 'indent-line-function)
- (setq indent-line-function 'indent-mim-line)
- ;; look for that paren
- (make-local-variable 'blink-matching-paren-distance)
- (setq blink-matching-paren-distance nil)
- ;; so people who dont like tabs can turn them off locally in indenter.
- (make-local-variable 'indent-tabs-mode)
- (setq indent-tabs-mode t)
- (setq local-abbrev-table mim-mode-abbrev-table)
- (setq major-mode 'mim-mode)
- (setq mode-name "Mim")
- (run-hooks 'mim-mode-hook))
-
-(defun line-to-top-of-window ()
- "Move current line to top of window."
- (interactive) ; for lazy people
- (recenter 0))
-
-(defun forward-mim-object (arg)
- "Move forward across Mim object.
-With ARG, move forward that many objects."
- (interactive "p")
- ;; this function is weird because it emulates the behavior of the old
- ;; (gosling) mim-mode - if the arg is 1 and we are `inside' an ADECL,
- ;; more than one character into the ATOM part and not sitting on the
- ;; colon, then we move to the DECL part (just past colon) instead of
- ;; the end of the object (the entire ADECL). otherwise, ADECL's are
- ;; atomic objects. likewise for ATOM trailers.
- (if (= (abs arg) 1)
- (if (inside-atom-p)
- ;; Move to end of ATOM or to trailer (!) or to ADECL (:).
- (forward-sexp arg)
- ;; Either scan an sexp or move over one bracket.
- (forward-mim-objects arg t))
- ;; in the multi-object case, don't perform any magic.
- ;; treats ATOM trailers and ADECLs atomically, stops at unmatched
- ;; brackets with error.
- (forward-mim-objects arg)))
-
-(defun inside-atom-p ()
- ;; Returns t iff inside an atom (takes account of trailers)
- (let ((c1 (preceding-char))
- (c2 (following-char)))
- (and (or (= (char-syntax c1) ?w) (= (char-syntax c1) ?_) (= c1 ?!))
- (or (= (char-syntax c2) ?w) (= (char-syntax c2) ?_) (= c2 ?!)))))
-
-(defun forward-mim-objects (arg &optional skip-bracket-p)
- ;; Move over arg objects ignoring ADECLs and trailers. If
- ;; skip-bracket-p is non-nil, then move over one bracket on error.
- (let ((direction (sign arg)))
- (condition-case conditions
- (while (/= arg 0)
- (forward-sexp direction)
- (if (not (inside-adecl-or-trailer-p direction))
- (setq arg (- arg direction))))
- (error (if (not skip-bracket-p)
- (signal 'error (cdr conditions))
- (skip-mim-whitespace direction)
- (goto-char (+ (point) direction)))))
- ;; If we moved too far move back to first interesting character.
- (if (= (point) (buffer-end direction)) (skip-mim-whitespace (- direction)))))
-
-(defun backward-mim-object (&optional arg)
- "Move backward across Mim object.
-With ARG, move backward that many objects."
- (interactive "p")
- (forward-mim-object (if arg (- arg) -1)))
-
-(defun mark-mim-object (&optional arg)
- "Mark following Mim object.
-With ARG, mark that many following (preceding, ARG < 0) objects."
- (interactive "p")
- (push-mark (save-excursion (forward-mim-object (or arg 1)) (point))))
-
-(defun forward-kill-mim-object (&optional arg)
- "Kill following Mim object.
-With ARG, kill that many objects."
- (interactive "*p")
- (kill-region (point) (progn (forward-mim-object (or arg 1)) (point))))
-
-(defun backward-kill-mim-object (&optional arg)
- "Kill preceding Mim object.
-With ARG, kill that many objects."
- (interactive "*p")
- (forward-kill-mim-object (- (or arg 1))))
-
-(defun raise-mim-line (&optional arg)
- "Raise following line, fixing up whitespace at join.
-With ARG raise that many following lines.
-A negative ARG will raise current line and previous lines."
- (interactive "*p")
- (let* ((increment (sign (or arg (setq arg 1))))
- (direction (if (> arg 0) 1 0)))
- (save-excursion
- (while (/= arg 0)
- ;; move over eol and kill it
- (forward-line direction)
- (delete-region (point) (1- (point)))
- (fixup-whitespace)
- (setq arg (- arg increment))))))
-
-(defun forward-down-mim-object (&optional arg)
- "Move down a level of Mim structure forwards.
-With ARG, move down that many levels forwards (backwards, ARG < 0)."
- (interactive "p")
- ;; another weirdo - going down `inside' an ADECL or ATOM trailer
- ;; depends on the value of mim-down-parens-only. if nil, treat
- ;; ADECLs and trailers as structured objects.
- (let ((direction (sign (or arg (setq arg 1)))))
- (if (and (= (abs arg) 1) (not mim-down-parens-only))
- (goto-char
- (save-excursion
- (skip-mim-whitespace direction)
- (if (> direction 0) (re-search-forward "\\s'*"))
- (or (and (let ((c (next-char direction)))
- (or (= (char-syntax c) ?_)
- (= (char-syntax c) ?w)))
- (progn (forward-sexp direction)
- (if (inside-adecl-or-trailer-p direction)
- (point))))
- (scan-lists (point) direction -1)
- (buffer-end direction))))
- (while (/= arg 0)
- (goto-char (or (scan-lists (point) direction -1) (buffer-end direction)))
- (setq arg (- arg direction))))))
-
-(defun backward-down-mim-object (&optional arg)
- "Move down a level of Mim structure backwards.
-With ARG, move down that many levels backwards (forwards, ARG < 0)."
- (interactive "p")
- (forward-down-mim-object (if arg (- arg) -1)))
-
-(defun forward-up-mim-object (&optional arg)
- "Move up a level of Mim structure forwards
-With ARG, move up that many levels forwards (backwards, ARG < 0)."
- (interactive "p")
- (let ((direction (sign (or arg (setq arg 1)))))
- (while (/= arg 0)
- (goto-char (or (scan-lists (point) direction 1) (buffer-end arg)))
- (setq arg (- arg direction)))
- (if (< direction 0) (backward-prefix-chars))))
-
-(defun backward-up-mim-object (&optional arg)
- "Move up a level of Mim structure backwards
-With ARG, move up that many levels backwards (forwards, ARG > 0)."
- (interactive "p")
- (forward-up-mim-object (if arg (- arg) -1)))
-
-(defun replace-in-mim-object (old new)
- "Replace string in following Mim object."
- (interactive "*sReplace in object: \nsReplace %s with: ")
- (save-restriction
- (narrow-to-region (point) (save-excursion (forward-mim-object 1) (point)))
- (replace-string old new)))
-
-(defun transpose-mim-objects (&optional arg)
- "Transpose Mim objects around point.
-With ARG, transpose preceding object that many times with following objects.
-A negative ARG will transpose backwards."
- (interactive "*p")
- (transpose-subr 'forward-mim-object (or arg 1)))
-
-(defun beginning-of-DEFINE (&optional arg move)
- "Move backward to beginning of surrounding or previous toplevel Mim form.
-With ARG, do it that many times. Stops at last toplevel form seen if buffer
-end is reached."
- (interactive "p")
- (let ((direction (sign (or arg (setq arg 1)))))
- (if (not move) (setq move t))
- (if (< direction 0) (goto-char (1+ (point))))
- (while (and (/= arg 0) (re-search-backward "^<" nil move direction))
- (setq arg (- arg direction)))
- (if (< direction 0)
- (goto-char (1- (point))))))
-
-(defun end-of-DEFINE (&optional arg)
- "Move forward to end of surrounding or next toplevel mim form.
-With ARG, do it that many times. Stops at end of last toplevel form seen
-if buffer end is reached."
- (interactive "p")
- (if (not arg) (setq arg 1))
- (if (< arg 0)
- (beginning-of-DEFINE (- (1- arg)))
- (if (not (looking-at "^<")) (setq arg (1+ arg)))
- (beginning-of-DEFINE (- arg) 'move)
- (beginning-of-DEFINE 1))
- (forward-mim-object 1)
- (forward-line 1))
-
-(defun next-mim-object (&optional arg)
- "Move to beginning of next toplevel Mim object.
-With ARG, do it that many times. Stops at last object seen if buffer end
-is reached."
- (interactive "p")
- (let ((search-string (if mim-stop-for-slop "^\\S " "^\\s("))
- (direction (sign (or arg (setq arg 1)))))
- (if (> direction 0)
- (goto-char (1+ (point)))) ; no error if end of buffer
- (while (and (/= arg 0)
- (re-search-forward search-string nil t direction))
- (setq arg (- arg direction)))
- (if (> direction 0)
- (goto-char (1- (point)))) ; no error if beginning of buffer
- ;; scroll to top of window if moving forward and end not visible.
- (if (not (or (< direction 0)
- (save-excursion (forward-mim-object 1)
- (pos-visible-in-window-p (point)))))
- (recenter 0))))
-
-(defun previous-mim-object (&optional arg)
- "Move to beginning of previous toplevel Mim object.
-With ARG do it that many times. Stops at last object seen if buffer end
-is reached."
- (interactive "p")
- (next-mim-object (- (or arg 1))))
-
-(defun calculate-mim-indent (&optional parse-start)
- "Calculate indentation for Mim line. Returns column."
- (save-excursion ; some excursion, huh, toto?
- (beginning-of-line)
- (let ((indent-point (point)) retry state containing-sexp last-sexp
- desired-indent start peek where paren-depth)
- (if parse-start
- (goto-char parse-start) ; should be containing environment
- (catch 'from-the-top
- ;; find a place to start parsing. going backwards is fastest.
- ;; forward-sexp signals error on encountering unmatched open.
- (setq retry t)
- (while retry
- (condition-case nil (forward-sexp -1) (error (setq retry nil)))
- (if (looking-at ".?[ \t]*\"")
- ;; cant parse backward in presence of strings, go forward.
- (progn
- (goto-char indent-point)
- (re-search-backward "^\\s(" nil 'move 1) ; to top of object
- (throw 'from-the-top nil)))
- (setq retry (and retry (/= (current-column) 0))))
- (skip-chars-backward mim-whitespace)
- (if (not (bobp)) (forward-char -1)) ; onto unclosed open
- (backward-prefix-chars)))
- ;; find outermost containing sexp if we started inside an sexp.
- (while (< (point) indent-point)
- (setq state (parse-partial-sexp (point) indent-point 0)))
- ;; find usual column to indent under (not in string or toplevel).
- ;; on termination, state will correspond to containing environment
- ;; (if retry is nil), where will be position of character to indent
- ;; under normally, and desired-indent will be the column to indent to
- ;; except if inside form, string, or at toplevel. point will be in
- ;; in column to indent to unless inside string.
- (setq retry t)
- (while (and retry (setq paren-depth (car state)) (> paren-depth 0))
- ;; find innermost containing sexp.
- (setq retry nil)
- (setq last-sexp (car (nthcdr 2 state)))
- (setq containing-sexp (car (cdr state)))
- (goto-char (1+ containing-sexp)) ; to last unclosed open
- (if (and last-sexp (> last-sexp (point)))
- ;; is the last sexp a containing sexp?
- (progn (setq peek (parse-partial-sexp last-sexp indent-point 0))
- (if (setq retry (car (cdr peek))) (setq state peek))))
- (if retry
- nil
- (setq where (1+ containing-sexp)) ; innermost containing sexp
- (goto-char where)
- (cond
- ((not last-sexp) ; indent-point after bracket
- (setq desired-indent (current-column)))
- ((= (preceding-char) ?\<) ; it's a form
- (cond ((> (progn (forward-sexp 1) (point)) last-sexp)
- (goto-char where)) ; only one frob
- ((> (save-excursion (forward-line 1) (point)) last-sexp)
- (skip-chars-forward " \t") ; last-sexp is on same line
- (setq where (point))) ; as containing-sexp
- ((progn
- (goto-char last-sexp)
- (beginning-of-line)
- (parse-partial-sexp (point) last-sexp 0 t)
- (or (= (point) last-sexp)
- (save-excursion
- (= (car (parse-partial-sexp (point) last-sexp 0))
- 0))))
- (backward-prefix-chars) ; last-sexp 1st on line or 1st
- (setq where (point))) ; frob on that line level 0
- (t (goto-char where)))) ; punt, should never occur
- ((and indent-mim-arglist ; maybe hack arglist
- (= (preceding-char) ?\() ; its a list
- (save-excursion ; look for magic atoms
- (setq peek 0) ; using peek as counter
- (forward-char -1) ; back over containing paren
- (while (and (< (setq peek (1+ peek)) 6)
- (condition-case nil
- (progn (forward-sexp -1) t)
- (error nil))))
- (and (< peek 6) (looking-at "DEFINE\\|DEFMAC\\|FUNCTION"))))
- ;; frobs stack under strings they belong to or under first
- ;; frob to right of strings they belong to unless luser has
- ;; frob (non-string) on preceding line with different
- ;; indentation. strings stack under start of arglist unless
- ;; mim-indent-arglist is not t, in which case they stack
- ;; under the last string, if any, else the start of the arglist.
- (let ((eol 0) last-string)
- (while (< (point) last-sexp) ; find out where the strings are
- (skip-chars-forward mim-whitespace last-sexp)
- (if (> (setq start (point)) eol)
- (progn ; simultaneously keeping track
- (setq where (min where start))
- (end-of-line) ; of indentation of first frob
- (setq eol (point)) ; on each line
- (goto-char start)))
- (if (= (following-char) ?\")
- (progn (setq last-string (point))
- (forward-sexp 1)
- (if (= last-string last-sexp)
- (setq where last-sexp)
- (skip-chars-forward mim-whitespace last-sexp)
- (setq where (point))))
- (forward-sexp 1)))
- (goto-char indent-point) ; if string is first on
- (skip-chars-forward " \t" (point-max)) ; line we are indenting, it
- (if (= (following-char) ?\") ; goes under arglist start
- (if (and last-string (not (equal indent-mim-arglist t)))
- (setq where last-string) ; or under last string.
- (setq where (1+ containing-sexp)))))
- (goto-char where)
- (setq desired-indent (current-column)))
- (t ; plain vanilla structure
- (cond ((> (save-excursion (forward-line 1) (point)) last-sexp)
- (skip-chars-forward " \t") ; last-sexp is on same line
- (setq where (point))) ; as containing-sexp
- ((progn
- (goto-char last-sexp)
- (beginning-of-line)
- (parse-partial-sexp (point) last-sexp 0 t)
- (or (= (point) last-sexp)
- (save-excursion
- (= (car (parse-partial-sexp (point) last-sexp 0))
- 0))))
- (backward-prefix-chars) ; last-sexp 1st on line or 1st
- (setq where (point))) ; frob on that line level 0
- (t (goto-char where))) ; punt, should never occur
- (setq desired-indent (current-column))))))
- ;; state is innermost containing environment unless toplevel or string.
- (if (car (nthcdr 3 state)) ; inside string
- (progn
- (if last-sexp ; string must be next
- (progn (goto-char last-sexp)
- (forward-sexp 1)
- (search-forward "\"")
- (forward-char -1))
- (goto-char indent-point) ; toplevel string, look for it
- (re-search-backward "[^\\]\"")
- (forward-char 1))
- (setq start (point)) ; opening double quote
- (skip-chars-backward " \t")
- (backward-prefix-chars)
- ;; see if the string is really a comment.
- (if (and (looking-at ";[ \t]*\"") indent-mim-comment)
- ;; it's a comment, line up under the start unless disabled.
- (goto-char (1+ start))
- ;; it's a string, dont mung the indentation.
- (goto-char indent-point)
- (skip-chars-forward " \t"))
- (setq desired-indent (current-column))))
- ;; point is sitting in usual column to indent to and if retry is nil
- ;; 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
- (not retry)
- (setq desired-indent
- (funcall indent-mim-function 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)
- "Compute indentation for Mim special forms. Returns column or nil."
- (let ((containing-sexp (car (cdr state))) (current-indent (point)))
- (save-excursion
- (goto-char (1+ containing-sexp))
- (backward-prefix-chars)
- ;; make sure we are looking at a symbol. if so, see if it is a special
- ;; symbol. if so, add the special indentation to the indentation of
- ;; the start of the special symbol, unless the property is not
- ;; an integer and not nil (in this case, call the property, it must
- ;; be a function which returns the appropriate indentation or nil and
- ;; does not change the buffer).
- (if (looking-at "\\sw\\|\\s_")
- (let* ((start (current-column))
- (function
- (intern-soft (buffer-substring (point)
- (progn (forward-sexp 1)
- (point)))))
- (method (get function 'indent-mim-function)))
- (if (or (if (equal method 'DEFINE) (setq method mim-body-indent))
- (integerp method))
- ;; only use method if its first line after containing-sexp.
- ;; we could have done this in calculate-mim-indent, but someday
- ;; someone might want to format frobs in a special form based
- ;; on position instead of indenting uniformly (like lisp if),
- ;; so preserve right for posterity. if not first line,
- ;; calculate-mim-indent already knows right indentation -
- ;; give luser chance to change indentation manually by changing
- ;; 1st line after containing-sexp.
- (if (> (progn (forward-line 1) (point)) (car (nthcdr 2 state)))
- (+ method start))
- (goto-char current-indent)
- (if (consp method)
- ;; list or pointed list of explicit indentations
- (indent-mim-offset state indent-point)
- (if (and (symbolp method) (fboundp method))
- ;; luser function - s/he better know what's going on.
- ;; should take state and indent-point as arguments - for
- ;; description of state, see parse-partial-sexp
- ;; documentation the function is guaranteed the following:
- ;; (1) state describes the closest surrounding form,
- ;; (2) indent-point is the beginning of the line being
- ;; indented, (3) point points to char in column that would
- ;; normally be used for indentation, (4) function is bound
- ;; to the special ATOM. See indent-mim-offset for example
- ;; of a special function.
- (funcall method state indent-point)))))))))
-
-(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))
- (containing-sexp (car (cdr state)))
- (last-sexp (car (nthcdr 2 state)))
- indentation)
- (goto-char (1+ containing-sexp))
- ;; determine which of the indentations to use.
- (while (and (< (point) indent-point)
- (condition-case nil
- (progn (forward-sexp 1)
- (parse-partial-sexp (point) indent-point 1 t))
- (error nil)))
- (skip-chars-backward " \t")
- (backward-prefix-chars)
- (if (= (following-char) ?\;)
- nil ; ignore comments
- (setq indentation (car indentations))
- (if (integerp (setq indentations (cdr indentations)))
- ;; if last cdr is integer, that is indentation to use for all
- ;; all the rest of the forms.
- (progn (setq mim-body-indent indentations)
- (setq indentations nil)))))
- (goto-char (1+ containing-sexp))
- (+ (current-column) (or indentation mim-body-indent))))
-
-(defun indent-mim-comment (&optional start)
- "Indent a one line (string) Mim comment following object, if any."
- (let* ((old-point (point)) (eol (progn (end-of-line) (point))) state last-sexp)
- ;; this function assumes that comment indenting is enabled. it is caller's
- ;; responsibility to check the indent-mim-comment flag before calling.
- (beginning-of-line)
- (catch 'no-comment
- (setq state (parse-partial-sexp (point) eol))
- ;; determine if there is an existing regular comment. a `regular'
- ;; comment is defined as a commented string which is the last thing
- ;; on the line and does not extend beyond the end of the line.
- (if (or (not (setq last-sexp (car (nthcdr 2 state))))
- (car (nthcdr 3 state)))
- ;; empty line or inside string (multiple line).
- (throw 'no-comment nil))
- ;; could be a comment, but make sure its not the only object.
- (beginning-of-line)
- (parse-partial-sexp (point) eol 0 t)
- (if (= (point) last-sexp)
- ;; only one object on line
- (throw 'no-comment t))
- (goto-char last-sexp)
- (skip-chars-backward " \t")
- (backward-prefix-chars)
- (if (not (looking-at ";[ \t]*\""))
- ;; aint no comment
- (throw 'no-comment nil))
- ;; there is an existing regular comment
- (delete-horizontal-space)
- ;; move it to comment-column if possible else to tab-stop
- (if (< (current-column) comment-column)
- (indent-to comment-column)
- (tab-to-tab-stop)))
- (goto-char old-point)))
-
-(defun indent-mim-line ()
- "Indent line of Mim code."
- (interactive "*")
- (let* ((position (- (point-max) (point)))
- (bol (progn (beginning-of-line) (point)))
- (indent (calculate-mim-indent)))
- (skip-chars-forward " \t")
- (if (/= (current-column) indent)
- (progn (delete-region bol (point)) (indent-to indent)))
- (if (> (- (point-max) position) (point)) (goto-char (- (point-max) position)))))
-
-(defun newline-and-mim-indent ()
- "Insert newline at point and indent."
- (interactive "*")
- ;; commented code would correct indentation of line in arglist which
- ;; starts with string, but it would indent every line twice. luser can
- ;; just say tab after typing string to get same effect.
- ;(if indent-mim-arglist (indent-mim-line))
- (newline)
- (indent-mim-line))
-
-(defun open-mim-line (&optional lines)
- "Insert newline before point and indent.
-With ARG insert that many newlines."
- (interactive "*p")
- (beginning-of-line)
- (let ((indent (calculate-mim-indent)))
- (while (> lines 0)
- (newline)
- (forward-line -1)
- (indent-to indent)
- (setq lines (1- lines)))))
-
-(defun indent-mim-object (&optional dont-indent-first-line)
- "Indent object following point and all lines contained inside it.
-With ARG, idents only contained lines (skips first line)."
- (interactive "*P")
- (let (end bol indent start)
- (save-excursion (parse-partial-sexp (point) (point-max) 0 t)
- (setq start (point))
- (forward-sexp 1)
- (setq end (- (point-max) (point))))
- (save-excursion
- (if (not dont-indent-first-line) (indent-mim-line))
- (while (progn (forward-line 1) (> (- (point-max) (point)) end))
- (setq indent (calculate-mim-indent start))
- (setq bol (point))
- (skip-chars-forward " \t")
- (if (/= indent (current-column))
- (progn (delete-region bol (point)) (indent-to indent)))
- (if indent-mim-comment (indent-mim-comment))))))
-
-(defun find-mim-definition (name)
- "Search for definition of function, macro, or gfcn.
-You need type only enough of the name to be unambiguous."
- (interactive "sName: ")
- (let (where)
- (save-excursion
- (goto-char (point-min))
- (condition-case nil
- (progn
- (re-search-forward
- (concat "^<\\(DEFINE\\|\\DEFMAC\\|FCN\\|GFCN\\)\\([ \t]*\\)"
- name))
- (setq where (point)))
- (error (error "Can't find %s" name))))
- (if where
- (progn (push-mark)
- (goto-char where)
- (beginning-of-line)
- (recenter 0)))))
-
-(defun begin-mim-comment ()
- "Move to existing comment or insert empty comment."
- (interactive "*")
- (let* ((eol (progn (end-of-line) (point)))
- (bol (progn (beginning-of-line) (point))))
- ;; check for existing comment first.
- (if (re-search-forward ";[ \t]*\"" eol t)
- ;; found it. indent if desired and go there.
- (if indent-mim-comment
- (let ((where (- (point-max) (point))))
- (indent-mim-comment)
- (goto-char (- (point-max) where))))
- ;; nothing there, make a comment.
- (let (state last-sexp)
- ;; skip past all the sexps on the line
- (goto-char bol)
- (while (and (equal (car (setq state (parse-partial-sexp (point) eol 0)))
- 0)
- (car (nthcdr 2 state)))
- (setq last-sexp (car (nthcdr 2 state))))
- (if (car (nthcdr 3 state))
- nil ; inside a string, punt
- (delete-region (point) eol) ; flush trailing whitespace
- (if (and (not last-sexp) (equal (car state) 0))
- (indent-to (calculate-mim-indent)) ; empty, indent like code
- (if (> (current-column) comment-column) ; indent to comment column
- (tab-to-tab-stop) ; unless past it, else to
- (indent-to comment-column))) ; tab-stop
- ;; if luser changes comment-{start end} to something besides semi
- ;; followed by zero or more whitespace characters followed by string
- ;; delimiters, the code above fails to find existing comments, but as
- ;; taa says, `let the losers lose'.
- (insert comment-start)
- (save-excursion (insert comment-end)))))))
-
-(defun skip-mim-whitespace (direction)
- (if (>= direction 0)
- (skip-chars-forward mim-whitespace (point-max))
- (skip-chars-backward mim-whitespace (point-min))))
-
-(defun inside-adecl-or-trailer-p (direction)
- (if (>= direction 0)
- (looking-at ":\\|!-")
- (or (= (preceding-char) ?:)
- (looking-at "!-"))))
-
-(defun sign (n)
- "Returns -1 if N < 0, else 1."
- (if (>= n 0) 1 -1))
-
-(defun abs (n)
- "Returns the absolute value of N."
- (if (>= n 0) n (- n)))
-
-(defun next-char (direction)
- "Returns preceding-char if DIRECTION < 0, otherwise following-char."
- (if (>= direction 0) (following-char) (preceding-char)))
-
-(provide 'mim-mode)
-
-;;; mim-mode.el ends here
+++ /dev/null
-;;; mim-syntax.el --- syntax checker for Mim (MDL).
-
-;; Copyright (C) 1985 Free Software Foundation, Inc.
-
-;; Author: K. Shane Hartman
-;; Maintainer: FSF
-;; Keywords: languages
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to
-;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;;; Code:
-
-(require 'mim-mode)
-
-(defun slow-syntax-check-mim ()
- "Check Mim syntax slowly.
-Points out the context of the error, if the syntax is incorrect."
- (interactive)
- (message "checking syntax...")
- (let ((stop (point-max)) point-stack current last-bracket whoops last-point)
- (save-excursion
- (goto-char (point-min))
- (while (and (not whoops)
- (re-search-forward "\\s(\\|\\s)\\|\"\\|[\\]" stop t))
- (setq current (preceding-char))
- (cond ((= current ?\")
- (condition-case nil
- (progn (re-search-forward "[^\\]\"")
- (setq current nil))
- (error (setq whoops (point)))))
- ((= current ?\\)
- (condition-case nil (forward-char 1) (error nil)))
- ((= (char-syntax current) ?\))
- (if (or (not last-bracket)
- (not (= (logand (lsh (aref (syntax-table) last-bracket) -8)
- ?\177)
- current)))
- (setq whoops (point))
- (setq last-point (car point-stack))
- (setq last-bracket (if last-point (char-after (1- last-point))))
- (setq point-stack (cdr point-stack))))
- (t
- (if last-point (setq point-stack (cons last-point point-stack)))
- (setq last-point (point))
- (setq last-bracket current)))))
- (cond ((not (or whoops last-point))
- (message "Syntax correct"))
- (whoops
- (goto-char whoops)
- (cond ((equal current ?\")
- (error "Unterminated string"))
- ((not last-point)
- (error "Extraneous %s" (char-to-string current)))
- (t
- (error "Mismatched %s with %s"
- (save-excursion
- (setq whoops (1- (point)))
- (goto-char (1- last-point))
- (buffer-substring (point)
- (min (progn (end-of-line) (point))
- whoops)))
- (char-to-string current)))))
- (t
- (goto-char last-point)
- (error "Unmatched %s" (char-to-string last-bracket))))))
-
-(defun fast-syntax-check-mim ()
- "Checks Mim syntax quickly.
-Answers correct or incorrect, cannot point out the error context."
- (interactive)
- (save-excursion
- (goto-char (point-min))
- (let (state)
- (while (and (not (eobp))
- (equal (car (setq state (parse-partial-sexp (point) (point-max) 0)))
- 0)))
- (if (equal (car state) 0)
- (message "Syntax correct")
- (error "Syntax incorrect")))))
-
-;;; mim-syntax.el ends here
+++ /dev/null
-;;; netunam.el --- HP-UX RFA Commands
-
-;; Copyright (C) 1988 Free Software Foundation, Inc.
-
-;; Author: Chris Hanson <cph@zurich.ai.mit.edu>
-;; Keywords: comm
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to
-;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;;; Commentary:
-
-;; Use the Remote File Access (RFA) facility of HP-UX from Emacs.
-
-;;; Code:
-
-(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))))))))
-\f
-(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)))))
-\f
-(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)))
-
-;;; netunam.el ends here
+++ /dev/null
-;;; old-shell.el --- run a shell in an Emacs window
-
-;; Copyright (C) 1985, 1986, 1987, 1990 Free Software Foundation, Inc.
-
-;; Keywords: processes
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to
-;; the Free Software Foundation, 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.
-
-;;; For documentation on the functionality provided by comint mode, and
-;;; the hooks available for customising it, see the file comint.el.
-
-;;; 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?
-
-;;; Code:
-
-(require 'comint)
-(defvar shell-popd-regexp "popd"
- "*Regexp to match subshell commands equivalent to popd.")
-
-(defvar shell-pushd-regexp "pushd"
- "*Regexp to match subshell commands equivalent to pushd.")
-
-(defvar shell-cd-regexp "cd"
- "*Regexp to match subshell commands equivalent to cd.")
-
-(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")
-
-\f
-;;; Basic Procedures
-;;; ===========================================================================
-;;;
-
-(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-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."
- (interactive)
- (comint-mode)
- (setq major-mode 'shell-mode
- mode-name "Shell"
- comint-prompt-regexp shell-prompt-pattern
- comint-input-sentinel 'shell-directory-tracker)
- (use-local-map shell-mode-map)
- (make-local-variable 'shell-dirstack)
- (set (make-local-variable 'shell-dirtrackp) t)
- (run-hooks 'shell-mode-hook))
-
-\f
-(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.
-
-The buffer is put in shell-mode, giving commands for sending input
-and controlling the subjobs of the shell.
-
-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.)"
- (interactive)
- (if (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*"))
-
-\f
-;;; 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."
- (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."
- (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)))
-
-(provide 'shell)
-
-;;; old-shell.el ends here
+++ /dev/null
-;; -*- Mode: Emacs-Lisp -*-
-;; sc-alist.el -- Version 1.0 (used to be baw-alist.el)
-
-;; association list utilities providing insertion, deletion, sorting
-;; fetching off key-value pairs in association lists.
-
-;; ========== Disclaimer ==========
-;; This software 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.
-
-;; This software was written as part of the supercite author's
-;; official duty as an employee of the United States Government and is
-;; thus in the public domain. You are free to use that particular
-;; software as you wish, but WITHOUT ANY WARRANTY WHATSOEVER. It
-;; would be nice, though if when you use any of this code, you give
-;; due credit to the author.
-
-;; ========== Author (unless otherwise stated) ========================
-;; NAME: Barry A. Warsaw USMAIL: Century Computing, Inc.
-;; TELE: (301) 593-3330 1014 West Street
-;; INET: bwarsaw@cen.com Laurel, Md 20707
-;; UUCP: uunet!cen.com!bwarsaw
-;;
-(provide 'sc-alist)
-
-
-(defun asort (alist-symbol key)
- "Move a specified key-value pair to the head of an alist.
-The alist is referenced by ALIST-SYMBOL. Key-value pair to move to
-head is one matching KEY. Returns the sorted list and doesn't affect
-the order of any other key-value pair. Side effect sets alist to new
-sorted list."
- (set alist-symbol
- (sort (copy-alist (eval alist-symbol))
- (function (lambda (a b) (equal (car a) key))))))
-
-
-(defun aelement (key value)
- "Makes a list of a cons cell containing car of KEY and cdr of VALUE.
-The returned list is suitable as an element of an alist."
- (list (cons key value)))
-
-
-(defun aheadsym (alist)
- "Return the key symbol at the head of ALIST."
- (car (car alist)))
-
-
-(defun anot-head-p (alist key)
- "Find out if a specified key-value pair is not at the head of an alist.
-The alist to check is specified by ALIST and the key-value pair is the
-one matching the supplied KEY. Returns nil if ALIST is nil, or if
-key-value pair is at the head of the alist. Returns t if key-value
-pair is not at the head of alist. ALIST is not altered."
- (not (equal (aheadsym alist) key)))
-
-
-(defun aput (alist-symbol key &optional value)
- "Inserts a key-value pair into an alist.
-The alist is referenced by ALIST-SYMBOL. The key-value pair is made
-from KEY and optionally, VALUE. Returns the altered alist or nil if
-ALIST is nil.
-
-If the key-value pair referenced by KEY can be found in the alist, and
-VALUE is supplied non-nil, then the value of KEY will be set to VALUE.
-If VALUE is not supplied, or is nil, the key-value pair will not be
-modified, but will be moved to the head of the alist. If the key-value
-pair cannot be found in the alist, it will be inserted into the head
-of the alist (with value nil if VALUE is nil or not supplied)."
- (let ((elem (aelement key value))
- alist)
- (asort alist-symbol key)
- (setq alist (eval alist-symbol))
- (cond ((null alist) (set alist-symbol elem))
- ((anot-head-p alist key) (set alist-symbol (nconc elem alist)))
- (value (setcar alist (car elem)))
- (t alist))))
-
-
-(defun adelete (alist-symbol key)
- "Delete a key-value pair from the alist.
-Alist is referenced by ALIST-SYMBOL and the key-value pair to remove
-is pair matching KEY. Returns the altered alist."
- (asort alist-symbol key)
- (let ((alist (eval alist-symbol)))
- (cond ((null alist) nil)
- ((anot-head-p alist key) alist)
- (t (set alist-symbol (cdr alist))))))
-
-
-(defun aget (alist key &optional keynil-p)
- "Returns the value in ALIST that is associated with KEY.
-Optional KEYNIL-P describes what to do if the value associated with
-KEY is nil. If KEYNIL-P is not supplied or is nil, and the value is
-nil, then KEY is returned. If KEYNIL-P is non-nil, then nil would be
-returned.
-
-If no key-value pair matching KEY could be found in ALIST, or ALIST is
-nil then nil is returned. ALIST is not altered."
- (let ((copy (copy-alist alist)))
- (cond ((null alist) nil)
- ((progn (asort 'copy key)
- (anot-head-p copy key)) nil)
- ((cdr (car copy)))
- (keynil-p nil)
- ((car (car copy)))
- (t nil))))
-
-
-(defun amake (alist-symbol keylist &optional valuelist)
- "Make an association list.
-The association list is attached to the alist referenced by
-ALIST-SYMBOL. Each element in the KEYLIST becomes a key and is
-associated with the value in VALUELIST with the same index. If
-VALUELIST is not supplied or is nil, then each key in KEYLIST is
-associated with nil.
-
-KEYLIST and VALUELIST should have the same number of elements, but
-this isn't enforced. If VALUELIST is smaller than KEYLIST, remaining
-keys are associated with nil. If VALUELIST is larger than KEYLIST,
-extra values are ignored. Returns the created alist."
- (let ((keycar (car keylist))
- (keycdr (cdr keylist))
- (valcar (car valuelist))
- (valcdr (cdr valuelist)))
- (cond ((null keycdr)
- (aput alist-symbol keycar valcar))
- (t
- (amake alist-symbol keycdr valcdr)
- (aput alist-symbol keycar valcar))))
- (eval alist-symbol))
+++ /dev/null
-;; -*- Mode: Emacs-Lisp -*-
-;; sc.el -- Version 2.3 (used to be supercite.el)
-
-;; ========== Introduction ==========
-;; Citation and attribution package for various GNU emacs news and
-;; electronic mail reading subsystems. This version of supercite should
-;; work with Rmail and GNUS as found in Emacs 19. It may also work with
-;; VM 4.40+ and MH-E 3.7.
-
-;; This package does not do any yanking of messages, but instead
-;; massages raw reply buffers set up by the reply/forward functions in
-;; the news/mail subsystems. Therefore, such useful operations as
-;; yanking and citing portions of the original article (instead of the
-;; whole article) are not within the ability or responsibility of
-;; supercite.
-
-;; ========== Disclaimer ==========
-;; This software is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY. No author or distributor, nor any
-;; author's past, present, or future employers 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.
-
-;; Some of this software was written as part of the supercite author's
-;; official duty as an employee of the United States Government and is
-;; thus not subject to copyright. You are free to use that particular
-;; software as you wish, but WITHOUT ANY WARRANTY WHATSOEVER. It
-;; would be nice, though if when you use any of this or other freely
-;; available code, you give due credit to the author.
-
-;; Other parts of this code were written by other people. Wherever
-;; possible, credit to that author, and the copy* notice supplied by
-;; the author are included with that code. The supercite author is no
-;; longer an employee of the U.S. Government so the GNU Public Licence
-;; should be considered in effect for all enhancements and bug fixes
-;; performed by the author.
-
-;; ========== Author (unless otherwise stated) ========================
-;; NAME: Barry A. Warsaw USMAIL: Century Computing, Inc.
-;; TELE: (301) 593-3330 1014 West Street
-;; INET: bwarsaw@cen.com Laurel, Md 20707
-;; UUCP: uunet!cen.com!bwarsaw
-;;
-;; Want to be on the Supercite mailing list?
-;;
-;; Send articles to:
-;; Internet: supercite@anthem.nlm.nih.gov
-;; UUCP: uunet!anthem.nlm.nih.gov!supercite
-;;
-;; Send administrivia (additions/deletions to list, etc) to:
-;; Internet: supercite-request@anthem.nlm.nih.gov
-;; UUCP: uunet!anthem.nlm.nih.gov!supercite-request
-
-;; ========== Credits and Thanks ==========
-;; This package was derived from the Superyank 1.11 package as posted
-;; to the net. Superyank 1.11 was inspired by code and ideas from
-;; Martin Neitzel and Ashwin Ram. Supercite version 2.3 has evolved
-;; through the comments and suggestions of the supercite mailing list
-;; which consists of many authors and users of the various mail and
-;; news reading subsystems.
-
-;; Many folks on the supercite mailing list have contributed their
-;; help in debugging, making suggestions and supplying support code or
-;; bug fixes for the previous versions of supercite. I want to thank
-;; everyone who helped, especially (in no particular order):
-;;
-;; Mark D. Baushke, Khalid Sattar, David Lawrence, Chris Davis, Kyle
-;; Jones, Kayvan Sylvan, Masanobu Umeda, Dan Jacobson, Piet van
-;; Oostrum, Hamish (H.I.) Macdonald, and Joe Wells.
-;;
-;; I don't mean to leave anyone out. All who have helped have been
-;; appreciated.
-
-;; ========== Getting Started ==========
-;; Here is a quick guide to getting started with supercite. The
-;; information contained here is mostly excerpted from the more
-;; detailed explanations given in the accompanying README file.
-;; Naturally, there are many customizations you can do to give your
-;; replies that personalized flair, but the instructions in this
-;; section should be sufficient for getting started.
-
-;; First, to connect supercite to any mail/news reading subsystem, put
-;; this in your .emacs file:
-;;
-;; (setq mail-yank-hooks 'sc-cite-original) ; for old mail agents
-;; (setq mh-yank-hooks 'sc-cite-original) ; for MH-E only
-;; (add-hook 'mail-citation-hook 'sc-cite-original) ; for newer mail agents
-;;
-;; If supercite is not pre-loaded into your emacs session, you should
-;; add the following autoload:
-;;
-;; (autoload 'sc-cite-original "sc" "Supercite 2.3" t)
-;;
-;; Finally, if you want to customize supercite, you should do it in a
-;; function called my-supercite-hook and:
-;;
-;; (setq sc-load-hook 'my-supercite-hook)
-
-(require 'assoc)
-
-\f
-;; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
-;; start of user defined variables
-;; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
-
-(defvar sc-nested-citation-p nil
- "*Controls whether to use nested or non-nested citation style.
-Non-nil uses nested citations, nil uses non-nested citations. Type
-\\[sc-describe] for more information.")
-
-(defvar sc-citation-leader " "
- "*String comprising first part of a citation.")
-
-(defvar sc-citation-delimiter ">"
- "*String comprising third part of a citation.
-This string is used in both nested and non-nested citations.")
-
-(defvar sc-citation-separator " "
- "*String comprising fourth and last part of a citation.")
-
-(defvar sc-default-author-name "Anonymous"
- "*String used when author's name cannot be determined.")
-
-(defvar sc-default-attribution "Anon"
- "*String used when author's attribution cannot be determined.")
-
-;; Noriya KOBAYASHI (nk@ics.osaka-u.ac.jp) writes to the supercite
-;; mailing list:
-;; I use supercite in Nemacs-3.3.2. In order to handle citation using
-;; Kanji, [...set sc-cite-regexp to...]
-;; "\\s *\\([a-zA-Z0-9]\\|\\cc\\|\\cC\\|\\ch\\|\\cH\\|\\ck\\|\\cK\\)*\\s *>+"
-;;
-(defvar sc-cite-regexp "\\s *[-a-zA-Z0-9_.]*>+\\s *"
- "*Regular expression describing how a already cited line begins.
-The regexp is only used at the beginning of a line, so it doesn't need
-to start with a '^'.")
-
-(defvar sc-titlecue-regexp "\\s +-+\\s +"
- "*Regular expression describing the separator between names and titles.
-Set to nil to treat entire field as a name.")
-
-(defvar sc-spacify-name-chars '(?_ ?* ?+ ?=)
- "*List of characters to convert to spaces if found in an author's name.")
-
-(defvar sc-nicknames-alist
- '(("Michael" "Mike")
- ("Daniel" "Dan")
- ("David" "Dave")
- ("Jonathan" "John")
- ("William" "Bill")
- ("Elizabeth" "Beth")
- ("Elizabeth" "Betsy")
- ("Kathleen" "Kathy")
- ("Smith" "Smitty"))
- "*Association list of names and their common nicknames.
-Entries are of the form (NAME NICKNAME), and NAMEs can have more than
-one nickname. Nicknames will not be automatically used as an
-attribution string, since I'm not sure this is really polite, but if a
-name is glommed from the author name and presented in the attribution
-string completion list, the matching nicknames will also be presented.
-Set this variable to nil to defeat nickname expansions. Also note that
-nicknames are not put in the supercite information alist.")
-
-(defvar sc-confirm-always-p t
- "*If non-nil, always confirm attribution string before citing text body.")
-
-(defvar sc-preferred-attribution 'firstname
- "*Specifies which part of the author's name becomes the attribution.
-The value of this variable must be one of the following quoted symbols:
-
- emailname -- email terminus name
- initials -- initials of author
- firstname -- first name of author
- lastname -- last name of author
- middlename1 -- first middle name of author
- middlename2 -- second middle name of author
- ...
-
-Middle name indexes can be any positive integer greater than 0, though
-it is unlikely that many authors will supply more than one middle
-name, if that many.")
-
-(defvar sc-use-only-preference-p nil
- "*Controls what happens when the preferred attribution cannot be found.
-If non-nil, then sc-default-attribution will be used. If nil, then
-some secondary scheme will be employed to find a suitable attribution
-string.")
-
-(defvar sc-downcase-p nil
- "*Non-nil means downcase the attribution and citation strings.")
-
-(defvar sc-rewrite-header-list
- '((sc-no-header)
- (sc-header-on-said)
- (sc-header-inarticle-writes)
- (sc-header-regarding-adds)
- (sc-header-attributed-writes)
- (sc-header-verbose)
- (sc-no-blank-line-or-header)
- )
- "*List of reference header rewrite functions.
-The variable sc-preferred-header-style controls which function in this
-list is chosen for automatic reference header insertions. Electric
-reference mode will cycle through this list of functions. For more
-information, type \\[sc-describe].")
-
-(defvar sc-preferred-header-style 1
- "*Index into sc-rewrite-header-list specifying preferred header style.
-Index zero accesses the first function in the list.")
-
-(defvar sc-electric-references-p t
- "*Use electric references if non-nil.")
-
-(defvar sc-electric-circular-p t
- "*Treat electric references as circular if non-nil.")
-
-(defvar sc-mail-fields-list
- '("date" "message-id" "subject" "newsgroups" "references"
- "from" "return-path" "path" "reply-to" "organization"
- "reply" )
- "*List of mail header whose values will be saved by supercite.
-These values can be used in header rewrite functions by accessing them
-with the sc-field function. Mail headers in this list are case
-insensitive and do not require a trailing colon.")
-
-(defvar sc-mumble-string ""
- "*Value returned by sc-field if chosen field cannot be found.")
-
-(defvar sc-nuke-mail-headers-p t
- "*Nuke or don't nuke mail headers.
-If non-nil, nuke mail headers after gleaning useful information from
-them.")
-
-(defvar sc-reference-tag-string ">>>>> "
- "*String used at the beginning of built-in reference headers.")
-
-(defvar sc-fill-paragraph-hook 'sc-fill-paragraph
- "*Hook for filling a paragraph.
-This hook gets executed when you fill a paragraph either manually or
-automagically. It expects point to be within the extent of the
-paragraph that is going to be filled. This hook allows you to use a
-different paragraph filling package than the one supplied with
-supercite.")
-
-(defvar sc-auto-fill-region-p nil
- "*If non-nil, automatically fill each paragraph after it has been cited.")
-
-(defvar sc-auto-fill-query-each-paragraph-p nil
- "*If non-nil, query before filling each paragraph.
-No querying and no filling will be performed if sc-auto-fill-region-p
-is set to nil.")
-
-(defvar sc-fixup-whitespace-p nil
- "*If non-nil, delete all leading white space before citing.")
-
-(defvar sc-all-but-cite-p nil
- "*If non-nil, sc-cite-original does everything but cite the text.
-This is useful for manually citing large messages, or portions of
-large messages. When non-nil, sc-cite-original will still set up all
-necessary variables and databases, but will skip the citing routine
-which modify the reply buffer's text.")
-
-(defvar sc-load-hook nil
- "*User definable hook.
-Runs after supercite is loaded. Set your customizations here.")
-
-(defvar sc-pre-hook nil
- "*User definable hook.
-Runs before sc-cite-original executes.")
-
-(defvar sc-post-hook nil
- "*User definable hook.
-Runs after sc-cite-original executes.")
-
-(defvar sc-header-nuke-list
- '("via" "origin" "status" "received" "remailed" "cc" "sender" "replied"
- "organization" "keywords" "distribution" "xref" "references" "expires"
- "approved" "summary" "precedence" "subject" "newsgroup[s]?"
- "\\(followup\\|apparently\\|errors\\|\\(\\(in-\\)?reply\\)?-\\)?to"
- "x-[a-z0-9-]+" "[a-z-]*message-id" "\\(summary-\\)?line[s]"
- "\\(\\(return\\|reply\\)-\\)?path" "\\(posted-\\)?date"
- "\\(mail-\\)?from")
- "*List of mail headers to remove from body of reply.")
-
-
-\f
-;; ======================================================================
-;; keymaps
-
-(defvar sc-default-keymap
- '(lambda ()
- (local-set-key "\C-c\C-r" 'sc-insert-reference)
- (local-set-key "\C-c\C-t" 'sc-cite)
- (local-set-key "\C-c\C-a" 'sc-recite)
- (local-set-key "\C-c\C-u" 'sc-uncite)
- (local-set-key "\C-c\C-i" 'sc-insert-citation)
- (local-set-key "\C-c\C-o" 'sc-open-line)
- (local-set-key "\C-c\C-q" 'sc-fill-paragraph-manually)
- (local-set-key "\C-cq" 'sc-fill-paragraph-manually)
- (local-set-key "\C-c\C-m" 'sc-modify-information)
- (local-set-key "\C-cf" 'sc-view-field)
- (local-set-key "\C-cg" 'sc-glom-headers)
- (local-set-key "\C-c\C-v" 'sc-version)
- (local-set-key "\C-c?" 'sc-describe)
- )
- "*Default keymap if major-mode can't be found in `sc-local-keymaps'.")
-
-(defvar sc-local-keymaps
- '((mail-mode
- (lambda ()
- (local-set-key "\C-c\C-r" 'sc-insert-reference)
- (local-set-key "\C-c\C-t" 'sc-cite)
- (local-set-key "\C-c\C-a" 'sc-recite)
- (local-set-key "\C-c\C-u" 'sc-uncite)
- (local-set-key "\C-c\C-i" 'sc-insert-citation)
- (local-set-key "\C-c\C-o" 'sc-open-line)
- (local-set-key "\C-c\C-q" 'sc-fill-paragraph-manually)
- (local-set-key "\C-cq" 'sc-fill-paragraph-manually)
- (local-set-key "\C-c\C-m" 'sc-modify-information)
- (local-set-key "\C-cf" 'sc-view-field)
- (local-set-key "\C-cg" 'sc-glom-headers)
- (local-set-key "\C-c\C-v" 'sc-version)
- (local-set-key "\C-c?" 'sc-describe)
- ))
- (mh-letter-mode
- (lambda ()
- (local-set-key "\C-c\C-r" 'sc-insert-reference)
- (local-set-key "\C-c\C-t" 'sc-cite)
- (local-set-key "\C-c\C-a" 'sc-recite)
- (local-set-key "\C-c\C-u" 'sc-uncite)
- (local-set-key "\C-ci" 'sc-insert-citation)
- (local-set-key "\C-c\C-o" 'sc-open-line)
- (local-set-key "\C-cq" 'sc-fill-paragraph-manually)
- (local-set-key "\C-c\C-m" 'sc-modify-information)
- (local-set-key "\C-cf" 'sc-view-field)
- (local-set-key "\C-cg" 'sc-glom-headers)
- (local-set-key "\C-c\C-v" 'sc-version)
- (local-set-key "\C-c?" 'sc-describe)
- ))
- (news-reply-mode mail-mode)
- (vm-mail-mode mail-mode)
- (e-reply-mode mail-mode)
- (n-reply-mode mail-mode)
- )
- "*List of keymaps to use with the associated major-mode.")
-
-(defvar sc-electric-mode-map nil
- "*Keymap for sc-electric-mode.")
-
-(if sc-electric-mode-map
- nil
- (setq sc-electric-mode-map (make-sparse-keymap))
- (define-key sc-electric-mode-map "p" 'sc-eref-prev)
- (define-key sc-electric-mode-map "n" 'sc-eref-next)
- (define-key sc-electric-mode-map "s" 'sc-eref-setn)
- (define-key sc-electric-mode-map "j" 'sc-eref-jump)
- (define-key sc-electric-mode-map "x" 'sc-eref-abort)
- (define-key sc-electric-mode-map "\r" 'sc-eref-exit)
- (define-key sc-electric-mode-map "\n" 'sc-eref-exit)
- (define-key sc-electric-mode-map "q" 'sc-eref-exit)
- (define-key sc-electric-mode-map "g" 'sc-eref-goto)
- )
-
-;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-;; end of user defined variables
-;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-
-\f
-;; ======================================================================
-;; global variables, not user accessible
-
-(defconst sc-version-number "2.3"
- "Supercite's version number.")
-
-;; when rnewspost.el patch is installed (or function is overloaded)
-;; this should be nil since supercite now does this itself.
-(setq news-reply-header-hook nil)
-
-;; autoload for sc-electric-mode
-(autoload 'sc-electric-mode "sc-elec"
- "Quasi-major mode for viewing supercite reference headers." nil)
-
-;; global alists (gals), misc variables. make new bytecompiler happy
-(defvar sc-gal-information nil
- "Internal global alist variable containing information.")
-(defvar sc-gal-attributions nil
- "Internal global alist variable containing attributions.")
-(defvar sc-fill-arg nil
- "Internal fill argument holder.")
-(defvar sc-cite-context nil
- "Internal citation context holder.")
-(defvar sc-force-confirmation-p nil
- "Internal variable.")
-
-(make-variable-buffer-local 'sc-gal-attributions)
-(make-variable-buffer-local 'sc-gal-information)
-(make-variable-buffer-local 'sc-leached-keymap)
-(make-variable-buffer-local 'sc-fill-arg)
-(make-variable-buffer-local 'sc-cite-context)
-
-(setq-default sc-gal-attributions nil)
-(setq-default sc-gal-information nil)
-(setq-default sc-leached-keymap (current-local-map))
-(setq-default sc-fill-arg nil)
-(setq-default sc-cite-context nil)
-
-
-\f
-;; ======================================================================
-;; miscellaneous support functions
-
-(defun sc-mark ()
- "Mark compatibility between emacs v18 and v19."
- (let ((zmacs-regions nil))
- (marker-position (mark-marker))))
-
-(defun sc-update-gal (attribution)
- "Update the information alist.
-Add ATTRIBUTION and compose the nested and non-nested citation
-strings."
- (let ((attrib (if sc-downcase-p (downcase attribution) attribution)))
- (aput 'sc-gal-information "sc-attribution" attrib)
- (aput 'sc-gal-information "sc-nested-citation"
- (concat attrib sc-citation-delimiter))
- (aput 'sc-gal-information "sc-citation"
- (concat sc-citation-leader
- attrib
- sc-citation-delimiter
- sc-citation-separator))))
-
-(defun sc-valid-index-p (index)
- "Returns t if INDEX is a valid index into sc-rewrite-header-list."
- (let ((last (1- (length sc-rewrite-header-list))))
- (and (natnump index) ;; a number, and greater than or equal to zero
- (<= index last) ;; less than or equal to the last index
- )))
-
-(defun sc-string-car (namestring)
- "Return the string-equivalent \"car\" of NAMESTRING.
-
- example: (sc-string-car \"John Xavier Doe\")
- => \"John\""
- (substring namestring
- (progn (string-match "\\s *" namestring) (match-end 0))
- (progn (string-match "\\s *\\S +" namestring) (match-end 0))))
-
-(defun sc-string-cdr (namestring)
- "Return the string-equivalent \"cdr\" of NAMESTRING.
-
- example: (sc-string-cdr \"John Xavier Doe\")
- => \"Xavier Doe\""
- (substring namestring
- (progn (string-match "\\s *\\S +\\s *" namestring)
- (match-end 0))))
-
-(defun sc-linepos (&optional position col-p)
- "Return the character position at various line positions.
-Optional POSITION can be one of the following symbols:
- bol == beginning of line
- boi == beginning of indentation
- eol == end of line [default]
-
-Optional COL-P non-nil returns current-column instead of character position."
- (let ((tpnt (point))
- rval)
- (cond
- ((eq position 'bol) (beginning-of-line))
- ((eq position 'boi) (back-to-indentation))
- (t (end-of-line)))
- (setq rval (if col-p (current-column) (point)))
- (goto-char tpnt)
- rval))
-
-\f
-;; ======================================================================
-;; this section snarfs mail fields and places them in the info alist
-
-(defun sc-build-header-zap-regexp ()
- "Return a regexp for sc-mail-yank-clear-headers."
- (let ((headers sc-header-nuke-list)
- (regexp nil))
- (while headers
- (setq regexp (concat regexp
- "^" (car headers) ":"
- (if (cdr headers) "\\|" nil)))
- (setq headers (cdr headers)))
- regexp))
-
-(defun sc-mail-yank-clear-headers (start end)
- "Nuke mail headers between START and END."
- (if (and sc-nuke-mail-headers-p sc-header-nuke-list)
- (let ((regexp (sc-build-header-zap-regexp)))
- (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 regexp nil t))
- (beginning-of-line)
- (delete-region (point)
- (progn (re-search-forward "\n[^ \t]")
- (forward-char -1)
- (point)))
- )))
- ))))
-
-(defun sc-mail-fetch-field (field)
- "Return the value of the header field FIELD.
-The buffer is expected to be narrowed to just the headers of the
-message."
- (save-excursion
- (goto-char (point-min))
- (let ((case-fold-search t)
- (name (concat "^" (regexp-quote field) "[ \t]*:[ \t]*")))
- (goto-char (point-min))
- (if (re-search-forward name nil t)
- (let ((opoint (point)))
- (while (progn (forward-line 1)
- (looking-at "[ \t]")))
- (buffer-substring opoint (1- (point))))))))
-
-(defun sc-fetch-fields (start end)
- "Fetch the mail fields in the region from START to END.
-These fields can be accessed in header rewrite functions with sc-field."
- (save-excursion
- (save-restriction
- (narrow-to-region start end)
- (goto-char start)
- (let ((fields sc-mail-fields-list))
- (while fields
- (let ((value (sc-mail-fetch-field (car fields)))
- (next (cdr fields)))
- (and value
- (aput 'sc-gal-information (car fields) value))
- (setq fields next)))
- (if (sc-mail-fetch-field "from")
- (aput 'sc-gal-information "from" (sc-mail-fetch-field "from")))))))
-
-(defun sc-field (field)
- "Return the alist information associated with the FIELD.
-If FIELD is not a valid key, return sc-mumble-string."
- (or (aget sc-gal-information field) sc-mumble-string))
-
-\f
-;; ======================================================================
-;; built-in reference header rewrite functions
-
-(defun sc-no-header ()
- "Does nothing. Use this instead of nil to get a blank header."
- ())
-
-(defun sc-no-blank-line-or-header()
- "Similar to sc-no-header except it removes the preceding blank line."
- (if (not (bobp))
- (if (and (eolp)
- (progn (forward-line -1)
- (or (looking-at mail-header-separator)
- (and (eq major-mode 'mh-letter-mode)
- (mh-in-header-p)))))
- (progn (forward-line)
- (let ((kill-lines-magic t)) (kill-line))))))
-
-(defun sc-header-on-said ()
- "\"On <date>, <from> said:\", unless 1. the \"from\" field cannot be
-found, in which case nothing is inserted; or 2. the \"date\" field is
-missing in which case only the from part is printed."
- (let* ((sc-mumble-string "")
- (whofrom (sc-field "from"))
- (when (sc-field "date")))
- (if (not (string= whofrom ""))
- (insert sc-reference-tag-string
- (if (not (string= when ""))
- (concat "On " when ", ") "")
- whofrom " said:\n"))))
-
-(defun sc-header-inarticle-writes ()
- "\"In article <message-id>, <from> writes:\"
-Treats \"message-id\" and \"from\" fields similar to sc-header-on-said."
- (let* ((sc-mumble-string "")
- (whofrom (sc-field "from"))
- (msgid (sc-field "message-id")))
- (if (not (string= whofrom ""))
- (insert sc-reference-tag-string
- (if (not (string= msgid ""))
- (concat "In article " msgid ", ") "")
- whofrom " writes:\n"))))
-
-(defun sc-header-regarding-adds ()
- "\"Regarding <subject>; <from> adds:\"
-Treats \"subject\" and \"from\" fields similar to sc-header-on-said."
- (let* ((sc-mumble-string "")
- (whofrom (sc-field "from"))
- (subj (sc-field "subject")))
- (if (not (string= whofrom ""))
- (insert sc-reference-tag-string
- (if (not (string= subj ""))
- (concat "Regarding " subj "; ") "")
- whofrom " adds:\n"))))
-
-(defun sc-header-attributed-writes ()
- "\"<sc-attribution>\" == <sc-author> <address> writes:
-Treats these fields in a similar manner to sc-header-on-said."
- (let* ((sc-mumble-string "")
- (whofrom (sc-field "from"))
- (reply (sc-field "sc-reply-address"))
- (from (sc-field "sc-from-address"))
- (attr (sc-field "sc-attribution"))
- (auth (sc-field "sc-author")))
- (if (not (string= whofrom ""))
- (insert sc-reference-tag-string
- (if (not (string= attr ""))
- (concat "\"" attr "\" == " ) "")
- (if (not (string= auth ""))
- (concat auth " ") "")
- (if (not (string= reply ""))
- (concat "<" reply ">")
- (if (not (string= from ""))
- (concat "<" from ">") ""))
- " writes:\n"))))
-
-(defun sc-header-verbose ()
- "Very verbose, some say gross."
- (let* ((sc-mumble-string "")
- (whofrom (sc-field "from"))
- (reply (sc-field "sc-reply-address"))
- (from (sc-field "sc-from-address"))
- (author (sc-field "sc-author"))
- (date (sc-field "date"))
- (org (sc-field "organization"))
- (msgid (sc-field "message-id"))
- (ngrps (sc-field "newsgroups"))
- (subj (sc-field "subject"))
- (refs (sc-field "references"))
- (cite (sc-field "sc-citation"))
- (nl sc-reference-tag-string))
- (if (not (string= whofrom ""))
- (insert (if (not (string= date ""))
- (concat nl "On " date ",\n") "")
- (concat nl (if (not (string= author ""))
- author
- whofrom) "\n")
- (if (not (string= org ""))
- (concat nl "from the organization of " org "\n") "")
- (if (not (string= reply ""))
- (concat nl "who can be reached at: " reply "\n")
- (if (not (string= from ""))
- (concat nl "who can be reached at: " from "\n") ""))
- (if (not (string= cite ""))
- (concat nl "(whose comments are cited below with \""
- cite "\"),\n") "")
- (if (not (string= msgid ""))
- (concat nl "had this to say in article " msgid "\n") "")
- (if (not (string= ngrps ""))
- (concat nl "in newsgroups " ngrps "\n") "")
- (if (not (string= subj ""))
- (concat nl "concerning the subject of " subj "\n") "")
- (if (not (string= refs ""))
- (concat nl "(see " refs " for more details)\n") "")
- ))))
-
-\f
-;; ======================================================================
-;; this section queries the user for necessary information
-
-(defun sc-query (&optional default)
- "Query for an attribution string with the optional DEFAULT choice.
-Returns the string entered by the user, if non-empty and non-nil, or
-DEFAULT otherwise. If DEFAULT is not supplied, sc-default-attribution
-is used."
- (if (not default) (setq default sc-default-attribution))
- (let* ((prompt (concat "Enter attribution string: (default " default ") "))
- (query (read-string prompt)))
- (if (or (null query)
- (string= query ""))
- default
- query)))
-
-(defun sc-confirm ()
- "Confirm the preferred attribution with the user."
- (if (or sc-confirm-always-p
- sc-force-confirmation-p)
- (aput 'sc-gal-attributions
- (let* ((default (aheadsym sc-gal-attributions))
- chosen
- (prompt (concat "Complete "
- (cond
- ((eq sc-cite-context 'citing) "cite")
- ((eq sc-cite-context 'reciting) "recite")
- (t ""))
- " attribution string: (default "
- default ") "))
- (minibuffer-local-completion-map
- (copy-keymap minibuffer-local-completion-map)))
- (define-key minibuffer-local-completion-map "\C-g"
- '(lambda () (interactive) (beep) (throw 'select-abort nil)))
- (setq chosen (completing-read prompt sc-gal-attributions))
- (if (or (not chosen)
- (string= chosen ""))
- default
- chosen)))))
-
-\f
-;; ======================================================================
-;; this section contains primitive functions used in the email address
-;; parsing schemes. they extract name fields from various parts of
-;; the "from:" field.
-
-(defun sc-style1-addresses (from-string &optional delim)
- "Extract the author's email terminus from email address FROM-STRING.
-Match addresses of the style \"name%[stuff].\" when called with DELIM
-of \"%\" and addresses of the style \"[stuff]name@[stuff]\" when
-called with DELIM \"@\". If DELIM is nil or not provided, matches
-addresses of the style \"name\"."
- (and (string-match (concat "[a-zA-Z0-9_-]+" delim) from-string 0)
- (substring from-string
- (match-beginning 0)
- (- (match-end 0) (if (null delim) 0 1)))))
-
-(defun sc-style2-addresses (from-string)
- "Extract the author's email terminus from email address FROM-STRING.
-Match addresses of the style \"[stuff]![stuff]...!name[stuff].\""
- (let ((eos (length from-string))
- (mstart (string-match "![a-zA-Z0-9_-]+\\([^!a-zA-Z0-9_-]\\|$\\)"
- from-string 0))
- (mend (match-end 0)))
- (and mstart
- (substring from-string (1+ mstart) (- mend (if (= mend eos) 0 1)))
- )))
-
-(defun sc-get-address (from-string author)
- "Get the full email address path from FROM-STRING.
-AUTHOR is the author's name (which is removed from the address)."
- (let ((eos (length from-string)))
- (if (string-match (concat "\\(^\\|^\"\\)" author
- "\\(\\s +\\|\"\\s +\\)") from-string 0)
- (let ((addr (substring from-string (match-end 0) eos)))
- (if (and (= (aref addr 0) ?<)
- (= (aref addr (1- (length addr))) ?>))
- (substring addr 1 (1- (length addr)))
- addr))
- (if (string-match "[a-zA-Z0-9!@%._-]+" from-string 0)
- (substring from-string (match-beginning 0) (match-end 0))
- "")
- )))
-
-(defun sc-get-emailname (from-string)
- "Get the email terminus name from FROM-STRING."
- (cond
- ((sc-style1-addresses from-string "%"))
- ((sc-style1-addresses from-string "@"))
- ((sc-style2-addresses from-string))
- ((sc-style1-addresses from-string nil))
- (t (substring from-string 0 10))))
-
-\f
-;; ======================================================================
-;; this section contains functions that will extract a list of names
-;; from the name field string.
-
-(defun sc-spacify-name-chars (name)
- (let ((len (length name))
- (s 0))
- (while (< s len)
- (if (memq (aref name s) sc-spacify-name-chars)
- (aset name s 32))
- (setq s (1+ s)))
- name))
-
-(defun sc-name-substring (string start end extend)
- "Extract the specified substring of STRING from START to END.
-EXTEND is the number of characters on each side to extend the
-substring."
- (and start
- (let ((sos (+ start extend))
- (eos (- end extend)))
- (substring string sos
- (or (string-match sc-titlecue-regexp string sos) eos)
- ))))
-
-(defun sc-extract-namestring (from-string)
- "Extract the name string from FROM-STRING.
-This should be the author's full name minus an optional title."
- (let ((pstart (string-match "(.*)" from-string 0))
- (pend (match-end 0))
- (qstart (string-match "\".*\"" from-string 0))
- (qend (match-end 0))
- (bstart (string-match "\\([.a-zA-Z0-9_-]+\\s *\\)+" from-string 0))
- (bend (match-end 0)))
- (sc-spacify-name-chars
- (cond
- ((sc-name-substring from-string pstart pend 1))
- ((sc-name-substring from-string qstart qend 1))
- ((sc-name-substring from-string bstart bend 0))
- ))))
-
-(defun sc-chop-namestring (namestring)
- "Convert NAMESTRING to a list of names.
-
- example: (sc-namestring-to-list \"John Xavier Doe\")
- => (\"John\" \"Xavier\" \"Doe\")"
- (if (not (string= namestring ""))
- (append (list (sc-string-car namestring))
- (sc-chop-namestring (sc-string-cdr namestring)))))
-
-(defun sc-strip-initials (namelist)
- "Extract the author's initials from the NAMELIST."
- (if (not namelist)
- nil
- (concat (if (string= (car namelist) "")
- ""
- (substring (car namelist) 0 1))
- (sc-strip-initials (cdr namelist)))))
-
-\f
-;; ======================================================================
-;; this section handles selection of the attribution and citation strings
-
-(defun sc-populate-alists (from-string)
- "Put important and useful information in the alists using FROM-STRING.
-Return the list of name symbols."
- (let* ((namelist (sc-chop-namestring (sc-extract-namestring from-string)))
- (revnames (reverse (cdr namelist)))
- (midnames (reverse (cdr revnames)))
- (firstname (car namelist))
- (midnames (reverse (cdr revnames)))
- (lastname (car revnames))
- (initials (sc-strip-initials namelist))
- (emailname (sc-get-emailname from-string))
- (n 1)
- (symlist (list 'emailname 'initials 'firstname 'lastname)))
-
- ;; put basic information
- (aput 'sc-gal-attributions 'firstname firstname)
- (aput 'sc-gal-attributions 'lastname lastname)
- (aput 'sc-gal-attributions 'emailname emailname)
- (aput 'sc-gal-attributions 'initials initials)
-
- (aput 'sc-gal-information "sc-firstname" firstname)
- (aput 'sc-gal-information "sc-lastname" lastname)
- (aput 'sc-gal-information "sc-emailname" emailname)
- (aput 'sc-gal-information "sc-initials" initials)
-
- ;; put middle names and build sc-author entry
- (let ((author (concat firstname " ")))
- (while midnames
- (let ((name (car midnames))
- (next (cdr midnames))
- (symbol (intern (format "middlename%d" n)))
- (string (format "sc-middlename-%d" n)))
- ;; first put new middlename
- (aput 'sc-gal-attributions symbol name)
- (aput 'sc-gal-information string name)
- (setq n (1+ n))
- (nconc symlist (list symbol))
-
- ;; now build author name
- (setq author (concat author name " "))
-
- ;; incr loop
- (setq midnames next)
- ))
- (setq author (concat author lastname))
-
- ;; put author name and email address
- (aput 'sc-gal-information "sc-author" author)
- (aput 'sc-gal-information "sc-from-address"
- (sc-get-address from-string author))
- (aput 'sc-gal-information "sc-reply-address"
- (sc-get-address (sc-field "reply-to") author))
- )
- ;; return value
- symlist))
-
-(defun sc-sort-attribution-alist ()
- "Put preferred attribution at head of attributions alist."
- (asort 'sc-gal-attributions sc-preferred-attribution)
-
- ;; use backup scheme if preference is not legal
- (if (or (null sc-preferred-attribution)
- (anot-head-p sc-gal-attributions sc-preferred-attribution)
- (let ((prefval (aget sc-gal-attributions
- sc-preferred-attribution)))
- (or (null prefval)
- (string= prefval ""))))
- ;; no legal attribution
- (if sc-use-only-preference-p
- (aput 'sc-gal-attributions 'sc-user-query
- (sc-query sc-default-attribution))
- ;; else use secondary scheme
- (asort 'sc-gal-attributions 'firstname))))
-
-(defun sc-build-attribution-alist (from-string)
- "Extract attributions from FROM-STRING, applying preferences."
- (let ((symlist (sc-populate-alists from-string))
- (headval (progn (sc-sort-attribution-alist)
- (aget sc-gal-attributions
- (aheadsym sc-gal-attributions) t))))
-
- ;; for each element in the symlist, remove the corresponding
- ;; key-value pair in the alist, then insert just the value.
- (while symlist
- (let ((value (aget sc-gal-attributions (car symlist) t))
- (next (cdr symlist)))
- (if (not (or (null value)
- (string= value "")))
- (aput 'sc-gal-attributions value))
- (adelete 'sc-gal-attributions (car symlist))
- (setq symlist next)))
-
- ;; add nicknames to the completion list
- (let ((gal sc-gal-attributions))
- (while gal
- (let ((nns sc-nicknames-alist)
- (galname (car (car gal))))
- (while nns
- (if (string= galname (car (car nns)))
- (aput 'sc-gal-attributions (car (cdr (car nns)))))
- (setq nns (cdr nns)))
- (setq gal (cdr gal)))))
-
- ;; now reinsert the head (preferred) attribution unless it is nil,
- ;; this effectively just moves the head value to the front of the
- ;; list.
- (if headval
- (aput 'sc-gal-attributions headval))
-
- ;; check to be sure alist is not nil
- (if (null sc-gal-attributions)
- (aput 'sc-gal-attributions sc-default-attribution))))
-
-(defun sc-select ()
- "Select an attribution and create a citation string."
- (cond
- (sc-nested-citation-p
- (sc-update-gal ""))
- ((null (aget sc-gal-information "from" t))
- (aput 'sc-gal-information "sc-author" sc-default-author-name)
- (sc-update-gal (sc-query sc-default-attribution)))
- ((null sc-gal-attributions)
- (sc-build-attribution-alist (aget sc-gal-information "from" t))
- (sc-confirm)
- (sc-update-gal (aheadsym sc-gal-attributions)))
- (t
- (sc-confirm)
- (sc-update-gal (aheadsym sc-gal-attributions))))
- t)
-
-\f
-;; ======================================================================
-;; region citing and unciting
-
-(defun sc-cite-region (start end)
- "Cite a region delineated by START and END."
- (save-excursion
- ;; set real end-of-region
- (goto-char end)
- (forward-line 1)
- (set-mark (point))
- ;; goto real beginning-of-region
- (goto-char start)
- (beginning-of-line)
- (let ((fstart (point))
- (fend (point)))
- (while (< (point) (sc-mark))
- ;; remove leading whitespace if desired
- (and sc-fixup-whitespace-p
- (fixup-whitespace))
- ;; if end of line then perhaps autofill
- (cond ((eolp)
- (or (= fstart fend)
- (not sc-auto-fill-region-p)
- (and sc-auto-fill-query-each-paragraph-p
- (not (y-or-n-p "Fill this paragraph? ")))
- (save-excursion (set-mark fend)
- (goto-char (/ (+ fstart fend 1) 2))
- (run-hooks 'sc-fill-paragraph-hook)))
- (setq fstart (point)
- fend (point)))
- ;; not end of line so perhaps cite it
- ((not (looking-at sc-cite-regexp))
- (insert (aget sc-gal-information "sc-citation")))
- (sc-nested-citation-p
- (insert (aget sc-gal-information "sc-nested-citation"))))
- (setq fend (point))
- (forward-line 1))
- (and sc-auto-fill-query-each-paragraph-p
- (message " "))
- )))
-
-(defun sc-uncite-region (start end cite-regexp)
- "Uncite a previously cited region delineated by START and END.
-CITE-REGEXP describes how a cited line of texts starts. Unciting also
-auto-fills paragraph if sc-auto-fill-region-p is non-nil."
- (save-excursion
- (set-mark end)
- (goto-char start)
- (beginning-of-line)
- (let ((fstart (point))
- (fend (point)))
- (while (< (point) (sc-mark))
- ;; if end of line, then perhaps autofill
- (cond ((eolp)
- (or (= fstart fend)
- (not sc-auto-fill-region-p)
- (and sc-auto-fill-query-each-paragraph-p
- (not (y-or-n-p "Fill this paragraph? ")))
- (save-excursion (set-mark fend)
- (goto-char (/ (+ fstart fend 1) 2))
- (run-hooks 'sc-fill-paragraph-hook)))
- (setq fstart (point)
- fend (point)))
- ;; not end of line so perhaps uncite it
- ((looking-at cite-regexp)
- (save-excursion
- (save-restriction
- (narrow-to-region (sc-linepos 'bol) (sc-linepos))
- (beginning-of-line)
- (delete-region (point-min)
- (progn (re-search-forward cite-regexp
- (point-max)
- t)
- (match-end 0)))))))
- (setq fend (point))
- (forward-line 1)))))
-
-\f
-;; ======================================================================
-;; this section contains paragraph filling support
-
-(defun sc-guess-fill-prefix (&optional literalp)
- "Guess the fill prefix used on the current line.
-Use various heuristics to find the fill prefix. Search begins on first
-non-blank line after point.
-
- 1) If fill-prefix is already bound to the empty string, return
- nil.
-
- 2) If fill-prefix is already bound, but not to the empty
- string, return the value of fill-prefix.
-
- 3) If the current line starts with the last chosen citation
- string, then that string is returned.
-
- 4) If the current line starts with a string matching the regular
- expression sc-cite-regexp, return the match. Note that if
- optional LITERALP is provided and non-nil, then the *string*
- that matches the regexp is return. Otherwise, if LITERALP is
- not provided or is nil, the *regexp* sc-cite-regexp is
- returned.
-
- 5) If the current line starts with any number of characters,
- followed by the sc-citation-delimiter and then white space,
- that match is returned. See comment #4 above for handling of
- LITERALP.
-
- 6) Nil is returned."
- (save-excursion
- ;; scan for first non-blank line in the region
- (beginning-of-line)
- (skip-chars-forward "\n\t ")
- (beginning-of-line)
- (let ((citation (aget sc-gal-information "sc-citation"))
- (generic-citation
- (concat "\\s *[^ \t\n" sc-citation-delimiter "]+>\\s +")))
- (cond
- ((string= fill-prefix "") nil) ;; heuristic #1
- (fill-prefix) ;; heuristic #2
- ((looking-at (regexp-quote citation)) citation) ;; heuristic #3
- ((looking-at sc-cite-regexp) ;; heuristic #4
- (if literalp
- (buffer-substring
- (point)
- (progn (re-search-forward (concat sc-cite-regexp "\\s *")
- (point-max) nil)
- (point)))
- sc-cite-regexp))
- ((looking-at generic-citation) ;; heuristic #5
- (if literalp
- (buffer-substring
- (point)
- (progn (re-search-forward generic-citation) (point)))
- generic-citation))
- (t nil))))) ;; heuristic #6
-
-(defun sc-consistent-cite-p (prefix)
- "Check current paragraph for consistent citation.
-Scans to paragraph delineated by (forward|backward)-paragraph to see
-if all lines start with PREFIX. Returns t if entire paragraph is
-consistently cited, nil otherwise."
- (save-excursion
- (let ((end (progn (forward-paragraph)
- (beginning-of-line)
- (or (not (eolp))
- (forward-char -1))
- (point)))
- (start (progn (backward-paragraph)
- (beginning-of-line)
- (or (not (eolp))
- (forward-char 1))
- (point)))
- (badline t))
- (goto-char start)
- (beginning-of-line)
- (while (and (< (point) end)
- badline)
- (setq badline (looking-at prefix))
- (forward-line 1))
- badline)))
-
-(defun sc-fill-start (fill-prefix)
- "Find buffer position of start of region which begins with FILL-PREFIX.
-Restrict scan to current paragraph."
- (save-excursion
- (let ((badline nil)
- (top (save-excursion
- (backward-paragraph)
- (beginning-of-line)
- (or (not (eolp))
- (forward-char 1))
- (point))))
- (while (and (not badline)
- (> (point) top))
- (forward-line -1)
- (setq badline (not (looking-at fill-prefix)))))
- (forward-line 1)
- (point)))
-
-(defun sc-fill-end (fill-prefix)
- "Find the buffer position of end of region which begins with FILL-PREFIX.
-Restrict scan to current paragraph."
- (save-excursion
- (let ((badline nil)
- (bot (save-excursion
- (forward-paragraph)
- (beginning-of-line)
- (or (not (eolp))
- (forward-char -1))
- (point))))
- (while (and (not badline)
- (< (point) bot))
- (beginning-of-line)
- (setq badline (not (looking-at fill-prefix)))
- (forward-line 1)))
- (forward-line -1)
- (point)))
-
-(defun sc-fill-paragraph ()
- "Supercite's paragraph fill function.
-Fill the paragraph containing or following point. Use
-sc-guess-fill-prefix to find the fill-prefix for the paragraph.
-
-If the paragraph is inconsistently cited (mixed fill-prefix), then the
-user is queried to restrict the the fill to only those lines around
-point which begin with the fill prefix.
-
-The variable sc-fill-arg is passed to fill-paragraph and
-fill-region-as-paragraph which controls justification of the
-paragraph. sc-fill-arg is set by sc-fill-paragraph-manually."
- (save-excursion
- (let ((pnt (point))
- (fill-prefix (sc-guess-fill-prefix t)))
- (cond
- ((not fill-prefix)
- (fill-paragraph sc-fill-arg))
- ((sc-consistent-cite-p fill-prefix)
- (fill-paragraph sc-fill-arg))
- ((y-or-n-p "Inconsistent citation found. Restrict? ")
- (message "")
- (fill-region-as-paragraph (progn (goto-char pnt)
- (sc-fill-start fill-prefix))
- (progn (goto-char pnt)
- (sc-fill-end fill-prefix))
- sc-fill-arg))
- (t
- (message "")
- (progn
- (setq fill-prefix (aget sc-gal-information "sc-citation"))
- (fill-paragraph sc-fill-arg)))))))
-
-\f
-;; ======================================================================
-;; the following functions are the top level, interactive commands that
-;; can be bound to key strokes
-
-(defun sc-insert-reference (arg)
- "Insert, at point, a reference header in the body of the reply.
-Numeric ARG indicates which header style from sc-rewrite-header-list
-to use when rewriting the header. No supplied ARG indicates use of
-sc-preferred-header-style.
-
-With just \\[universal-argument], electric reference insert mode is
-entered, regardless of the value of sc-electric-references-p. See
-sc-electric-mode for more information."
- (interactive "P")
- (if (consp arg)
- (sc-electric-mode)
- (let ((pref (cond ((sc-valid-index-p arg) arg)
- ((sc-valid-index-p sc-preferred-header-style)
- sc-preferred-header-style)
- (t 0))))
- (if sc-electric-references-p (sc-electric-mode pref)
- (condition-case err
- (eval (nth pref sc-rewrite-header-list))
- (void-function
- (progn (message
- "Symbol's function definition is void: %s. (Header %d)."
- (symbol-name (car (cdr err)))
- pref)
- (beep)))
- (error
- (progn (message "Error evaluating rewrite header function %d."
- pref)
- (beep)))
- )))))
-
-(defun sc-cite (arg)
- "Cite the region of text between point and mark.
-Numeric ARG, if supplied, is passed unaltered to sc-insert-reference."
- (interactive "P")
- (if (not (sc-mark))
- (error "Please designate a region to cite (i.e. set the mark)."))
- (catch 'select-abort
- (let ((sc-cite-context 'citing)
- (sc-force-confirmation-p (interactive-p)))
- (sc-select)
- (undo-boundary)
- (let ((xchange (if (> (sc-mark) (point)) nil
- (exchange-point-and-mark)
- t)))
- (sc-insert-reference arg)
- (sc-cite-region (point) (sc-mark))
- ;; leave point on first cited line
- (while (and (< (point) (sc-mark))
- (not (looking-at (aget sc-gal-information
- (if sc-nested-citation-p
- "sc-nested-citation"
- "sc-citation")))))
- (forward-line 1))
- (and xchange
- (exchange-point-and-mark))
- ))))
-
-(defun sc-uncite ()
- "Uncite the region between point and mark."
- (interactive)
- (if (not (sc-mark))
- (error "Please designate a region to uncite (i.e. set the mark)."))
- (undo-boundary)
- (let ((xchange (if (> (sc-mark) (point)) nil
- (exchange-point-and-mark)
- t))
- (fp (or (sc-guess-fill-prefix)
- "")))
- (sc-uncite-region (point) (sc-mark) fp)
- (and xchange
- (exchange-point-and-mark))))
-
-(defun sc-recite ()
- "Recite the region by first unciting then citing the text."
- (interactive)
- (if (not (sc-mark))
- (error "Please designate a region to recite (i.e. set the mark)."))
- (catch 'select-abort
- (let ((sc-cite-context 'reciting)
- (sc-force-confirmation-p t))
- (sc-select)
- (undo-boundary)
- (let ((xchange (if (> (sc-mark) (point)) nil
- (exchange-point-and-mark)
- t))
- (fp (or (sc-guess-fill-prefix)
- "")))
- (sc-uncite-region (point) (sc-mark) fp)
- (sc-cite-region (point) (sc-mark))
- (and xchange
- (exchange-point-and-mark))
- ))))
-
-(defun sc-insert-citation ()
- "Insert citation string at beginning of current line."
- (interactive)
- (save-excursion
- (beginning-of-line)
- (insert (aget sc-gal-information "sc-citation"))))
-
-(defun sc-open-line (arg)
- "Insert a newline and leave point before it.
-Also inserts the guessed prefix at the beginning of the new line. With
-numeric ARG, inserts that many new lines."
- (interactive "p")
- (save-excursion
- (let ((start (point))
- (string (or (sc-guess-fill-prefix t)
- "")))
- (open-line arg)
- (goto-char start)
- (forward-line 1)
- (while (< 0 arg)
- (insert string)
- (forward-line 1)
- (setq arg (- arg 1))))))
-
-(defun sc-fill-paragraph-manually (arg)
- "Fill current cited paragraph.
-Really just runs the hook sc-fill-paragraph-hook, however it does set
-the global variable sc-fill-arg to the value of ARG. This is
-currently the only way to pass an argument to a hookified function."
- (interactive "P")
- (setq sc-fill-arg arg)
- (run-hooks 'sc-fill-paragraph-hook))
-
-(defun sc-modify-information (arg)
- "Interactively modify information in the information alist.
-\\[universal-argument] if supplied, deletes the entry from the alist.
-You can add an entry by supplying a key instead of completing."
- (interactive "P")
- (let* ((delete-p (consp arg))
- (action (if delete-p "delete" "modify"))
- (defaultkey (aheadsym sc-gal-information))
- (prompt (concat "Select information key to "
- action ": (default "
- defaultkey ") "))
- (key (completing-read prompt sc-gal-information))
- )
- (if (or (string= key "")
- (null key))
- (setq key defaultkey))
- (if delete-p (adelete 'sc-gal-information key)
- (let* ((oldval (aget sc-gal-information key t))
- (prompt (concat "Enter new value for key \""
- key "\" (default \"" oldval "\") "))
- (newval (read-input prompt)))
- (if (or (string= newval "")
- (null newval))
- nil
- (aput 'sc-gal-information key newval)
- )))))
-
-(defun sc-view-field (arg)
- "View field values in the information alist.
-This is essentially an interactive version of sc-field, and is similar
-to sc-modify-information, except that the field values can't be
-modified. With \\[universal-argument], if supplied, inserts the value
-into the current buffer as well."
- (interactive "P")
- (let* ((defaultkey (aheadsym sc-gal-information))
- (prompt (concat "View information key: (default "
- defaultkey ") "))
- (key (completing-read prompt sc-gal-information)))
- (if (or (string= key "")
- (null key))
- (setq key defaultkey))
- (let* ((val (aget sc-gal-information key t))
- (pval (if val (concat "\"" val "\"") "nil")))
- (message "value of key %s: %s" key pval)
- (if (and key (consp arg)) (insert val)))))
-
-(defun sc-glom-headers ()
- "Glom information from mail headers in region between point and mark.
-Any old information is lost, unless an error occurs."
- (interactive)
- (let ((attr (copy-sequence sc-gal-attributions))
- (info (copy-sequence sc-gal-information)))
- (setq sc-gal-attributions nil
- sc-gal-information nil)
- (let (start end
- (sc-force-confirmation-p t)
- (sc-cite-context nil))
- (let ((mark-active t))
- (setq start (region-beginning)
- end (region-end)))
- (sc-fetch-fields start end)
- (if (null sc-gal-information)
- (progn
- (message "No mail headers found! Restoring old information.")
- (setq sc-gal-attributions attr
- sc-gal-information info))
- (sc-mail-yank-clear-headers start end)
- (if (not (catch 'select-abort
- (condition-case foo
- (sc-select)
- (quit (beep) (throw 'select-abort nil)))
- ))
- (setq sc-gal-attributions attr
- sc-gal-information info))
- ))))
-
-(defun sc-version (arg)
- "Show supercite version.
-Universal argument (\\[universal-argument]) ARG inserts version
-information in the current buffer instead of printing the message in
-the echo area."
- (interactive "P")
- (if (consp arg)
- (insert "Using Supercite version " sc-version-number)
- (message "Using Supercite version %s" sc-version-number)))
-
-\f
-;; ======================================================================
-;; leach onto current mode
-
-(defun sc-append-current-keymap ()
- "Append some useful key bindings to the current local key map.
-This searches sc-local-keymap for the keymap to install based on the
-major-mode of the current buffer."
- (let ((hook (car (cdr (assq major-mode sc-local-keymaps)))))
- (cond
- ((not hook)
- (run-hooks 'sc-default-keymap))
- ((not (listp hook))
- (setq hook (car (cdr (assq hook sc-local-keymaps))))
- (run-hooks 'hook))
- (t
- (run-hooks 'hook))))
- (setq sc-leached-keymap (current-local-map)))
-
-(defun sc-snag-all-keybindings ()
- "Snag all keybindings in major-mode's current keymap."
- (let* ((curkeymap (current-local-map))
- (symregexp ".*sc-.*\n")
- (docstring (substitute-command-keys "\\{curkeymap}"))
- (start 0)
- (maxend (length docstring))
- (spooge ""))
- (while (and (< start maxend)
- (string-match symregexp docstring start))
- (setq spooge (concat spooge (substring docstring
- (match-beginning 0)
- (match-end 0))))
- (setq start (match-end 0)))
- spooge))
-
-(defun sc-spoogify-docstring ()
- "Modifies (makes into spooge) the docstring for the current major mode.
-This will leach the keybinding descriptions for supercite onto the end
-of the current major mode's docstring. If major mode is preloaded,
-this function will first make a copy of the list associated with the
-mode, then modify this copy."
- (let* ((symfunc (symbol-function major-mode))
- (doc-cdr (and (listp symfunc) (nthcdr 2 symfunc)))
- (doc-str (documentation major-mode)))
- (cond
- ;; is a docstring even provided?
- ((not (stringp doc-str)))
- ;; have we already leached on?
- ((string-match "Supercite" doc-str))
- ;; lets build the new doc string
- (t
- (let* ((described (sc-snag-all-keybindings))
- (commonstr "
-
-The major mode for this buffer has been modified to include the
-Supercite 2.3 package for handling attributions and citations of
-original messages in email replies. For more information on this
-package, type \"\\[sc-describe]\".")
- (newdoc-str
- (concat doc-str commonstr
- (if (not (string= described ""))
- (concat "\n\nThe following keys are bound "
- "to Supercite commands:\n\n"
- described)))
- ))
- (cond
- (doc-cdr
- (condition-case nil
- (setcar doc-cdr newdoc-str)
- (error
- ;; the major mode must be preloaded, make a copy first
- (setq symfunc (copy-sequence (symbol-function major-mode))
- doc-cdr (nthcdr 2 symfunc))
- (setcar doc-cdr newdoc-str)
- (fset major-mode symfunc))))
- ;; lemacs 19 byte-code.
- ;; Set function to a new byte-code vector with the
- ;; new documentation in the documentation slot (element 4).
- ;; We can't use aset because aset won't allow you to modify
- ;; a byte-code vector.
- ;; Include element 5 if the vector has one.
- (t
- (fset major-mode
- (apply 'make-byte-code
- (aref symfunc 0) (aref symfunc 1)
- (aref symfunc 2) (aref symfunc 3)
- newdoc-str
- (if (> (length symfunc) 5)
- (list (aref symfunc 5)))))
- )))))))
-
-\f
-;; ======================================================================
-;; this section contains default hooks and hook support for execution
-
-;;;###autoload
-(defun sc-cite-original ()
- "Hook version of sc-cite.
-This is callable from the various mail and news readers' reply
-function according to the agreed upon standard. See \\[sc-describe]
-for more details. Sc-cite-original does not do any yanking of the
-original message but it does require a few things:
-
- 1) The reply buffer is the current buffer.
-
- 2) The original message has been yanked and inserted into the
- reply buffer.
-
- 3) Verbose mail headers from the original message have been
- inserted into the reply buffer directly before the text of the
- original message.
-
- 4) Point is at the beginning of the verbose headers.
-
- 5) Mark is at the end of the body of text to be cited."
- (run-hooks 'sc-pre-hook)
- (setq sc-gal-attributions nil)
- (setq sc-gal-information nil)
- (let (start end)
- (let ((mark-active t))
- (setq start (region-beginning)
- end (region-end)))
- (sc-fetch-fields start end)
- (sc-mail-yank-clear-headers start end)
- (if (not sc-all-but-cite-p)
- (sc-cite sc-preferred-header-style))
- (sc-append-current-keymap)
- (sc-spoogify-docstring)
- (run-hooks 'sc-post-hook)))
-
-\f
-;; ======================================================================
-;; describe this package
-;;
-(defun sc-describe ()
- "Supercite version 2.3 is now described in a texinfo manual which
-makes the documentation available both for online perusal via emacs'
-info system, or for hard-copy printing using the TeX facility.
-
-To view the online document hit \\[info], then \"mSupercite <RET>\"."
- (interactive)
- (describe-function 'sc-describe))
-
-;; ======================================================================
-;; load hook
-(run-hooks 'sc-load-hook)
-(provide 'sc)
+++ /dev/null
-;; -*- Mode: Emacs-Lisp -*-
-;; sc-elec.el -- Version 2.3
-
-;; ========== Introduction ==========
-;; This file contains sc-electric mode for viewing reference headers.
-;; It is loaded automatically by supercite.el when needed.
-
-;; ========== Disclaimer ==========
-;; This software 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.
-
-;; Some of this software was written as part of the supercite author's
-;; official duty as an employee of the United States Government and is
-;; thus in the public domain. You are free to use that particular
-;; software as you wish, but WITHOUT ANY WARRANTY WHATSOEVER. It
-;; would be nice, though if when you use any of this code, you give
-;; due credit to the author.
-
-;; Other parts of this code were written by other people. Wherever
-;; possible, credit to that author, and the copy* notice supplied by
-;; the author are included with that code. In all cases, the spirit,
-;; if not the letter of the GNU General Public Licence applies.
-
-;; ========== Author (unless otherwise stated) ==========
-;; NAME: Barry A. Warsaw USMAIL: Century Computing, Inc.
-;; TELE: (301) 593-3330 1014 West Street
-;; UUCP: uunet!cen.com!bwarsaw Laurel, MD 20707
-;; INET: bwarsaw@cen.com
-
-;; Want to be on the Supercite mailing list?
-;;
-;; Send articles to:
-;; INET: supercite@anthem.nlm.nih.gov
-;; UUCP: uunet!anthem.nlm.nih.gov!supercite
-;;
-;; Send administrivia (additions/deletions to list, etc) to:
-;; INET: supercite-request@anthem.nlm.nih.gov
-;; UUCP: uunet!anthem.nlm.nih.gov!supercite-request
-;;
-(provide 'sc-elec)
-
-
-;; ======================================================================
-;; set up vars for major mode
-
-(defconst sc-electric-bufname "*sc-erefs*"
- "*Supercite's electric buffer name.")
-
-
-(defvar sc-electric-mode-hook nil
- "*Hook for sc-electric-mode.")
-
-
-\f
-;; ======================================================================
-;; sc-electric-mode
-
-(defun sc-electric-mode (&optional arg)
- "Quasi major mode for viewing supercite reference headers.
-Commands are: \\{sc-electric-mode-map}
-Sc-electric-mode is not intended to be run interactively, but rather
-accessed through supercite's electric reference feature. See
-sc-insert-reference for more details. Optional ARG is the initial
-header style to use, unless not supplied or invalid, in which case
-sc-preferred-header-style is used."
- (let ((gal sc-gal-information)
- (sc-eref-style (if arg ;; assume passed arg is okay
- arg
- (if (and (natnump sc-preferred-header-style)
- (sc-valid-index-p sc-preferred-header-style))
- sc-preferred-header-style
- 0))))
- (get-buffer-create sc-electric-bufname)
- ;; set up buffer and enter command loop
- (save-excursion
- (save-window-excursion
- (pop-to-buffer sc-electric-bufname)
- (kill-all-local-variables)
- (setq sc-gal-information gal
- buffer-read-only t
- mode-name "Supercite-Electric-References"
- major-mode 'sc-electric-mode)
- (use-local-map sc-electric-mode-map)
- (sc-eref-show sc-eref-style)
- (run-hooks 'sc-electric-mode-hook)
- (recursive-edit)
- ))
- (if sc-eref-style
- (condition-case nil
- (eval (nth sc-eref-style sc-rewrite-header-list))
- (error nil)
- ))
- ;; now restore state
- (kill-buffer sc-electric-bufname)
- ))
-
-
-\f
-;; ======================================================================
-;; functions for electric mode
-
-(defun sc-eref-index (index)
- "Check INDEX to be sure it is a valid index into sc-rewrite-header-list.
-If sc-electric-circular-p is non-nil, then list is considered circular
-so that movement across the ends of the list wraparound."
- (let ((last (1- (length sc-rewrite-header-list))))
- (cond ((sc-valid-index-p index) index)
- ((< index 0)
- (if sc-electric-circular-p last
- (progn (error "No preceding reference headers in list.") 0)))
- ((> index last)
- (if sc-electric-circular-p 0
- (progn (error "No following reference headers in list.") last)))
- )
- ))
-
-
-(defun sc-eref-show (index)
- "Show reference INDEX in sc-rewrite-header-list."
- (setq sc-eref-style (sc-eref-index index))
- (save-excursion
- (set-buffer sc-electric-bufname)
- (let ((ref (nth sc-eref-style sc-rewrite-header-list))
- (buffer-read-only nil))
- (erase-buffer)
- (goto-char (point-min))
- (condition-case err
- (progn
- (set-mark (point-min))
- (eval ref)
- (message "Showing reference header %d." sc-eref-style)
- (goto-char (point-max))
- )
- (void-function
- (progn (message
- "Symbol's function definition is void: %s (Header %d)"
- (symbol-name (car (cdr err)))
- sc-eref-style)
- (beep)
- ))
- ))))
-
-
-\f
-;; ======================================================================
-;; interactive commands
-
-(defun sc-eref-next ()
- "Display next reference in other buffer."
- (interactive)
- (sc-eref-show (1+ sc-eref-style)))
-
-
-(defun sc-eref-prev ()
- "Display previous reference in other buffer."
- (interactive)
- (sc-eref-show (1- sc-eref-style)))
-
-
-(defun sc-eref-setn ()
- "Set reference header selected as preferred."
- (interactive)
- (setq sc-preferred-header-style sc-eref-style)
- (message "Preferred reference style set to header %d." sc-eref-style))
-
-
-(defun sc-eref-goto (refnum)
- "Show reference style indexed by REFNUM.
-If REFNUM is an invalid index, don't go to that reference and return
-nil."
- (interactive "NGoto Reference: ")
- (if (sc-valid-index-p refnum)
- (sc-eref-show refnum)
- (error "Invalid reference: %d. (Range: [%d .. %d])"
- refnum 0 (1- (length sc-rewrite-header-list)))
- ))
-
-
-(defun sc-eref-jump ()
- "Set reference header to preferred header."
- (interactive)
- (sc-eref-show sc-preferred-header-style))
-
-
-(defun sc-eref-abort ()
- "Exit from electric reference mode without inserting reference."
- (interactive)
- (setq sc-eref-style nil)
- (exit-recursive-edit))
-
-
-(defun sc-eref-exit ()
- "Exit from electric reference mode and insert selected reference."
- (interactive)
- (exit-recursive-edit))
+++ /dev/null
-;;; setaddr.el --- determine whether sendmail is configured on this machine
-
-;; Copyright (C) 1997 Free Software Foundation, Inc.
-
-;; Maintainer: FSF
-;; Keywords: mail
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;;; Commentary:
-
-;; If neither sendmail nor Emacs knows what host address to use
-;; for this machine, ask for it, and save it in site-start.el
-;; so we won't have to ask again.
-
-;; This uses a heuristic about the output from sendmail
-;; which may or may not really work. We will have to find
-;; out by experiment.
-
-;;; Code:
-
-(or mail-host-address
- (let (sendmail-configured)
- (with-temp-buffer " mail-host-address"
- (call-process sendmail-program nil t nil "-bv" "root")
- (goto-char (point-min))
- (setq sendmail-configured (looking-at "root@")))
- (or sendmail-configured
- (let (buffer)
- (setq mail-host-address
- (read-string "Specify your host's fully qualified domain name: ")))
- ;; Create an init file, and if we just read mail-host-address,
- ;; make the init file set it.
- (unwind-protect
- (save-excursion
- (set-buffer (find-file-noselect "site-start.el"))
- (setq buffer (current-buffer))
- ;; Get rid of the line that ran this file.
- (if (search-forward "(load \"setaddr\")\n")
- (progn
- (beginning-of-line)
- (delete-region (point)
- (progn (end-of-line)
- (point)))))
- ;; Add the results
- (goto-char (point-max))
- (insert "\n(setq mail-host-address "
- (prin1-to-string mail-host-address)
- ")\n")
- (condition-case nil
- (save-buffer)
- (file-error nil)))
- (if buffer
- (kill-buffer buffer))))))
-
-;;; setaddr.el ends here
+++ /dev/null
-;;; sun-keys.el --- support for Sun function keys
-
-;;; Copyright (C) 1986 Free Software Foundation, Inc.
-
-;; Author: Ian G. Batten <batten@uk.ac.bham.multics>
-;; Keywords: terminals
-
-;;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to
-;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;;; Commentary:
-
-;;; Support (cleanly) for Sun function keys. Provides help facilities,
-;;; better diagnostics, etc.
-;;;
-;;; To use: make sure your .ttyswrc binds 'F1' to <ESC> * F1 <CR> and so on.
-;;; load this lot from your start_up
-
-;;; Code:
-
-(defun sun-function-keys-dispatch (arg)
- "Dispatcher for function keys."
- (interactive "p")
- (let* ((key-stroke (read t))
- (command (assq key-stroke sun-function-keys-command-list)))
- (cond (command (funcall (cdr command) arg))
- (t (error "Unbound function key %s" key-stroke)))))
-
-(defvar sun-function-keys-command-list
- '((F1 . sun-function-keys-describe-bindings)
- (R8 . previous-line) ; arrow keys
- (R10 . backward-char)
- (R12 . forward-char)
- (R14 . next-line)))
-
-(defun sun-function-keys-bind-key (arg1 arg2)
- "Bind a specified key."
- (interactive "xFunction Key Cap Label:
-CCommand To Use:")
- (setq sun-function-keys-command-list
- (cons (cons arg1 arg2) sun-function-keys-command-list)))
-
-(defun sun-function-keys-describe-bindings (arg)
- "Describe the function key bindings we're running"
- (interactive)
- (with-output-to-temp-buffer "*Help*"
- (sun-function-keys-write-bindings
- (sort (copy-sequence sun-function-keys-command-list)
- '(lambda (x y) (string-lessp (car x) (car y)))))))
-
-(defun sun-function-keys-write-bindings (list)
- (cond ((null list)
- t)
- (t
- (princ (format "%s: %s\n"
- (car (car list))
- (cdr (car list))))
- (sun-function-keys-write-bindings (cdr list)))))
-
-(global-set-key "\e*" 'sun-function-keys-dispatch)
-
-(make-variable-buffer-local 'sun-function-keys-command-list)
-
-;;; sun-keys.el ends here
+++ /dev/null
-;;; superyank.el --- smart message-yanking code for GNUS
-
-;; Copyright (C) 1992 Free Software Foundation, Inc.
-
-;; Author: Barry A. Warsaw <warsaw@cme.nist.gov>
-;; Version: 1.1
-;; Adapted-By: ESR
-;; Keywords: news
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to
-;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;;; Commentary:
-
-;; 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 Emacs Lisp
-;; 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
-;;
-
-;;; Code:
-
-;; ======================================================================
-;;
-;; require and provide features
-;;
-(require 'sendmail)
-;;
-;; ======================================================================
-;;
-;; 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.
-This automatically finds the sy-cite-regexp and uses 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.
-This inserts the peristant 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 argument, inserts ARG 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))))))
-
-(provide 'superyank)
-
-;;; superyank.el ends here
+++ /dev/null
-;;; timer.el --- run a function with args at some time in future.
-
-;; Copyright (C) 1996 Free Software Foundation, Inc.
-
-;; Maintainer: FSF
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;;; Commentary:
-
-;; This package gives you the capability to run Emacs Lisp commands at
-;; specified times in the future, either as one-shots or periodically.
-
-;;; Code:
-
-;; Layout of a timer vector:
-;; [triggered-p high-seconds low-seconds usecs repeat-delay
-;; function args idle-delay]
-
-(defun timer-create ()
- "Create a timer object."
- (let ((timer (make-vector 8 nil)))
- (aset timer 0 t)
- timer))
-
-(defun timerp (object)
- "Return t if OBJECT is a timer."
- (and (vectorp object) (= (length object) 8)))
-
-(defun timer-set-time (timer time &optional delta)
- "Set the trigger time of TIMER to TIME.
-TIME must be in the internal format returned by, e.g., `current-time'.
-If optional third argument DELTA is a non-zero integer, make the timer
-fire repeatedly that many seconds apart."
- (or (timerp timer)
- (error "Invalid timer"))
- (aset timer 1 (car time))
- (aset timer 2 (if (consp (cdr time)) (car (cdr time)) (cdr time)))
- (aset timer 3 (or (and (consp (cdr time)) (consp (cdr (cdr time)))
- (nth 2 time))
- 0))
- (aset timer 4 (and (numberp delta) (> delta 0) delta))
- timer)
-
-(defun timer-set-idle-time (timer secs &optional repeat)
- "Set the trigger idle time of TIMER to SECS.
-If optional third argument REPEAT is non-nil, make the timer
-fire each time Emacs is idle for that many seconds."
- (or (timerp timer)
- (error "Invalid timer"))
- (aset timer 1 0)
- (aset timer 2 0)
- (aset timer 3 0)
- (timer-inc-time timer secs)
- (aset timer 4 repeat)
- timer)
-
-(defun timer-next-integral-multiple-of-time (time secs)
- "Yield the next value after TIME that is an integral multiple of SECS.
-More precisely, the next value, after TIME, that is an integral multiple
-of SECS seconds since the epoch. SECS may be a fraction."
- (let ((time-base (ash 1 16)))
- (if (fboundp 'atan)
- ;; Use floating point, taking care to not lose precision.
- (let* ((float-time-base (float time-base))
- (million 1000000.0)
- (time-usec (+ (* million
- (+ (* float-time-base (nth 0 time))
- (nth 1 time)))
- (nth 2 time)))
- (secs-usec (* million secs))
- (mod-usec (mod time-usec secs-usec))
- (next-usec (+ (- time-usec mod-usec) secs-usec))
- (time-base-million (* float-time-base million)))
- (list (floor next-usec time-base-million)
- (floor (mod next-usec time-base-million) million)
- (floor (mod next-usec million))))
- ;; Floating point is not supported.
- ;; Use integer arithmetic, avoiding overflow if possible.
- (let* ((mod-sec (mod (+ (* (mod time-base secs)
- (mod (nth 0 time) secs))
- (nth 1 time))
- secs))
- (next-1-sec (+ (- (nth 1 time) mod-sec) secs)))
- (list (+ (nth 0 time) (floor next-1-sec time-base))
- (mod next-1-sec time-base)
- 0)))))
-
-(defun timer-relative-time (time secs &optional usecs)
- "Advance TIME by SECS seconds and optionally USECS microseconds.
-SECS may be a fraction."
- (let ((high (car time))
- (low (if (consp (cdr time)) (nth 1 time) (cdr time)))
- (micro (if (numberp (car-safe (cdr-safe (cdr time))))
- (nth 2 time)
- 0)))
- ;; Add
- (if usecs (setq micro (+ micro usecs)))
- (if (floatp secs)
- (setq micro (+ micro (floor (* 1000000 (- secs (floor secs)))))))
- (setq low (+ low (floor secs)))
-
- ;; Normalize
- (setq low (+ low (/ micro 1000000)))
- (setq micro (mod micro 1000000))
- (setq high (+ high (/ low 65536)))
- (setq low (logand low 65535))
-
- (list high low (and (/= micro 0) micro))))
-
-(defun timer-inc-time (timer secs &optional usecs)
- "Increment the time set in TIMER by SECS seconds and USECS microseconds.
-SECS may be a fraction."
- (let ((time (timer-relative-time
- (list (aref timer 1) (aref timer 2) (aref timer 3))
- secs
- usecs)))
- (aset timer 1 (nth 0 time))
- (aset timer 2 (nth 1 time))
- (aset timer 3 (or (nth 2 time) 0))))
-
-(defun timer-set-time-with-usecs (timer time usecs &optional delta)
- "Set the trigger time of TIMER to TIME.
-TIME must be in the internal format returned by, e.g., `current-time'.
-If optional third argument DELTA is a non-zero integer, make the timer
-fire repeatedly that many seconds apart."
- (or (timerp timer)
- (error "Invalid timer"))
- (aset timer 1 (car time))
- (aset timer 2 (if (consp (cdr time)) (car (cdr time)) (cdr time)))
- (aset timer 3 usecs)
- (aset timer 4 (and (numberp delta) (> delta 0) delta))
- timer)
-
-(defun timer-set-function (timer function &optional args)
- "Make TIMER call FUNCTION with optional ARGS when triggering."
- (or (timerp timer)
- (error "Invalid timer"))
- (aset timer 5 function)
- (aset timer 6 args)
- timer)
-\f
-(defun timer-activate (timer)
- "Put TIMER on the list of active timers."
- (if (and (timerp timer)
- (integerp (aref timer 1))
- (integerp (aref timer 2))
- (integerp (aref timer 3))
- (aref timer 5))
- (let ((timers timer-list)
- last)
- ;; Skip all timers to trigger before the new one.
- (while (and timers
- (or (> (aref timer 1) (aref (car timers) 1))
- (and (= (aref timer 1) (aref (car timers) 1))
- (> (aref timer 2) (aref (car timers) 2)))
- (and (= (aref timer 1) (aref (car timers) 1))
- (= (aref timer 2) (aref (car timers) 2))
- (> (aref timer 3) (aref (car timers) 3)))))
- (setq last timers
- timers (cdr timers)))
- ;; Insert new timer after last which possibly means in front of queue.
- (if last
- (setcdr last (cons timer timers))
- (setq timer-list (cons timer timers)))
- (aset timer 0 nil)
- (aset timer 7 nil)
- nil)
- (error "Invalid or uninitialized timer")))
-
-(defun timer-activate-when-idle (timer &optional dont-wait)
- "Arrange to activate TIMER whenever Emacs is next idle.
-If optional argument DONT-WAIT is non-nil, then enable the
-timer to activate immediately, or at the right time, if Emacs
-is already idle."
- (if (and (timerp timer)
- (integerp (aref timer 1))
- (integerp (aref timer 2))
- (integerp (aref timer 3))
- (aref timer 5))
- (let ((timers timer-idle-list)
- last)
- ;; Skip all timers to trigger before the new one.
- (while (and timers
- (or (> (aref timer 1) (aref (car timers) 1))
- (and (= (aref timer 1) (aref (car timers) 1))
- (> (aref timer 2) (aref (car timers) 2)))
- (and (= (aref timer 1) (aref (car timers) 1))
- (= (aref timer 2) (aref (car timers) 2))
- (> (aref timer 3) (aref (car timers) 3)))))
- (setq last timers
- timers (cdr timers)))
- ;; Insert new timer after last which possibly means in front of queue.
- (if last
- (setcdr last (cons timer timers))
- (setq timer-idle-list (cons timer timers)))
- (aset timer 0 (not dont-wait))
- (aset timer 7 t)
- nil)
- (error "Invalid or uninitialized timer")))
-
-;;;###autoload
-(defalias 'disable-timeout 'cancel-timer)
-;;;###autoload
-(defun cancel-timer (timer)
- "Remove TIMER from the list of active timers."
- (or (timerp timer)
- (error "Invalid timer"))
- (setq timer-list (delq timer timer-list))
- (setq timer-idle-list (delq timer timer-idle-list))
- nil)
-
-;;;###autoload
-(defun cancel-function-timers (function)
- "Cancel all timers scheduled by `run-at-time' which would run FUNCTION."
- (interactive "aCancel timers of function: ")
- (let ((tail timer-list))
- (while tail
- (if (eq (aref (car tail) 5) function)
- (setq timer-list (delq (car tail) timer-list)))
- (setq tail (cdr tail))))
- (let ((tail timer-idle-list))
- (while tail
- (if (eq (aref (car tail) 5) function)
- (setq timer-idle-list (delq (car tail) timer-idle-list)))
- (setq tail (cdr tail)))))
-\f
-;; Record the last few events, for debugging.
-(defvar timer-event-last-2 nil)
-(defvar timer-event-last-1 nil)
-(defvar timer-event-last nil)
-
-(defvar timer-max-repeats 10
- "*Maximum number of times to repeat a timer, if real time jumps.")
-
-(defun timer-until (timer time)
- "Calculate number of seconds from when TIMER will run, until TIME.
-TIMER is a timer, and stands for the time when its next repeat is scheduled.
-TIME is a time-list."
- (let ((high (- (car time) (aref timer 1)))
- (low (- (nth 1 time) (aref timer 2))))
- (+ low (* high 65536))))
-
-(defun timer-event-handler (timer)
- "Call the handler for the timer TIMER.
-This function is called, by name, directly by the C code."
- (setq timer-event-last-2 timer-event-last-1)
- (setq timer-event-last-1 timer-event-last)
- (setq timer-event-last timer)
- (let ((inhibit-quit t))
- (if (timerp timer)
- (progn
- ;; Delete from queue.
- (cancel-timer timer)
- ;; Re-schedule if requested.
- (if (aref timer 4)
- (if (aref timer 7)
- (timer-activate-when-idle timer)
- (timer-inc-time timer (aref timer 4) 0)
- ;; If real time has jumped forward,
- ;; perhaps because Emacs was suspended for a long time,
- ;; limit how many times things get repeated.
- (if (and (numberp timer-max-repeats)
- (< 0 (timer-until timer (current-time))))
- (let ((repeats (/ (timer-until timer (current-time))
- (aref timer 4))))
- (if (> repeats timer-max-repeats)
- (timer-inc-time timer (* (aref timer 4) repeats)))))
- (timer-activate timer)))
- ;; Run handler.
- ;; We do this after rescheduling so that the handler function
- ;; can cancel its own timer successfully with cancel-timer.
- (condition-case nil
- (apply (aref timer 5) (aref timer 6))
- (error nil)))
- (error "Bogus timer event"))))
-
-;; This function is incompatible with the one in levents.el.
-(defun timeout-event-p (event)
- "Non-nil if EVENT is a timeout event."
- (and (listp event) (eq (car event) 'timer-event)))
-\f
-;;;###autoload
-(defun run-at-time (time repeat function &rest args)
- "Perform an action at time TIME.
-Repeat the action every REPEAT seconds, if REPEAT is non-nil.
-TIME should be a string like \"11:23pm\", nil meaning now, a number of seconds
-from now, a value from `current-time', or t (with non-nil REPEAT)
-meaning the next integral multiple of REPEAT.
-REPEAT may be an integer or floating point number.
-The action is to call FUNCTION with arguments ARGS.
-
-This function returns a timer object which you can use in `cancel-timer'."
- (interactive "sRun at time: \nNRepeat interval: \naFunction: ")
-
- (or (null repeat)
- (and (numberp repeat) (< 0 repeat))
- (error "Invalid repetition interval"))
-
- ;; Special case: nil means "now" and is useful when repeating.
- (if (null time)
- (setq time (current-time)))
-
- ;; Special case: t means the next integral multiple of REPEAT.
- (if (and (eq time t) repeat)
- (setq time (timer-next-integral-multiple-of-time (current-time) repeat)))
-
- ;; Handle numbers as relative times in seconds.
- (if (numberp time)
- (setq time (timer-relative-time (current-time) time)))
-
- ;; Handle relative times like "2 hours and 35 minutes"
- (if (stringp time)
- (let ((secs (timer-duration time)))
- (if secs
- (setq time (timer-relative-time (current-time) secs)))))
-
- ;; Handle "11:23pm" and the like. Interpret it as meaning today
- ;; which admittedly is rather stupid if we have passed that time
- ;; already. (Though only Emacs hackers hack Emacs at that time.)
- (if (stringp time)
- (progn
- (require 'diary-lib)
- (let ((hhmm (diary-entry-time time))
- (now (decode-time)))
- (if (>= hhmm 0)
- (setq time
- (encode-time 0 (% hhmm 100) (/ hhmm 100) (nth 3 now)
- (nth 4 now) (nth 5 now) (nth 8 now)))))))
-
- (or (consp time)
- (error "Invalid time format"))
-
- (let ((timer (timer-create)))
- (timer-set-time timer time repeat)
- (timer-set-function timer function args)
- (timer-activate timer)
- timer))
-
-;;;###autoload
-(defun run-with-timer (secs repeat function &rest args)
- "Perform an action after a delay of SECS seconds.
-Repeat the action every REPEAT seconds, if REPEAT is non-nil.
-SECS and REPEAT may be integers or floating point numbers.
-The action is to call FUNCTION with arguments ARGS.
-
-This function returns a timer object which you can use in `cancel-timer'."
- (interactive "sRun after delay (seconds): \nNRepeat interval: \naFunction: ")
- (apply 'run-at-time secs repeat function args))
-
-;;;###autoload
-(defun add-timeout (secs function object &optional repeat)
- "Add a timer to run SECS seconds from now, to call FUNCTION on OBJECT.
-If REPEAT is non-nil, repeat the timer every REPEAT seconds.
-This function is for compatibility; see also `run-with-timer'."
- (run-with-timer secs repeat function object))
-
-;;;###autoload
-(defun run-with-idle-timer (secs repeat function &rest args)
- "Perform an action the next time Emacs is idle for SECS seconds.
-The action is to call FUNCTION with arguments ARGS.
-SECS may be an integer or a floating point number.
-
-If REPEAT is non-nil, do the action each time Emacs has been idle for
-exactly SECS seconds (that is, only once for each time Emacs becomes idle).
-
-This function returns a timer object which you can use in `cancel-timer'."
- (interactive
- (list (read-from-minibuffer "Run after idle (seconds): " nil nil t)
- (y-or-n-p "Repeat each time Emacs is idle? ")
- (intern (completing-read "Function: " obarray 'fboundp t))))
- (let ((timer (timer-create)))
- (timer-set-function timer function args)
- (timer-set-idle-time timer secs repeat)
- (timer-activate-when-idle timer)
- timer))
-\f
-(defun with-timeout-handler (tag)
- (throw tag 'timeout))
-
-;;;###autoload (put 'with-timeout 'lisp-indent-function 1)
-
-;;;###autoload
-(defmacro with-timeout (list &rest body)
- "Run BODY, but if it doesn't finish in SECONDS seconds, give up.
-If we give up, we run the TIMEOUT-FORMS and return the value of the last one.
-The call should look like:
- (with-timeout (SECONDS TIMEOUT-FORMS...) BODY...)
-The timeout is checked whenever Emacs waits for some kind of external
-event \(such as keyboard input, input from subprocesses, or a certain time);
-if the program loops without waiting in any way, the timeout will not
-be detected."
- (let ((seconds (car list))
- (timeout-forms (cdr list)))
- `(let ((with-timeout-tag (cons nil nil))
- with-timeout-value with-timeout-timer)
- (if (catch with-timeout-tag
- (progn
- (setq with-timeout-timer
- (run-with-timer ,seconds nil
- 'with-timeout-handler
- with-timeout-tag))
- (setq with-timeout-value (progn . ,body))
- nil))
- (progn . ,timeout-forms)
- (cancel-timer with-timeout-timer)
- with-timeout-value))))
-
-(defun y-or-n-p-with-timeout (prompt seconds default-value)
- "Like (y-or-n-p PROMPT), with a timeout.
-If the user does not answer after SECONDS seconds, return DEFAULT-VALUE."
- (with-timeout (seconds default-value)
- (y-or-n-p prompt)))
-\f
-(defvar timer-duration-words
- (list (cons "microsec" 0.000001)
- (cons "microsecond" 0.000001)
- (cons "millisec" 0.001)
- (cons "millisecond" 0.001)
- (cons "sec" 1)
- (cons "second" 1)
- (cons "min" 60)
- (cons "minute" 60)
- (cons "hour" (* 60 60))
- (cons "day" (* 24 60 60))
- (cons "week" (* 7 24 60 60))
- (cons "fortnight" (* 14 24 60 60))
- (cons "month" (* 30 24 60 60)) ; Approximation
- (cons "year" (* 365.25 24 60 60)) ; Approximation
- )
- "Alist mapping temporal words to durations in seconds")
-
-(defun timer-duration (string)
- "Return number of seconds specified by STRING, or nil if parsing fails."
- (let ((secs 0)
- (start 0)
- (case-fold-search t))
- (while (string-match
- "[ \t]*\\([0-9.]+\\)?[ \t]*\\([a-z]+[a-rt-z]\\)s?[ \t]*"
- string start)
- (let ((count (if (match-beginning 1)
- (string-to-number (match-string 1 string))
- 1))
- (itemsize (cdr (assoc (match-string 2 string)
- timer-duration-words))))
- (if itemsize
- (setq start (match-end 0)
- secs (+ secs (* count itemsize)))
- (setq secs nil
- start (length string)))))
- (if (= start (length string))
- secs
- (if (string-match "\\`[0-9.]+\\'" string)
- (string-to-number string)))))
-\f
-(provide 'timer)
-
-;;; timer.el ends here
+++ /dev/null
-;;; tpu-doc.el --- Documentation for TPU-edt
-
-;; Copyright (C) 1993, 1994 Free Software Foundation, Inc.
-
-;; Author: Rob Riepel <riepel@networking.stanford.edu>
-;; Maintainer: Rob Riepel <riepel@networking.stanford.edu>
-;; Keywords: emulations
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to
-;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-
-;; This is documentation for the TPU-edt editor for GNU emacs. Major
-;; sections of this document are separated with lines that begin with
-;; ";; %% <topic>", where <topic> is what is discussed in that section.
-
-
-;; %% Contents
-
-;; % Introduction
-;; % Terminal Support
-;; % X-windows Support
-;; % Differences Between TPU-edt and the Real Thing
-;; % Starting TPU-edt
-;; % TPU-edt Default Editing Keypad, Control and Gold Key Bindings
-;; % Optional TPU-edt Extensions
-;; % Customizing TPU-edt using the Emacs Initialization File
-;; % Compiling TPU-edt
-;; % Regular expressions in TPU-edt
-;; % Etcetera
-
-
-;; %% Introduction
-
-;; TPU-edt is based on tpu.el by Jeff Kowalski and Bob Covey. TPU-edt
-;; endeavors to be even more like TPU's EDT emulation than the original
-;; tpu.el. Considerable effort has been expended to that end. Still,
-;; emacs is emacs and there are differences between TPU-edt and the
-;; real thing. Please read the "Differences Between TPU-edt and the
-;; Real Thing" and "Starting TPU-edt" sections before running TPU-edt.
-
-
-;; %% Terminal Support
-
-;; TPU-edt, like it's VMS cousin, works on VT-series terminals with
-;; DEC style keyboards. VT terminal emulators, including xterm with
-;; the appropriate key translations, work just fine too.
-
-
-;; %% X-windows Support
-
-;; Starting with version 19 of emacs, TPU-edt works with X-windows.
-;; This is accomplished through a TPU-edt X keymap. The emacs lisp
-;; program tpu-mapper.el creates this map and stores it in a file.
-;; Tpu-mapper will be run automatically the first time you invoke
-;; the X-windows version of emacs, or you can run it by hand. See
-;; the commentary in tpu-mapper.el for details.
-
-
-;; %% Differences Between TPU-edt and the Real Thing (not Coke (r))
-
-;; Emacs (version 18.58) doesn't support text highlighting, so selected
-;; regions are not shown in inverse video. Emacs uses the concept of
-;; "the mark". The mark is set at one end of a selected region; the
-;; cursor is at the other. The letter "M" appears in the mode line
-;; when the mark is set. The native emacs command ^X^X (Control-X
-;; twice) exchanges the cursor with the mark; this provides a handy
-;; way to find the location of the mark.
-
-;; In TPU the cursor can be either bound or free. Bound means the
-;; cursor cannot wander outside the text of the file being edited.
-;; Free means the arrow keys can move the cursor past the ends of
-;; lines. Free is the default mode in TPU; bound is the only mode
-;; in EDT. Bound is the only mode in the base version of TPU-edt;
-;; optional extensions add an approximation of free mode.
-
-;; Like TPU, emacs uses multiple buffers. Some buffers are used to
-;; hold files you are editing; other "internal" buffers are used for
-;; emacs' own purposes (like showing you help). Here are some commands
-;; for dealing with buffers.
-
-;; Gold-B moves to next buffer, including internal buffers
-;; Gold-N moves to next buffer containing a file
-;; Gold-M brings up a buffer menu (like TPU "show buffers")
-
-;; Emacs is very fond of throwing up new windows. Dealing with all
-;; these windows can be a little confusing at first, so here are a few
-;; commands to that may help:
-
-;; Gold-Next_Scr moves to the next window on the screen
-;; Gold-Prev_Scr moves to the previous window on the screen
-;; Gold-TAB also moves to the next window on the screen
-
-;; Control-x 1 deletes all but the current window
-;; Control-x 0 deletes the current window
-
-;; Note that the buffers associated with deleted windows still exist!
-
-;; Like TPU, TPU-edt has a "command" function, invoked with Gold-KP7 or
-;; Do. Most of the commands available are emacs commands. Some TPU
-;; commands are available, they are: replace, exit, quit, include, and
-;; Get (unfortunately, "get" is an internal emacs function, so we are
-;; stuck with "Get" - to make life easier, Get is available as Gold-g).
-
-;; Support for recall of commands, file names, and search strings was
-;; added to emacs in version 19. For version 18 of emacs, optional
-;; extensions are available to add this recall capability (see "Optional
-;; TPU-edt Extensions" below). The history of strings recalled in both
-;; versions of emacs differs slightly from TPU/edt, but it is still very
-;; convenient.
-
-;; Help is available! The traditional help keys (Help and PF2) display
-;; a three page help file showing the default keypad layout, control key
-;; functions, and Gold key functions. Pressing any key inside of help
-;; splits the screen and prints a description of the function of the
-;; pressed key. Gold-PF2 invokes the native emacs help, with it's
-;; zillions of options. Gold-Help shows all the current key bindings.
-
-;; Thanks to emacs, TPU-edt has some extensions that may make your life
-;; easier, or at least more interesting. For example, Gold-r toggles
-;; TPU-edt rectangular mode. In rectangular mode, Remove and Insert work
-;; on rectangles. Likewise, Gold-* toggles TPU-edt regular expression
-;; mode. In regular expression mode Find, Find Next, and the line-mode
-;; replace command work with regular expressions. [A regular expression
-;; is a pattern that denotes a set of strings; like VMS wildcards.]
-
-;; Emacs also gives TPU-edt the undo and occur functions. Undo does
-;; what it says; it undoes the last change. Multiple undos in a row
-;; undo multiple changes. For your convenience, undo is available on
-;; Gold-u. Occur shows all the lines containing a specific string in
-;; another window. Moving to that window, and typing ^C^C (Control-C
-;; twice) on a particular line moves you back to the original window
-;; at that line. Occur is on Gold-o.
-
-;; Finally, as you edit, remember that all the power of emacs is at
-;; your disposal. It really is a fantastic tool. You may even want to
-;; take some time and read the emacs tutorial; perhaps not to learn the
-;; native emacs key bindings, but to get a feel for all the things
-;; emacs can do for you. The emacs tutorial is available from the
-;; emacs help function: "Gold-PF2 t"
-
-
-;; %% Starting TPU-edt
-
-;; In order to use TPU-edt, the TPU-edt editor definitions, contained
-;; in tpu-edt.el, need to be loaded when emacs is run. This can be
-;; done in a couple of ways. The first is by explicitly requesting
-;; loading of the TPU-edt emacs definition file on the command line:
-
-;; prompt> emacs -l /path/to/definitions/tpu-edt.el
-
-;; If TPU-edt is installed on your system, that is, if tpu-edt.el is in
-;; a directory like /usr/local/emacs/lisp, along with dozens of other
-;; .el files, you should be able to use the command:
-
-;; prompt> emacs -l tpu-edt
-
-;; If you like TPU-edt and want to use it all the time, you can load
-;; the TPU-edt definitions using the emacs initialization file, .emacs.
-;; Simply create a .emacs file in your home directory containing the
-;; line:
-
-;; (load "/path/to/definitions/tpu-edt")
-
-;; or, if (as above) TPU-edt is installed on your system:
-
-;; (load "tpu-edt")
-
-;; Once TPU-edt has been loaded, you will be using an editor with the
-;; interface shown in the next section (A section that is suitable for
-;; cutting out of this document and pasting next to your terminal!).
-
-
-;; %% TPU-edt Default Editing Keypad, Control and Gold Key Bindings
-;;
-;; _______________________ _______________________________
-;; | HELP | Do | | | | | |
-;; |KeyDefs| | | | | | |
-;; |_______|_______________| |_______|_______|_______|_______|
-;; _______________________ _______________________________
-;; | Find |Insert |Remove | | Gold | HELP |FndNxt | Del L |
-;; | | |Sto Tex| | key |E-Help | Find |Undel L|
-;; |_______|_______|_______| |_______|_______|_______|_______|
-;; |Select |Pre Scr|Nex Scr| | Page | Sect |Append | Del W |
-;; | Reset |Pre Win|Nex Win| | Do | Fill |Replace|Undel W|
-;; |_______|_______|_______| |_______|_______|_______|_______|
-;; |Move up| |Forward|Reverse|Remove | Del C |
-;; | Top | |Bottom | Top |Insert |Undel C|
-;; _______|_______|_______ |_______|_______|_______|_______|
-;; |Mov Lef|Mov Dow|Mov Rig| | Word | EOL | Char | |
-;; |StaOfLi|Bottom |EndOfLi| |ChngCas|Del EOL|SpecIns| Enter |
-;; |_______|_______|_______| |_______|_______|_______| |
-;; | Line |Select | Subs |
-;; | Open Line | Reset | |
-;; |_______________|_______|_______|
-;; Control Characters
-;;
-;; ^A toggle insert and overwrite ^L insert page break
-;; ^B recall ^R remember, re-center
-;; ^E end of line ^U delete to beginning of line
-;; ^G cancel current operation ^V quote
-;; ^H beginning of line ^W refresh
-;; ^J delete previous word ^Z exit
-;; ^K learn ^X^X exchange point and mark
-;;
-;;
-;; Gold-<key> Functions
-;; -----------------------------------------------------------------
-;; W Write - save current buffer
-;; K Kill buffer - abandon edits and delete buffer
-;;
-;; E Exit - save current buffer and ask about others
-;; X eXit - save all modified buffers and exit
-;; Q Quit - exit without saving anything
-;;
-;; G Get - load a file into a new edit buffer
-;; I Include - include a file in this buffer
-;;
-;; B next Buffer - display the next buffer (all buffers)
-;; N Next file buffer - display next buffer containing a file
-;; M buffer Menu - display a list of all buffers
-;;
-;; U Undo - undo the last edit
-;; C Recall - edit and possibly repeat previous commands
-;;
-;; O Occur - show following lines containing REGEXP
-;; S Search and substitute - line mode REPLACE command
-;;
-;; ? Spell check - check spelling in a region or entire buffer
-;;
-;; R Toggle Rectangular mode for remove and insert
-;; * Toggle regular expression mode for search and substitute
-;;
-;; V Show TPU-edt version
-;; -----------------------------------------------------------------
-
-
-;; %% Optional TPU-edt Extensions
-
-;; Several optional packages have been included in this distribution
-;; of TPU-edt. The following is a brief description of each package.
-;; See the {package}.el file for more detailed information and usage
-;; instructions.
-
-;; tpu-extras - TPU/edt scroll margins and free cursor mode.
-;; tpu-recall - String, file name, and command history.
-;; vt-control - VTxxx terminal width and keypad controls.
-
-;; Packages are normally loaded from the emacs initialization file
-;; (discussed below). If a package is not installed in the emacs
-;; lisp directory, it can be loaded by specifying the complete path
-;; to the package file. However, it is preferable to modify the
-;; emacs load-path variable to include the directory where packages
-;; are stored. This way, packages can be loaded by name, just as if
-;; they were installed. The first part of the sample .emacs file
-;; below shows how to make such a modification.
-
-
-;; %% Customizing TPU-edt using the Emacs Initialization File
-
-;; .emacs - a sample emacs initialization file
-
-;; This is a sample emacs initialization file. It shows how to invoke
-;; TPU-edt, and how to customize it.
-
-;; The load-path is where emacs looks for files to fulfill load requests.
-;; If TPU-edt is not installed in a standard emacs directory, the load-path
-;; should be updated to include the directory where the TPU-edt files are
-;; stored. Modify and un-comment the following section if TPU-ed is not
-;; installed on your system - be sure to leave the double quotes!
-
-;; (setq load-path
-;; (append (list (expand-file-name "/path/to/tpu-edt/files"))
-;; load-path))
-
-;; Load TPU-edt
-(load "tpu-edt")
-
-;; Load the optional goodies - scroll margins, free cursor mode, command
-;; and string recall. But don't complain if the file aren't available.
-(load "tpu-extras" t)
-(load "tpu-recall" t)
-
-;; Uncomment this line to set scroll margins 10% (top) and 15% (bottom).
-;(and (fboundp 'tpu-set-scroll-margins) (tpu-set-scroll-margins "10%" "15%"))
-
-;; Load the vtxxx terminal control functions, but don't complain if
-;; if the file is not found.
-(load "vt-control" t)
-
-;; TPU-edt treats words like EDT; here's how to add word separators.
-;; Note that backslash (\) and double quote (") are quoted with '\'.
-(tpu-add-word-separators "]\\[-_,.\"=+()'/*#:!&;$")
-
-;; Emacs is happy to save files without a final newline; other Unix programs
-;; hate that! This line will make sure that files end with newlines.
-(setq require-final-newline t)
-
-;; Emacs has the ability to automatically run code embedded in files
-;; you edit. This line makes emacs ask if you want to run the code.
-(if tpu-emacs19-p (setq enable-local-variables "ask")
- (setq inhibit-local-variables t))
-
-;; Emacs uses Control-s and Control-q. Problems can occur when using emacs
-;; on terminals that use these codes for flow control (Xon/Xoff flow control).
-;; These lines disable emacs' use of these characters.
-(global-unset-key "\C-s")
-(global-unset-key "\C-q")
-
-;; top, bottom, bol, eol seem like a waste of Gold-arrow functions. The
-;; following section re-maps up and down arrow keys to top and bottom of
-;; screen, and left and right arrow keys to pan left and right (pan-left,
-;; right moves the screen 16 characters left or right - try it, you'll
-;; like it!).
-
-;; Re-map the Gold-arrow functions
-(define-key GOLD-CSI-map "A" 'tpu-beginning-of-window) ; up-arrow
-(define-key GOLD-CSI-map "B" 'tpu-end-of-window) ; down-arrow
-(define-key GOLD-CSI-map "C" 'tpu-pan-right) ; right-arrow
-(define-key GOLD-CSI-map "D" 'tpu-pan-left) ; left-arrow
-(define-key GOLD-SS3-map "A" 'tpu-beginning-of-window) ; up-arrow
-(define-key GOLD-SS3-map "B" 'tpu-end-of-window) ; down-arrow
-(define-key GOLD-SS3-map "C" 'tpu-pan-right) ; right-arrow
-(define-key GOLD-SS3-map "D" 'tpu-pan-left) ; left-arrow
-
-;; Re-map the Gold-arrow functions for X-windows TPU-edt (emacs version 19)
-(cond
- ((and tpu-emacs19-p window-system)
- (define-key GOLD-map [up] 'tpu-beginning-of-window) ; up-arrow
- (define-key GOLD-map [down] 'tpu-end-of-window) ; down-arrow
- (define-key GOLD-map [right] 'tpu-pan-right) ; right-arrow
- (define-key GOLD-map [left] 'tpu-pan-left))) ; left-arrow
-
-;; The emacs universal-argument function is very useful for native emacs
-;; commands. This line maps universal-argument to Gold-PF1
-(define-key GOLD-SS3-map "P" 'universal-argument) ; Gold-PF1
-
-;; Make KP7 move by paragraphs, instead of pages.
-(define-key SS3-map "w" 'tpu-paragraph) ; KP7
-
-;; TPU-edt assumes you have the ispell spelling checker;
-;; Un-comment this line if you don't.
-;(setq tpu-have-spell nil)
-
-;; Display the TPU-edt version.
-(tpu-version)
-
-;; End of .emacs - a sample emacs initialization file
-
-;; After initialization with the .emacs file shown above, the editing
-;; keys have been re-mapped to look like this:
-
-;; _______________________ _______________________________
-;; | HELP | Do | | | | | |
-;; |KeyDefs| | | | | | |
-;; |_______|_______________| |_______|_______|_______|_______|
-;; _______________________ _______________________________
-;; | Find |Insert |Remove | | Gold | HELP |FndNxt | Del L |
-;; | | |Sto Tex| | U Arg |E-Help | Find |Undel L|
-;; |_______|_______|_______| |_______|_______|_______|_______|
-;; |Select |Pre Scr|Nex Scr| |Paragra| Sect |Append | Del W |
-;; | Reset |Pre Win|Nex Win| | Do | Fill |Replace|Undel W|
-;; |_______|_______|_______| |_______|_______|_______|_______|
-;; |Move up| |Forward|Reverse|Remove | Del C |
-;; |Tscreen| |Bottom | Top |Insert |Undel C|
-;; _______|_______|_______ |_______|_______|_______|_______|
-;; |Mov Lef|Mov Dow|Mov Rig| | Word | EOL | Char | |
-;; |PanLeft|Bscreen|PanRigh| |ChngCas|Del EOL|SpecIns| Enter |
-;; |_______|_______|_______| |_______|_______|_______| |
-;; | Line |Select | Subs |
-;; | Open Line | Reset | |
-;; |_______________|_______|_______|
-
-;; Astute emacs hackers will realize that on systems where TPU-edt is
-;; installed, this documentation file can be loaded to produce the above
-;; editing keypad layout. In fact, to get all the changes in the sample
-;; initialization file, you only need a one line initialization file:
-
-;; (load "tpu-doc")
-
-;; wow!
-
-
-;; %% Compiling TPU-edt
-
-;; It is not necessary to compile (byte-compile in emacs parlance)
-;; TPU-edt to use it. However, byte-compiled code loads and runs
-;; faster, and takes up less memory when loaded. To byte compile
-;; TPU-edt, use the following command.
-
-;; emacs -batch -f batch-byte-compile tpu-edt.el
-
-;; This will produce a file named tpu-edt.elc. This new file can be
-;; used in place of the original tpu-edt.el file. In commands where
-;; the file type is not specified, emacs always attempts to use the
-;; byte-compiled version before resorting to the source.
-
-
-;; %% Regular expressions in TPU-edt
-
-;; Gold-* toggles TPU-edt regular expression mode. In regular expression
-;; mode, find, find next, replace, and substitute accept emacs regular
-;; expressions. A complete list of emacs regular expressions can be
-;; found using the emacs "info" command (it's somewhat like the VMS help
-;; command). Try the following sequence of commands:
-
-;; DO info <enter info mode>
-;; m regex <select the "regular expression" topic>
-;; m directives <select the "directives" topic>
-
-;; Type "q" to quit out of info mode.
-
-;; There is a problem in regular expression mode when searching for
-;; empty strings, like beginning-of-line (^) and end-of-line ($).
-;; When searching for these strings, find-next may find the current
-;; string, instead of the next one. This can cause global replace and
-;; substitute commands to loop forever in the same location. For this
-;; reason, commands like
-
-;; replace "^" "> " <add "> " to beginning of line>
-;; replace "$" "00711" <add "00711" to end of line>
-
-;; may not work properly.
-
-;; Commands like those above are very useful for adding text to the
-;; beginning or end of lines. They might work on a line-by-line basis,
-;; but go into an infinite loop if the "all" response is specified. If
-;; the goal is to add a string to the beginning or end of a particular
-;; set of lines TPU-edt provides functions to do this.
-
-;; Gold-^ Add a string at BOL in region or buffer
-;; Gold-$ Add a string at EOL in region or buffer
-
-;; There is also a TPU-edt interface to the native emacs string
-;; replacement commands. Gold-/ invokes this command. It accepts
-;; regular expressions if TPU-edt is in regular expression mode. Given
-;; a repeat count, it will perform the replacement without prompting
-;; for confirmation.
-
-;; This command replaces empty strings correctly, however, it has its
-;; drawbacks. As a native emacs command, it has a different interface
-;; than the emulated TPU commands. Also, it works only in the forward
-;; direction, regardless of the current TPU-edt direction.
-
-
-;; %% Etcetera
-
-;; That's TPU-edt in a nutshell...
-
-;; Please send any bug reports, feature requests, or cookies to the
-;; author, Rob Riepel, at the address shown by the tpu-version command
-;; (Gold-V).
-
-;; Share and enjoy... Rob Riepel 7/93
-
-;;; tpu-doc.el ends here
+++ /dev/null
-;;; vmsx.el --- run asynchronous VMS subprocesses under Emacs
-
-;; Copyright (C) 1986 Free Software Foundation, Inc.
-
-;; Author: Mukesh Prasad
-;; Maintainer: FSF
-;; Keywords: vms
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to
-;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;;; Code:
-
-(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)
-
-;;; vmsx.el ends here
+++ /dev/null
-;;; word-help.el --- keyword help for any language doc'd in TeXinfo.
-
-;; Copyright (c) 1996 Free Software Foundation, Inc.
-
-;; Author: Jens T. Berger Thielemann <jensthi@ifi.uio.no>
-;; Keywords: help, keyword, languages, completion
-
-;; This file is part of GNU Emacs.
-
-;; 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 2, 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 GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;;; Commentary:
-
-;; This package provides a rather general interface for doing keyword
-;; help in most languages. In short, it'll determine which TeXinfo
-;; file which is relevant for the current mode; cache the index and
-;; use regexps to give you help on the keyword you're looking at.
-
-;; Installation
-;; ************
-
-;; For the default setup to work for all supported modes, make sure
-;; the Texinfo files from the following packages are installed:
-
-;; Texinfo file | Available in archive or URL | Notes
-;; autoconf.info | autoconf-2.10.tar.gz | -
-;; bison.info | bison-1.25.tar.gz | -
-;; libc.info | glibc-1.09.1.tar.gz | -
-;; elisp.info | elisp-manual-19-2.4.tar.gz | -
-;; latex.info | ftp://ftp.dante.de/pub/tex/info/latex2e-help-texinfo/latex2e.texi
-;; groff.info | groff-1.10.tar.gz | -
-;; m4.info | m4-1.4.tar.gz | -
-;; make.info | make-3.75.tar.gz | -
-;; perl.info | http://www.perl.com/CPAN/doc/manual/info/
-;; simula.info | Mail bjort@ifi.uio.no | Written in Norwegian
-;; texinfo.info | texinfo-3.9.tar.gz | -
-
-;; BTW: We refer to Texinfo files by just their last component, not
-;; with an absolute file name. You must thus set up
-;; `Info-directory-list' and `Info-default-directory-list' so that
-;; these can automatically be located.
-
-;; Usage
-;; *****
-;;
-;; Place the cursor over the function/variable/type/whatever you want
-;; help on. Type "C-h C-i". `word-help' will then make a suggestion
-;; to an index topic; press return to accept this. If not, you may use
-;; tab-completion to find the topic you're interested in.
-
-;; `word-help' is also able to do symbol completion via the
-;; `word-help-complete' function. Bind this function to C-TAB by
-;; adding the following line to your .emacs file:
-;;
-;; (global-set-key [?\M-\t] 'word-help-complete)
-;;
-;; Note that some modes automatically override this key; you may
-;; therefore wish to either put the above statement in a hook or
-;; associate the function with an other key.
-
-;; Usually, `word-help' is able to determine the relevant Texinfo
-;; file from looking at the buffer's `mode-name'; if not, you can use
-;; the interactive function `set-help-file' to set this.
-
-;; Customizing
-;; ***********
-;;
-;; User interface
-;; --------------
-;;
-;; Two variables control the behaviour of the user-interface of
-;; `word-help': `word-help-split-window' and
-;; `word-help-magic-index'. Do C-h v to get more information on
-;; these.
-
-;; Adding more Texinfo files
-;; -------------------------
-;;
-;; Associations between mode-names and Texinfo files can be done
-;; through the `word-help-mode-alist' variable, which defines an
-;; `alist' making `set-help-file' able to initialize the necessary
-;; variable.
-
-;; NOTE: If you have to customize the regexps, it is *CRUCIAL* that
-;; none of your regexps match the empty string! Not adhering to this
-;; restriction will make `word-help' enter an infinite loop.
-
-;; Contacting the author
-;; *********************
-;;
-;; If you wish to contact me for any reason, please feel free to write
-;; to:
-
-;; Jens Berger
-;; Spektrumveien 4
-;; N-0666 Oslo
-;; Norway
-;;
-;; E-mail: <jensthi@ifi.uio.no>
-
-;; Have fun.
-
-;;
-;;; Code:
-;;
-
-(require 'info)
-
-;;;--------------------
-;;; USER OPTIONS
-;;;--------------------
-
-(defvar word-help-split-window t
- "*Non-nil means that the info buffer will pop up in a separate window.
-If nil, we will just switch to it.")
-
-(defvar word-help-magic-index t
- "*Non-nil means that the keyword will be searched for in the requested node.
-This is done by determining whether the line the point is positioned
-on after using `Info-goto-node', actually contains the keyword. If
-not, we will search for the first occurence of the keyword. This may
-help when the info file isn't correctly indexed.")
-
-;;; ---- end of user configurable variables
-
-;;;-------------------------
-;;; ADVANCED USER OPTIONS
-;;;-------------------------
-
-(defvar word-help-mode-alist
- '(
- ("autoconf"
- (("autoconf" "Macro Index") ("m4" "Macro index"))
- (("AC_\\([A-Za-z0-9_]+\\)" 1)
- ("[a-z]+"))
- nil
- nil
- (("AC_\\([A-Za-z0-9_]+\\)" 1 nil (("^[A-Z_]+$")))
- ("[a-z_][a-z_]*" 0 nil (("^[a-z_]+$")))))
-
- ("Bison"
- (("bison" "Index")
- ("libc" "Type Index" "Function Index" "Variable Index"))
- (("%[A-Za-z]*")
- ("[A-Za-z_][A-Za-z0-9_]*"))
- nil
- nil
- (("%[A-Za-z]*" nil nil (("^%")))
- ("[A-Za-z_][A-Za-z0-9_]*" nil nil (("[A-Za-z_][A-Za-z0-9_]*")))))
-
- ("YACC" . "Bison")
-
- ("C" (("libc" "Type Index" "Function Index" "Variable Index")))
- ("C++" . "C")
-
- ("Emacs-Lisp"
- (("elisp" "Index"))
- (("[^][ ()\n\t.\"'#]+"))
- nil
- nil
- lisp-complete-symbol)
-
- ("LaTeX"
- (("latex" "Command Index"))
- (("\\\\\\(begin\\|end\\){\\([^}\n]+\\)}" 2 0)
- ("\\\\[A-Za-z]+")
- ("\\\\[^A-Za-z]")
- ("[A-Za-z]+"))
- nil
- nil
- (("\\\\begin{\\([A-Za-z]*\\)" 1 "}" (("^[A-Za-z]+$")))
- ("\\\\end{\\([A-Za-z]*\\)" 1 "}" (("^[A-Za-z]+$")))
- ("\\\\renewcommand{\\(\\\\?[A-Za-z]*\\)" 1 "}" (("^\\\\[A-Za-z]+")))
- ("\\\\renewcommand\\(\\\\?[A-Za-z]*\\)" 1 "" (("^\\\\[A-Za-z]+")))
- ("\\\\renewenvironment{?\\([A-Za-z]*\\)" 1 "}"(("^[A-Za-z]+$")))
- ("\\\\[A-Za-z]*" 0 "" (("^\\\\[A-Za-z]+")))))
-
- ("latex" . "LaTeX")
-
- ("Nroff"
- (("groff" "Macro Index" "Register Index" "Request Index"))
- (("\\.[^A-Za-z]")
- ("\\.[A-Za-z]+")
- ("\\.\\([A-Za-z]+\\)" 1))
- nil
- nil
- (("\\.[A-Za-z]*" nil nil (("^\\.[A-Za-z]+$")))
- ("\\.\\([A-Za-z]*\\)" 1 nil (("^[A-Za-z]+$")))))
-
- ("Groff" . "Nroff")
-
- ("m4"
- (("m4" "Macro index"))
- (("\\([mM]4_\\)?\\([A-Za-z_][A-Za-z_0-9]*\\)" 2))
- nil
- nil
- (("[mM]4_\\([A-Za-z_]?[A-Za-z_0-9]*\\)" 1)
- ("[A-Za-z_][A-Za-z_0-9]*")))
-
- ("Makefile"
- (("make" "Name Index"))
- (("\\.[A-Za-z]+") ;; .SUFFIXES
- ("\\$[^()]") ;; $@
- ("\\$([^A-Za-z].)") ;; $(<@)
- ("\\$[\(\{]\\([a-zA-Z+]\\)" 1) ;; $(wildcard)
- ("[A-Za-z]+")) ;; foreach
- nil
- nil
- (("\\.[A-Za-z]*" nil ":" (("^\\.[A-Za-z]+$")))
- ("\\$(\\([A-Z]*\\)" 1 ")" (("^[A-Z]")))
- ("[a-z]+" nil nil (("^[a-z]+$")))))
-
- ("Perl"
- (("perl" "Variable Index" "Function Index"))
- (("\\$[^A-Za-z^]") ;; $@
- ("\\$\\^[A-Za-z]?") ;; $^D
- ("\\$[A-Za-z][A-Za-z_0-9]+") ;; $foobar
- ("[A-Za-z_][A-Za-z_0-9]+")) ;; dbmopen
- nil
- nil
- (("\\$[A-Za-z]*" nil nil (("^\\$[A-Za-z]+$"))) ;; $variable
- ("[A-Za-z_][A-Za-z_0-9]*" nil nil
- (("^[A-Za-z_][A-Za-z_0-9]*$"))))) ;; function
-
- ("Simula" (("simula" "Index")) nil t)
- ("Ifi Simula" . "Simula")
- ("SIMULA" . "Simula")
-
- ("Texinfo"
- (("texinfo" "Command and Variable Index"))
- (("@\\([A-Za-z]+\\)" 1))
- nil
- nil
- (("@\\([A-Za-z]*\\)" 1)))
-
- )
- "Assoc list between `mode-name' and Texinfo files.
-The variable should be initialized with a list of elements with the
-following form:
-
-\(mode-name (word-help-info-files) (word-help-keyword-regexps)
- word-help-ignore-case word-help-index-mapper
- word-help-complete-list)
-
-where `word-help-info-files', `word-help-keyword-regexps' and so
-forth of course are the values which should be put in these variables
-for this mode. Note that `mode-name' doesn't have to be a legal
-mode-name; the user may use the call `set-help-file', where
-`mode-name' will be used in the `completing-read'.
-
-Example entry (for C):
-
-\(\"C\" ((\"libc\" \"Type Index\" \"Function Index\" \"Variable Index\"))
- ((\"[A-Za-z_][A-Za-z0-9]+\")))
-
-The two first variables must be initialized; the two remaining will
-get default values if you omit them or set them to nil. The default
-values are:
-
-word-help-keyword-regexps: (\"[A-Za-z_][A-Za-z0-9]+\")
-word-help-ignore-case: nil
-
-More settings may be defined in the future.
-
-You may also define aliases, if there are several relevant mode-names
-to a single entry. These should be of the form:
-
-\(MODE-NAME-ALIAS . MODE-NAME-REAL)
-
-For C++, you would use the alias
-
-\(\"C++\" . \"C\")
-
-to make C++ mode use the same help files as C files do. Please note
-that you can shoot yourself in the foot with this possibility, by
-defining recursive aliases.")
-
-;;; --- end of advanced user options
-
-(defvar word-help-ignore-case nil
- "Non-nil means that case is ignored when doing lookup.")
-(make-variable-buffer-local 'word-help-ignore-case)
-
-(defvar word-help-info-files nil
- "List of info files with respective nodes, for the current mode.
-
-This should be a list of the following form:
-
-\((INFO-FILE-1 NODE-NAME-1 NODE-NAME-2 ...)
- (INFO-FILE-1 NODE-NAME-1 NODE-NAME-2 ...)
- : : :
- (INFO-FILE-1 NODE-NAME-1 NODE-NAME-2 ...))
-
-An example entry for e.g. C would be:
-
-\((\"/local/share/gnu/info/libc\" \"Function Index\" \"Type Index\"
- \"Variable Index\"))
-
-The files and nodes will be searched/cached in the order specified.
-This variable is usually set by the `word-help-switch-help-file'
-function, which utilizes the `word-help-mode-alist'.")
-(make-variable-buffer-local 'word-help-info-files)
-
-(defvar word-help-keyword-regexps nil
- "Regexps for finding keywords in the current mode.
-
-This is constructed as a list of the following form:
-
-\((REGEXP SUBMATCH-LOOKUP SUBMATCH-CURSOR)
- (REGEXP SUBMATCH-LOOKUP SUBMATCH-CURSOR)
- : : :
- (REGEXP SUBMATCH-LOOKUP SUBMATCH-CURSOR))
-
-The regexps will be searched in order for a match which the cursor is
-within.
-
-submatch-lookup is the submatch number which will be looked for in the
-index. May be omitted; defaults to 0 (e.g. the entire pattern). This is
-useful in for instance configure lookup; each command is there prefixed
-with 'AC_', which must be ignored when doing a lookup. Example regexp
-entry for this:
-
-\(\"AC_\\\\([A-Za-z0-9]+\\\\)\" 1)
-
-submatch-cursor is the part of the match which the cursor must be within.
-May be omitted; defaults to 0 (e.g. the entire pattern).")
-(make-variable-buffer-local 'word-help-keyword-regexps)
-(set-default 'word-help-keyword-regexps '(("[A-Za-z_][A-Za-z_0-9]*")))
-
-(defvar word-help-index-mapper nil
- "Regexps to use for massaging index-entries into keywords.
-This variable should contain a list of regexps with sub-expressions,
-where we will only look for the sub-expression in the user text.
-
-The regexp list should be formatted as:
-
- ((REGEXP SUBEXP) (REGEXP SUBEXP) ... )
-
-If the index entry does not match any of the regexps, it will be ignored.
-
-Example:
-
-Perl has index entries of the following form:
-
-* abs VALUE: perlfunc.
-* accept NEWSOCKET,GENERICSOCKET: perlfunc.
-* alarm SECONDS: perlfunc.
-* atan2 Y,X: perlfunc.
-* bind SOCKET,NAME: perlfunc.
- : : :
-
-We will thus try to extract the first word in the index entry -
-\"abs\" from \"abs VALUE\", etc. This is done by the following entry:
-
-\((\"^\\\\([^ \\t\\n]+\\\\)\" 1))
-
-This value is btw. the default one, and works with most Texinfo files")
-(make-variable-buffer-local 'word-help-index-mapper)
-(set-default 'word-help-index-mapper '(("^\\([^ \t\n]+\\)" 1)))
-
-
-(defvar word-help-complete-list nil
- "Regexps or function to use for completion of symbols.
-The list should have the following format:
-
- ((REGEXP SUBMATCH TEXT-APPEND (RE-FILTER-1 REG-FILTER-2 ...)
- : : : : :
- (REGEXP SUBMATCH TEXT-APPEND (RE-FILTER-1 REG-FILTER-2 ...))
-
-The two first entries are similar to `word-help-keyword-regexps',
-REGEXP is a regular expression which should match any relevant
-expression, and where SUBMATCH should be used for look up. By
-specifying non-nil REGEXP-FILTERs, we'll only include entries in the
-index which matches the regexp specified.
-
-If the contents of this variable is a symbol of a function, this
-function will be called instead. This is useful for modes providing
-a more intelligent function (like `lisp-complete-symbol' in Emacs Lisp mode).
-
-If you would like to use another function instead, you may.
-
-Non-nil TEXT-APPEND means that this text will be inserted after the
-completion, if we manage to do make a completion.")
-(make-variable-buffer-local 'word-help-complete-list)
-(set-default 'word-help-complete-list '(("[A-Za-z_][A-Za-z_0-9]*")))
-
-;;; Work variables
-
-
-(defvar word-help-main-index nil
- "List of all index entries.
-
-See `word-help-process-indexes' for structure formatting.
-
-Minor note: This variable is a list if it is initialized, t if
-initializing failed and nil if uninitialized.")
-(make-variable-buffer-local 'word-help-main-index)
-
-(defvar word-help-complete-index nil
- "List of regexps for completion, with matching index entries.
-Value is nil if uninitialized, t if initialized but not accessible,
-a list if we're feeling ok.")
-(make-variable-buffer-local 'word-help-complete-index)
-
-(defvar word-help-main-obarray nil
- "Global work variable for `word-help' system.
-Do Not mess with this!")
-
-(defvar word-help-history nil
- "History for `word-help' minibuffer queries.")
-(make-local-variable 'word-help-history)
-
-(defvar word-help-current-help-file nil
- "Current help file active for this mode.")
-
-(defvar word-help-index-alist nil
- "An assoc list mapping help files to info indexes.
-This means that `word-help-mode-index' can be init'ed faster.")
-
-(defvar word-help-help-mode nil
- "Which mode the help system is bound to for the current mode.")
-(make-variable-buffer-local 'word-help-help-mode)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;; User Functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;;; Debugging
-
-;;;###autoload
-(defun reset-word-help ()
- "Clear all cached indexes in the `word-help' system.
-You should only need this when installing new info files, and/or
-adding more Texinfo files to the `word-help' system."
- (interactive)
- (setq word-help-index-alist nil
- word-help-main-index nil
- word-help-info-files nil
- word-help-complete-index nil))
-
-
-;;; Changing help file
-
-;;;###autoload
-(defun set-word-help-file ()
- "Change which set of Texinfo files used for word-help.
-
-`word-help' maintains a list over which Texinfo files which are
-relevant for each programming language (`word-help-mode-alist'). It
-usually selects the correct one, based upon the value of `mode-name'.
-If this guess is incorrect, you may also use this function manually to
-instruct future `word-help' calls which Texinfo files to use."
- (interactive)
- (let (helpfile helpguess (completion-ignore-case t))
-;; Try to make a guess
- (setq helpguess (cond
- (word-help-current-help-file)
- ((word-help-guess-help-file))))
-;; Ask the user
- (setq helpfile (completing-read
- (if helpguess
- (format "Select help mode (default %s): " helpguess)
- "Select help mode: ")
- word-help-mode-alist
- nil t nil nil))
- (if (equal "" helpfile)
- (setq helpfile helpguess))
- (if helpfile
- (word-help-switch-help-file helpfile))))
-
-;;; Main user interface
-
-;;;###autoload
-(defun word-help ()
- "Find documentation on the keyword under the cursor.
-The determination of which language the keyword belongs to, is based upon
-The relevant info file is selected by matching `mode-name' (the major
-mode) against the assoc list `word-help-mode-alist'.
-
-If this is not possible, `set-help-file' will be invoked for selecting
-the relevant info file. `set-help-file' may also be invoked
-interactively by the user.
-
-If the keyword you are looking at is not available in any index, no
-default suggestion will be presented. "
- (interactive)
- (let (myguess guess index-info
- (completion-ignore-case word-help-ignore-case))
-;; Set necessary variables for later lookup
- (word-help-find-help-file)
-;; Have we previously cached datas?
- (word-help-process-indexes)
- (if
- (atom word-help-main-index)
- (message "No help file available for this mode.")
-;; First make a guess at what the user is looking for
- (setq myguess (word-help-guess
- (point)
- (cond
- ((not (atom word-help-main-index))
- (car word-help-main-index)))
- word-help-keyword-regexps))
-;; Ask the user himself
- (setq guess (completing-read
- ; Format string
- (if myguess
- (format "Look up keyword (default %s): " myguess)
- "Look up keyword: ")
- ; Collection
- (car word-help-main-index)
- nil t nil 'word-help-history))
- (if (equal guess "")
- (setq guess myguess))
-;; If we've got anything meaningful to lookup, do so
- (if (not guess)
- (message "Help aborted.")
- (setq index-info (word-help-find-index-node
- guess
- word-help-main-index))
- (if (not index-info)
- (message "Oops, I could not find \"%s\" anyway! Bug?" guess)
- (word-help-goto-index-node (nconc index-info (list guess))))))))
-
-;;;###autoload
-(defun word-help-complete ()
- "Perform completion on the symbol preceding the point.
-The determination of which language the keyword belongs to, is based upon
-The relevant info file is selected by matching `mode-name' (the major
-mode) against the assoc list `word-help-mode-alist'.
-
-If this is not possible, `set-help-file' will be invoked for selecting
-the relevant info file. `set-help-file' may also be invoked
-interactively by the user.
-
-The keywords are extracted from the index of the info file defined for
-this mode, by using the `word-help-complete-list' variable."
- (interactive)
- (word-help-make-complete)
- (cond
- ((not word-help-complete-index)
- (message "No completion available for this mode."))
- ((symbolp word-help-complete-index)
- (call-interactively word-help-complete-index))
- ((listp word-help-complete-index)
- (let ((all-match (word-help-guess-all (point)
- word-help-complete-index t))
- (completion-ignore-case word-help-ignore-case)
- (c-list word-help-complete-index)
- c-entry word-match completion completed)
-;; Loop over and try to find a match
- (while (and all-match (not completed))
- (setq word-match (car all-match)
- c-entry (car c-list)
- c-list (cdr c-list)
- all-match (cdr all-match))
-;; Check whether the current pattern matched
- (if word-match
- (let ((close (nth 3 c-entry))
- (words (nth 4 c-entry)))
-;; Find the maximum completion for this word
-; (print word-match)
-; (print c-entry)
-; (print close)
- (setq completion (try-completion word-match words))
-;; Was the match exact
- (cond ((eq completion t)
- (and close
- (not (looking-at (regexp-quote close)))
- (insert close))
- (setq completed t))
-;; Silently ignore non-matches
- ((not completion))
-;; May we complete more unambiguously
- ((not (string-equal completion word-match))
- (delete-region (- (point) (length word-match))
- (point))
- (insert completion)
- (if (eq t (try-completion completion words))
- (progn
- (and close
- (not (looking-at (regexp-quote close)))
- (insert close))))
- (setq completed t))
- (t
- (message "Making completion list...")
- (let ((list (all-completions word-match words nil)))
- (setq completed list)
- (with-output-to-temp-buffer "*Completions*"
- (display-completion-list list)))
- (message "Making completion list...done"))))))
- (if (not completed) (message "No match."))))
- (t (message "No completion available for this mode."))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;; Index mapping ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-
-(defun word-help-map-index-entries (str re-list)
- "Transform an Info index entry into a programming keyword.
-Uses this by mapping the entries through `word-help-index-mapper'."
- (let ((regexp (car (car re-list)))
- (subexp (car (cdr (car re-list))))
- (next (cdr re-list)))
- (cond
- ((string-match regexp str)
- (substring str (match-beginning subexp) (match-end subexp)))
- (next
- (word-help-map-index-entries str next)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;; Switch mode files ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;;; Mode lookup
-
-(defun word-help-guess-help-file ()
- "Guesses a relevant help file based on mode name.
-Returns nil if no guess could be made. Uses `word-help-mode-alist'."
- (let (guess)
- (cond
- ((setq guess (assoc mode-name word-help-mode-alist))
- (car guess)))))
-
-
-(defun word-help-switch-help-file (helpfile)
- "Changes the help-file to the mode name given.
-Uses `word-help-mode-alist'."
- (if helpfile
- (let (helpdesc)
- (if (not (setq helpdesc (assoc helpfile word-help-mode-alist)))
- (message "No help defined for \"%s\"." helpfile)
- (if (stringp (cdr helpdesc))
- (word-help-switch-help-file (cdr helpdesc))
- (word-help-make-default-map
- helpdesc
- (list 'word-help-help-mode
- 'word-help-info-files
- 'word-help-keyword-regexps
- 'word-help-ignore-case
- 'word-help-index-mapper
- 'word-help-complete-list))))
- (setq word-help-main-index nil
- word-help-complete-index nil))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;; Index collection ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-
-(defun word-help-extract-index (file-name index-list index-map ignore-case)
- "Extract index from filename and the first node name in index list.
-`file-name' is the name of the info file, while `index-list' is a list
-of node-names to search."
- (let (cmd1 cmdlow nodename ob-array next (case-fold-search word-help-ignore-case))
- (setq nodename (car index-list))
- (setq ob-array (make-vector 211 0))
- (message "Processing \"%s\" in %s..." nodename file-name)
- (save-window-excursion
- (Info-goto-node (concat "(" file-name ")" nodename))
- (end-of-buffer)
- (while (re-search-backward "\\* \\([^\n:]+\\):" nil t)
- (setq cmd1 (buffer-substring (match-beginning 1) (match-end 1)))
- (setq cmdlow (if ignore-case (downcase cmd1) cmd1))
- (if index-map
- (setq cmdlow (word-help-map-index-entries cmdlow
- index-map)))
-;; We have to do this workaround to support case-insensitive matching
- (cond
- (cmdlow
- (put (intern cmdlow ob-array) 'word-help-real-name cmd1)
- (intern cmdlow word-help-main-obarray)))))
- (setq next (cond
- ((cdr index-list)
- (word-help-extract-index file-name (cdr index-list)
- index-map ignore-case))))
- (nconc (list (list nodename ob-array)) next)))
-
-
-(defun word-help-collect-indexes (info-file)
- "Process all the indexes in an info file.
-
-Uses `word-help-extract-index' on each node, and returns an entry
-suitable for merging into `word-help-process-indexes'. `info-file'
-is an entry of the form
-
-\(FILE-NAME INDEX-NAME-1 INDEX-NAME-2 ...)"
- (let ((file (car info-file))
- (nodes (cdr info-file)))
- (nconc (list file) (word-help-extract-index file nodes
- word-help-index-mapper
- word-help-ignore-case))))
-
-(defun word-help-process-indexes ()
- "Process all the entries in the global variable `word-help-info-files'.
-Returns a list formatted as follows:
-
-\(all-entries-ob
- (file-name-1 (node-name-1 this-node-entries-ob)
- (node-name-2 this-node-entries-ob)
- : : :
- (node-name-n this-node-entries-ob))
- (file-name-2 (node-name-1 this-node-entries-ob)
- (node-name-2 this-node-entries-ob)
- : : :
- (node-name-n this-node-entries-ob))
- : : : : : : : : :
- (file-name-n (node-name-1 this-node-entries-ob)
- (node-name-2 this-node-entries-ob)
- : : :
- (node-name-n this-node-entries-ob)))
-
-The symbols in the obarrays may contain the additional property
-`word-help-real-name', which tells the *real* node to go to.
-
-Note that we use `word-help-index-alist' to speed up the process. Note
-that `word-help-switch-help-file' must have been called before this function.
-
-This structure is then later searched by `word-help-find-index-node'."
- (let (index-words old-index)
- (if (not word-help-main-index)
- (cond
- ((setq old-index
- (assoc word-help-help-mode word-help-index-alist))
- (setq word-help-main-index (nth 1 old-index)))
- (word-help-info-files
- (setq word-help-main-obarray (make-vector 307 0)
- index-words (mapcar 'word-help-collect-indexes
- word-help-info-files)
- word-help-main-index
- (append (list word-help-main-obarray) index-words))
- (setq word-help-index-alist (cons (list word-help-help-mode
- word-help-main-index)
- word-help-index-alist)))
- (t (setq word-help-main-index t))))))
-
-(defun word-help-find-help-file ()
- "Tries to find and set a relevant help file for the current mode."
- (let (helpguess)
- (if (not word-help-info-files)
- (if (setq helpguess (word-help-guess-help-file))
- (word-help-switch-help-file helpguess)
- (set-help-file)))))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;; Keyword guess ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defun word-help-guess-all (cur-point re-list
- &optional copy-to-point)
- "Guesses *all* keywords the user possibly may be looking at.
-Returns a list of all possible keywords. "
- (let ((regexp (car (car re-list)))
- (submatch (cond ((nth 1 (car re-list))) (0)))
- (cursmatch (cond ((nth 2 (car re-list))) (0)))
- (guess nil)
- (next-guess nil)
- (case-fold-search word-help-ignore-case)
- (end-point nil))
- (save-excursion
- (end-of-line)
- (setq end-point (point))
- ;; Start at the beginning
- (beginning-of-line)
- (while (and (not guess) (re-search-forward regexp end-point t))
- ;; Look whether the cursor is within the match
- (if (and (<= (match-beginning cursmatch) cur-point)
- (>= (match-end cursmatch) cur-point))
- (if (or (not copy-to-point) (<= cur-point (match-end submatch)))
- (setq guess (buffer-substring (match-beginning submatch)
- (if copy-to-point
- cur-point
- (match-end submatch)))))))
- ;; If we found anything, return it and call ourselves again
- (if (cdr re-list)
- (setq next-guess (word-help-guess-all cur-point (cdr re-list)
- copy-to-point))))
- (cons guess next-guess)))
-
-(defun word-help-guess-match (all-match cmd-array)
- (let ((sym (car all-match)))
- (cond
- ((and sym (intern-soft (if word-help-ignore-case
- (downcase sym)
- sym) cmd-array)
- sym))
- ((cdr all-match)
- (word-help-guess-match (cdr all-match) cmd-array)))))
-
-
-(defun word-help-guess (cur-point cmd-array re-list)
- "Guesses what keyword the user is looking at, and returns that.
-CUR-POINT should be the current value of `point', CMD-ARRAY an obarray
-of all the keywords which are defined for the current mode, and
-RE-LIST a list of regexps use for the hunt. See also
-`word-help-keyword-regexps'."
- (let ((all-matches (word-help-guess-all cur-point re-list)))
-; (print all-matches)
- (word-help-guess-match all-matches cmd-array)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;; Show node for keyword ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;;; Find an index entry
-
-(defun word-help-find-index-node (node index-reg)
- "Finds the node named `node' in the index-register `index-reg'.
-`index-reg' has the format as returned (and documented) by the
-`word-help-process-indexes' call. In most cases, this will be equal to
-`word-help-main-index'.
-
-Returns a list with format
- (file-name index-node-name index-entry)
-which contains the file and index where the entry can be found.
-Returns nil if the entry can't be found."
- (let (file-info node-name)
- (setq node-name (cond (word-help-ignore-case (downcase node)) (node)))
- (if (intern-soft node-name (car index-reg))
- (setq file-info (word-help-index-search-file node-name
- (cdr index-reg))))
- file-info))
-
-(defun word-help-index-search-file (entry file-data)
- "Searches a cached file for the index-entry `entry'."
- (let (this-file next-files file-name node node-infos)
- (setq this-file (car file-data)
- next-files (cdr file-data)
- file-name (car this-file)
- node-infos (cdr this-file)
- node (word-help-index-search-nodes entry node-infos))
- (cond
- (node
- (cons file-name node))
- (next-files (word-help-index-search-file entry next-files)))))
-
-(defun word-help-index-search-nodes (entry node-info)
- "Searches a cached list of nodes for the entry `entry'."
- (let (this-node next-nodes node-name node-ob node-sym)
- (setq this-node (car node-info)
- next-nodes (cdr node-info)
- node-name (car this-node)
- node-ob (car (cdr this-node))
- node-sym (intern-soft entry node-ob))
- (cond
- (node-sym
- (list node-name (get node-sym 'word-help-real-name)))
- (next-nodes (word-help-index-search-nodes entry next-nodes)))))
-
-;;; Switch to a node in an index
-
-(defun word-help-goto-index-node (index-info)
- "Jumps to an index node.
-`index-info' should be a list with the following format:
-
-\(FILE-NAME INDEX-NODE-NAME INDEX-ENTRY KEYWORD)"
-
- (let* ((file-name (car index-info))
- (node-name (nth 1 index-info))
- (entry-name (nth 2 index-info))
- (kw-name (nth 3 index-info))
- (buffer (current-buffer)))
- (if word-help-split-window
- (pop-to-buffer nil))
- (Info-goto-node (concat "(" file-name ")" node-name))
- (Info-menu entry-name)
-;; Do magic keyword search
- (if word-help-magic-index
- (let (end-point regs this-re found entry-re)
- (setq entry-re (regexp-quote kw-name)
- regs (list (concat
- (if (string-match "^[A-Za-z]" entry-name)
- "\\<" "")
- entry-re
- (if (string-match "[A-Za-z]$" entry-name)
- "\\>" ""))
- (concat "[`\"\(]" entry-re)
- (concat "^" entry-re
- (if (string-match "[A-Za-z]$" entry-name)
- "\\>" ""))))
- (end-of-line)
- (setq end-point (point))
- (beginning-of-line)
- (if (not (re-search-forward (car regs) end-point t))
- (while (and (not found) (car regs))
- (setq this-re (car regs)
- regs (cdr regs)
- found (re-search-forward this-re nil t))))
- (recenter 0)))
- (if word-help-split-window
- (pop-to-buffer buffer))))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Completion ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-
-
-(defun word-help-extract-matches (from-ob dest-ob re-list)
- "Takes atoms from from-ob, and puts them in dest-ob if they match re-list."
- (let ((regexp (car (car re-list))))
- (mapatoms (lambda (x)
- (if (or (not regexp) (string-match regexp (symbol-name x)))
- (intern (symbol-name x) dest-ob)))
- from-ob)
- (if (cdr re-list)
- (word-help-extract-matches from-ob dest-ob (cdr re-list))))
- dest-ob)
-
-(defun word-help-make-complete ()
- "Generates the `word-help-complete-index'."
- (if word-help-complete-index
- nil
- (word-help-find-help-file)
- (cond
- ((symbolp word-help-complete-list)
- (setq word-help-complete-index word-help-complete-list))
- (t
- (word-help-process-indexes)
- (if (not (atom word-help-main-index))
- (let ((from-ob (car word-help-main-index)))
- (message "Processing keywords...")
- (setq word-help-complete-index
- (mapcar
- (lambda (cmpl)
- (let
- ((regexp (car cmpl))
- (subm (cond ((nth 1 cmpl)) (0)))
- (app (cond ((nth 2 cmpl)) ("")))
- (re-list (cond ((nth 3 cmpl)) ('((".")))))
- (obarr (make-vector 47 0)))
- (list regexp subm subm app
- (word-help-extract-matches from-ob obarr
- re-list))))
- word-help-complete-list))))))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Misc. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-
-;;; Default mapping
-
-(defun word-help-make-default-map (list vars)
- "Makes a default mapping for `vars', which must be listed in order.
-vars is a list of quoted symbols. If the nth entry in the list is
-non-nil, the nth variable will be given this value. If nil, the var
-will be given the global default value."
- (set (car vars) (cond ((car list)) ((default-value (car vars)))))
- (if (cdr vars)
- (word-help-make-default-map (cdr list) (cdr vars))))
-
-(provide 'word-help)
-
-;;; word-help.el ends here
+++ /dev/null
-@c -*-texinfo-*-
-@setfilename ../info/locals
-@node Standard Buffer-Local Variables, Standard Keymaps, Standard Errors, Top
-@appendix Standard Buffer-Local Variables
-
- The table below shows all of the variables that are automatically
-local (when set) in each buffer in Emacs Version 18 with the common
-packages loaded.
-
-@table @code
-@item abbrev-mode
-@xref{Abbrevs}.
-
-@item auto-fill-function
-@xref{Auto Filling}.
-
-@item buffer-auto-save-file-name
-@xref{Auto-Saving}.
-
-@item buffer-backed-up
-@xref{Backup Files}.
-
-@item buffer-display-table
-@xref{Active Display Table}.
-
-@item buffer-file-name
-@xref{Buffer File Name}.
-
-@item buffer-file-truename
-@xref{Buffer File Name}.
-
-@item buffer-read-only
-@xref{Read Only Buffers}.
-
-@item buffer-saved-size
-@xref{Point}.
-
-@item case-fold-search
-@xref{Searching and Case}.
-
-@item ctl-arrow
-@xref{Control Char Display}.
-
-@item default-directory
-@xref{System Environment}.
-
-@item fill-column
-@xref{Auto Filling}.
-
-@item left-margin
-@xref{Indentation}.
-
-@item list-buffers-directory
-@xref{Buffer File Name}.
-
-@item local-abbrev-table
-@xref{Abbrevs}.
-
-@item major-mode
-@xref{Mode Help}.
-
-@item mark-ring
-@xref{The Mark}.
-
-@item minor-modes
-@xref{Minor Modes}.
-
-@item mode-name
-@xref{Mode Line Variables}.
-
-@item overwrite-mode
-@xref{Insertion}.
-
-@item paragraph-separate
-@xref{Standard Regexps}.
-
-@item paragraph-start
-@xref{Standard Regexps}.
-
-@item require-final-newline
-@xref{Insertion}.
-
-@item selective-display
-@xref{Selective Display}.
-
-@item selective-display-ellipses
-@xref{Selective Display}.
-
-@item tab-width
-@xref{Control Char Display}.
-
-@item truncate-lines
-@xref{Truncation}.
-@end table
+++ /dev/null
-/* GNU Emacs site configuration template file. -*- C -*-
- Copyright (C) 1988, 1993, 1994 Free Software Foundation, Inc.
-
-This file is part of GNU Emacs.
-
-GNU Emacs is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Emacs is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Emacs; see the file COPYING. If not, write to
-the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-Boston, MA 02111-1307, USA. */
-
-
-/* No code in Emacs #includes config.h twice, but some of the code
- intended to work with other packages as well (like gmalloc.c)
- think they can include it as many times as they like. */
-#ifndef EMACS_CONFIG_H
-#define EMACS_CONFIG_H
-
-
-/* These are all defined in the top-level Makefile by configure.
- They're here only for reference. */
-
-/* Define LISP_FLOAT_TYPE if you want emacs to support floating-point
- numbers. */
-#undef LISP_FLOAT_TYPE
-
-/* Define GNU_MALLOC if you want to use the *new* GNU memory allocator. */
-#undef GNU_MALLOC
-
-/* Define REL_ALLOC if you want to use the relocating allocator for
- buffer space. */
-#undef REL_ALLOC
-
-/* Define HAVE_X_WINDOWS if you want to use the X window system. */
-#undef HAVE_X_WINDOWS
-
-/* Define HAVE_X11 if you want to use version 11 of X windows.
- Otherwise, Emacs expects to use version 10. */
-#undef HAVE_X11
-
-/* Define if using an X toolkit. */
-#undef USE_X_TOOLKIT
-
-/* Define this if you're using XFree386. */
-#undef HAVE_XFREE386
-
-/* Define HAVE_X_MENU if you want to use the X window menu system.
- This appears to work on some machines that support X
- and not on others. */
-#undef HAVE_X_MENU
-
-/* Define if we have the X11R6 or newer version of Xt. */
-#undef HAVE_X11XTR6
-
-/* Define if netdb.h declares h_errno. */
-#undef HAVE_H_ERRNO
-
-/* Nowadays we have frame objects even if we support only ASCII terminals. */
-#define MULTI_FRAME
-
-/* If we're using any sort of window system, define some consequences. */
-#ifdef HAVE_X_WINDOWS
-#define HAVE_WINDOW_SYSTEM
-#define MULTI_KBOARD
-#define HAVE_FACES
-#define HAVE_MOUSE
-#endif
-
-/* Define USE_TEXT_PROPERTIES to support visual and other properties
- on text. */
-#define USE_TEXT_PROPERTIES
-
-/* Define USER_FULL_NAME to return a string
- that is the user's full name.
- It can assume that the variable `pw'
- points to the password file entry for this user.
-
- At some sites, the pw_gecos field contains
- the user's full name. If neither this nor any other
- field contains the right thing, use pw_name,
- giving the user's login name, since that is better than nothing. */
-#define USER_FULL_NAME pw->pw_gecos
-
-/* Define AMPERSAND_FULL_NAME if you use the convention
- that & in the full name stands for the login id. */
-#undef AMPERSAND_FULL_NAME
-
-/* Things set by --with options in the configure script. */
-
-/* Define to support POP mail retrieval. */
-#undef MAIL_USE_POP
-
-/* Define to support Kerberos-authenticated POP mail retrieval. */
-#undef KERBEROS
-
-/* Define to support using a Hesiod database to find the POP server. */
-#undef HESIOD
-
-/* Some things figured out by the configure script, grouped as they are in
- configure.in. */
-#ifndef _ALL_SOURCE /* suppress warning if this is pre-defined */
-#undef _ALL_SOURCE
-#endif
-#undef HAVE_SYS_SELECT_H
-#undef HAVE_SYS_TIMEB_H
-#undef HAVE_SYS_TIME_H
-#undef HAVE_UNISTD_H
-#undef HAVE_UTIME_H
-#undef STDC_HEADERS
-#undef TIME_WITH_SYS_TIME
-
-#undef HAVE_LIBDNET
-#undef HAVE_LIBPTHREADS
-#undef HAVE_LIBRESOLV
-
-#undef HAVE_ALLOCA_H
-
-#undef HAVE_GETTIMEOFDAY
-#undef GETTIMEOFDAY_ONE_ARGUMENT
-#undef HAVE_GETHOSTNAME
-#undef HAVE_DUP2
-#undef HAVE_RENAME
-#undef HAVE_CLOSEDIR
-
-#undef TM_IN_SYS_TIME
-#undef HAVE_TM_ZONE
-#undef HAVE_TZNAME
-
-#undef const
-
-#undef HAVE_LONG_FILE_NAMES
-
-#undef CRAY_STACKSEG_END
-
-#undef UNEXEC_SRC
-
-#undef HAVE_LIBXBSD
-#undef HAVE_XRMSETDATABASE
-#undef HAVE_XSCREENRESOURCESTRING
-#undef HAVE_XSCREENNUMBEROFSCREEN
-#undef HAVE_XSETWMPROTOCOLS
-
-#undef HAVE_MKDIR
-#undef HAVE_RMDIR
-#undef HAVE_RANDOM
-#undef HAVE_LRAND48
-#undef HAVE_BCOPY
-#undef HAVE_BCMP
-#undef HAVE_LOGB
-#undef HAVE_FREXP
-#undef HAVE_FMOD
-#undef HAVE_FTIME
-#undef HAVE_RES_INIT /* For -lresolv on Suns. */
-#undef HAVE_SETSID
-#undef HAVE_FPATHCONF
-#undef HAVE_SELECT
-#undef HAVE_MKTIME
-#undef HAVE_EACCESS
-#undef HAVE_GETPAGESIZE
-#undef HAVE_INET_SOCKETS
-
-#undef HAVE_AIX_SMT_EXP
-
-/* Define if you have the ANSI `strerror' function.
- Otherwise you must have the variable `char *sys_errlist[]'. */
-#undef HAVE_STRERROR
-
-#undef HAVE_UTIMES
-
-/* Define if `sys_siglist' is declared by <signal.h>. */
-#undef SYS_SIGLIST_DECLARED
-
-/* Define if `struct utimbuf' is declared by <utime.h>. */
-#undef HAVE_STRUCT_UTIMBUF
-
-/* Define if `struct timeval' is declared by <sys/time.h>. */
-#undef HAVE_TIMEVAL
-
-/* If using GNU, then support inline function declarations. */
-#ifdef __GNUC__
-#define INLINE __inline__
-#else
-#define INLINE
-#endif
-
-#undef EMACS_CONFIGURATION
-
-#undef EMACS_CONFIG_OPTIONS
-
-/* The configuration script defines opsysfile to be the name of the
- s/SYSTEM.h file that describes the system type you are using. The file
- is chosen based on the configuration name you give.
-
- See the file ../etc/MACHINES for a list of systems and the
- configuration names to use for them.
-
- See s/template.h for documentation on writing s/SYSTEM.h files. */
-#undef config_opsysfile
-#include "s/windows95.h"
-
-/* The configuration script defines machfile to be the name of the
- m/MACHINE.h file that describes the machine you are using. The file is
- chosen based on the configuration name you give.
-
- See the file ../etc/MACHINES for a list of machines and the
- configuration names to use for them.
-
- See m/template.h for documentation on writing m/MACHINE.h files. */
-#undef config_machfile
-#include "m/intel386.h"
-
-/* These typedefs shouldn't appear when alloca.s or Makefile.in
- includes config.h. */
-#ifndef NOT_C_CODE
-#ifndef SPECIAL_EMACS_INT
-typedef long EMACS_INT;
-typedef unsigned long EMACS_UINT;
-#endif
-#endif
-
-/* Load in the conversion definitions if this system
- needs them and the source file being compiled has not
- said to inhibit this. There should be no need for you
- to alter these lines. */
-
-#ifdef SHORTNAMES
-#ifndef NO_SHORTNAMES
-#include "../shortnames/remap.h"
-#endif /* not NO_SHORTNAMES */
-#endif /* SHORTNAMES */
-
-/* If no remapping takes place, static variables cannot be dumped as
- pure, so don't worry about the `static' keyword. */
-#ifdef NO_REMAP
-#undef static
-#endif
-
-/* Define `subprocesses' should be defined if you want to
- have code for asynchronous subprocesses
- (as used in M-x compile and M-x shell).
- These do not work for some USG systems yet;
- for the ones where they work, the s/SYSTEM.h file defines this flag. */
-
-#ifndef VMS
-#ifndef USG
-/* #define subprocesses */
-#endif
-#endif
-
-/* Define LD_SWITCH_SITE to contain any special flags your loader may need. */
-#undef LD_SWITCH_SITE
-
-/* Define C_SWITCH_SITE to contain any special flags your compiler needs. */
-#undef C_SWITCH_SITE
-
-/* Define LD_SWITCH_X_SITE to contain any special flags your loader
- may need to deal with X Windows. For instance, if you've defined
- HAVE_X_WINDOWS above and your X libraries aren't in a place that
- your loader can find on its own, you might want to add "-L/..." or
- something similar. */
-#undef LD_SWITCH_X_SITE
-
-/* Define LD_SWITCH_X_SITE_AUX with an -R option
- in case it's needed (for Solaris, for example). */
-#undef LD_SWITCH_X_SITE_AUX
-
-/* Define C_SWITCH_X_SITE to contain any special flags your compiler
- may need to deal with X Windows. For instance, if you've defined
- HAVE_X_WINDOWS above and your X include files aren't in a place
- that your compiler can find on its own, you might want to add
- "-I/..." or something similar. */
-#undef C_SWITCH_X_SITE
-
-/* Define STACK_DIRECTION here, but not if m/foo.h did. */
-#ifndef STACK_DIRECTION
-#undef STACK_DIRECTION
-#endif
-
-/* Define the return type of signal handlers if the s-xxx file
- did not already do so. */
-#define RETSIGTYPE void
-
-/* SIGTYPE is the macro we actually use. */
-#ifndef SIGTYPE
-#define SIGTYPE RETSIGTYPE
-#endif
-
-#ifdef emacs /* Don't do this for lib-src. */
-/* Tell regex.c to use a type compatible with Emacs. */
-#define RE_TRANSLATE_TYPE Lisp_Object *
-#endif
-
-/* The rest of the code currently tests the CPP symbol BSTRING.
- Override any claims made by the system-description files.
- Note that on some SCO version it is possible to have bcopy and not bcmp. */
-#undef BSTRING
-#if defined (HAVE_BCOPY) && defined (HAVE_BCMP)
-#define BSTRING
-#endif
-
-/* Non-ANSI C compilers usually don't have volatile. */
-#ifndef HAVE_VOLATILE
-#ifndef __STDC__
-#define volatile
-#endif
-#endif
-
-/* Some of the files of Emacs which are intended for use with other
- programs assume that if you have a config.h file, you must declare
- the type of getenv.
-
- This declaration shouldn't appear when alloca.s or Makefile.in
- includes config.h. */
-#ifndef NOT_C_CODE
-extern char *getenv ();
-#endif
-
-#endif /* EMACS_CONFIG_H */
-
-/* These default definitions are good for almost all machines.
- The exceptions override them in m/*.h. */
-
-#ifndef BITS_PER_CHAR
-#define BITS_PER_CHAR 8
-#endif
-
-#ifndef BITS_PER_SHORT
-#define BITS_PER_SHORT 16
-#endif
-
-/* Note that lisp.h uses this in a preprocessor conditional, so it
- would not work to use sizeof. That being so, we do all of them
- without sizeof, for uniformity's sake. */
-#ifndef BITS_PER_INT
-#define BITS_PER_INT 32
-#endif
-
-#ifndef BITS_PER_LONG
-#define BITS_PER_LONG 32
-#endif
+++ /dev/null
-@echo off \r
-set emacs_dir=c:\emacs\r
-\r
-REM Here begins emacs.bat.in\r
-\r
-REM Set OS specific values.\r
-set ARCH_SAVE=%PROCESSOR_ARCHITECTURE%\r
-set PROCESSOR_ARCHITECTURE=\r
-if "%ARCH_SAVE%" == "%PROCESSOR_ARCHITECTURE%" goto win95\r
-set PROCESSOR_ARCHITECTURE=%ARCH_SAVE%\r
-set SHELL=cmd\r
-goto next\r
-\r
-:win95\r
-set SHELL=command\r
-\r
-:next\r
-\r
-set EMACSLOADPATH=%emacs_dir%\lisp\r
-set EMACSDATA=%emacs_dir%\etc\r
-set EMACSPATH=%emacs_dir%\bin\r
-set EMACSLOCKDIR=%emacs_dir%\lock\r
-set INFOPATH=%emacs_dir%\info\r
-set EMACSDOC=%emacs_dir%\etc\r
-set TERM=CMD\r
-\r
-REM The variable HOME is used to find the startup file, ~\_emacs. Ideally,\r
-REM this will not be set in this file but should already be set before\r
-REM this file is invoked. If HOME is not set, use some generic default.\r
-\r
-set HOME_SAVE=%HOME%\r
-set HOME_EXISTS=yes\r
-set HOME_DEFAULT=C:\\r
-set HOME=\r
-if "%HOME%" == "%HOME_SAVE%" set HOME_EXISTS=no\r
-if "%HOME_EXISTS%" == "yes" set HOME=%HOME_SAVE%\r
-if "%HOME_EXISTS%" == "no" set HOME=%HOME_DEFAULT%\r
-if "%HOME_EXISTS%" == "no" echo HOME is not set! Using %HOME% as a default...\r
-\r
-start c:\msdev\bin\msdev -nologo %emacs_dir%\bin\emacs.exe %1 %2 %3 %4 %5 %6 %7 %8 %9\r
+++ /dev/null
-@echo off\r
-\r
-REM Change this to the directory into which you installed Emacs:\r
-set emacs_path=C:\emacs\r
-\r
-REM\r
-REM You shouldn't have to change any of the below.\r
-REM\r
-\r
-REM Set OS specific values.\r
-set ARCH_SAVE=%PROCESSOR_ARCHITECTURE%\r
-set PROCESSOR_ARCHITECTURE=\r
-if "%ARCH_SAVE%" == "%PROCESSOR_ARCHITECTURE%" goto win95\r
-set PROCESSOR_ARCHITECTURE=%ARCH_SAVE%\r
-set SHELL=cmd\r
-goto next\r
-\r
-:win95\r
-set SHELL=command\r
-\r
-:next\r
-\r
-set EMACSLOADPATH=%emacs_path%\lisp\r
-set EMACSDATA=%emacs_path%\etc\r
-set EMACSPATH=%emacs_path%\bin\r
-set EMACSLOCKDIR=%emacs_path%\lock\r
-set INFOPATH=%emacs_path%\info\r
-set EMACSDOC=%emacs_path%\etc\r
-set TERM=CMD\r
-\r
-REM The variable HOME is used to find the startup file, ~\_emacs. Ideally,\r
-REM this will not be set in this file but should already be set before\r
-REM this file is invoked. If HOME is not set, use some generic default.\r
-\r
-set HOME_SAVE=%HOME%\r
-set HOME_EXISTS=yes\r
-set HOME_DEFAULT=C:\\r
-set HOME=\r
-if "%HOME%" == "%HOME_SAVE%" set HOME_EXISTS=no\r
-if "%HOME_EXISTS%" == "yes" set HOME=%HOME_SAVE%\r
-if "%HOME_EXISTS%" == "no" set HOME=%HOME_DEFAULT%\r
-if "%HOME_EXISTS%" == "no" echo HOME is not set! Using %HOME% as a default...\r
-\r
-%emacs_path%\bin\emacs.exe %1 %2 %3 %4 %5 %6 %7 %8 %9\r
+++ /dev/null
- Building and Installing Emacs
- on Windows NT and Windows 95
-
-You need a compiler package to build and install Emacs on NT or Win95.
-If you don't have one, precompiled versions are available in
-ftp://ftp.cs.washington.edu/pub/ntemacs/<version>.
-
-Configuring:
-
-(1) In previous versions, you needed to edit makefile.def
- to reflect the compiler package that you are using. You should no
- longer have to do this if you have defined the INCLUDE and LIB
- environment variables, as is customary for use with Windows compilers.
- (Unless you are using MSVCNT 1.1, in which case you will need
- to set MSVCNT11 to be a non-zero value at the top of makefile.def.)
-
-(2) Choose the directory into which Emacs will be installed, and
- edit makefile.def to define INSTALL_DIR to be this directory.
- (Alternatively, if you have INSTALL_DIR set as an environment
- variable, the build process will ignore the value in makefile.def
- and use the value of the environment variable instead.) Note
- that if it is not installed in the directory in which it is built,
- the ~16 MB of lisp files will be copied into the installation directory.
-
- Also, makefile.def is sometimes unpacked read-only; use
-
- > attrib -r makefile.def
-
- to make it writable.
-
-(3) You may need to edit nt/paths.h to specify some other device
- instead of `C:'.
-
-Building:
-
-(4) The target to compile the sources is "all", and is recursive starting
- one directory up. The makefiles for the NT port are in files named
- "makefile.nt". To get things started, type in this directory:
-
- > nmake -f makefile.nt all
-
- or use the ebuild.bat file.
-
- When the files are compiled, you will see some warning messages declaring
- that some functions don't return a value, or that some data conversions
- will be lossy, etc. You can safely ignore these messages. The warnings
- may be fixed in the main FSF source at some point, but until then we
- will just live with them.
-
- NOTE: You should not have to edit src\paths.h to get Emacs to run
- correctly. All of the variables in src\paths.h are configured
- during start up using the nt\emacs.bat file (which gets installed
- as bin\emacs.bat -- see below).
-
-Installing:
-
-(5) Currently, Emacs requires a number of environment variables to be set
- for it to run correctly. A batch file, emacs.bat, is provided that
- sets these variables appropriately and then runs the executable
- (emacs.bat is generated using the definition of INSTALL_DIR in
- nt\makefile.def and the contents of nt\emacs.bat.in).
-
-(6) The install process will install the files necessary to run Emacs in
- INSTALL_DIR (which may be the directory in which it was built),
- and create a program manager/folder icon in a folder called GNU Emacs.
- From this directory, type:
-
- > nmake -f makefile.nt install
-
- or use the install.bat file.
-
-(7) Create the Emacs startup file. Under Unix, this file is .emacs;
- under NT and Win95, this files is _emacs. (If you would like to
- use a .emacs file that, for example, you share with a Unix version
- of Emacs, you can invoke Emacs with the -l option to specify the
- .emacs file that you would like to load.) Note that Emacs requires
- the environment variable HOME to be set in order for it to locate the
- _emacs file. Ideally, HOME should not be set in the emacs.bat file
- as it will be different for each user. (HOME could be set,
- for example, in the System panel of the Control Panel).
-
-(8) Either click on the icon, or run the emacs.bat file, and away you go.
-
- If you would like to resize the command window that Emacs uses,
- or change the font or colors, click on the program manager icon
- to start Emacs. Change the settings using the "-" menu in the upper
- left hand corner of the window, making sure to select the "Save"
- options in the dialog boxes as you do so. Exit Emacs and restart.
+++ /dev/null
-# Makefile for GNU Emacs.
-# Copyright (C) 1985, 87, 88, 93, 94, 95, 99, 2000, 2001
-# Free Software Foundation, Inc.
-
-# This file is part of GNU Emacs.
-
-# GNU Emacs is free software; you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 2, or (at your option)
-# any later version.
-
-# GNU Emacs is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-
-# You should have received a copy of the GNU General Public License
-# along with GNU Emacs; see the file COPYING. If not, write to
-# the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-# Boston, MA 02111-1307, USA.
-
-
-# Note that this file is edited by msdos/sed1v2.inp for MSDOS. That
-# script may need modifying in sync with changes made here. Try to
-# avoid shell-ism because the DOS build has to use the DOS shell.
-
-# Don't try to replace the ccp processing using autoconf facilities,
-# says rms.
-
-# Here are the things that we expect ../configure to edit.
-# We use $(srcdir) explicitly in dependencies so as not to depend on VPATH.
-srcdir=@srcdir@
-VPATH=@srcdir@
-CC=@CC@
-CPP=@CPP@
-CFLAGS=@CFLAGS@
-CPPFLAGS=@CPPFLAGS@
-LDFLAGS=@LDFLAGS@
-LN_S=@LN_S@
-# Substitute an assignment for the MAKE variable, because
-# BSD doesn't have it as a default.
-@SET_MAKE@
-# Don't use LIBS. configure puts stuff in it that either shouldn't be
-# linked with Emacs or is duplicated by the cpp stuff below.
-# LIBS = @LIBS@
-LIBOBJS = @LIBOBJS@
-
-# On Xenix and the IBM RS6000, double-dot gets screwed up.
-dot = .
-dotdot = ${dot}${dot}
-lispsource = ${srcdir}/$(dot)$(dot)/lisp/
-libsrc = $(dot)$(dot)/lib-src/
-etc = $(dot)$(dot)/etc/
-oldXMenudir = $(dot)$(dot)/oldXMenu/
-lwlibdir = $(dot)$(dot)/lwlib/
-
-# Configuration files for .o files to depend on.
-M_FILE = ${srcdir}/@machfile@
-S_FILE = ${srcdir}/@opsysfile@
-config_h = config.h $(M_FILE) $(S_FILE)
-
-# ========================== start of cpp stuff =======================
-/* From here on, comments must be done in C syntax. */
-
-C_SWITCH_SYSTEM=
-
-/* just to be sure the sh is used */
-SHELL=/bin/sh
-
-#define THIS_IS_MAKEFILE
-#define NO_SHORTNAMES
-#define NOT_C_CODE
-#include "config.h"
-
-/* We won't really call alloca;
- don't let the file name alloca.c get messed up. */
-#ifdef alloca
-#undef alloca
-#endif
-
-/* Don't let the file name mktime.c get messed up. */
-#ifdef mktime
-#undef mktime
-#endif
-
-/* Use HAVE_X11 as an alias for X11 in this file
- to avoid problems with X11 as a subdirectory name
- in -I and other such options which pass through this file. */
-
-#ifdef X11
-#define HAVE_X11
-#undef X11
-#endif
-
-/* On some machines #define register is done in config;
- don't let it interfere with this file. */
-#undef register
-
-/* On some systems we may not be able to use the system make command. */
-#ifdef MAKE_COMMAND
-MAKE = MAKE_COMMAND
-#endif
-
-#ifdef C_COMPILER
-CC = C_COMPILER
-#endif
-
-/* GNU libc requires ORDINARY_LINK so that its own crt0 is used.
- Linux is an exception because it uses a funny variant of GNU libc. */
-#ifdef __GNU_LIBRARY__
-#ifndef LINUX
-#define ORDINARY_LINK
-#endif
-#endif
-
-/* Some machines don't find the standard C libraries in the usual place. */
-#ifndef ORDINARY_LINK
-#ifndef LIB_STANDARD
-#define LIB_STANDARD -lc
-#endif
-#else
-#ifndef LIB_STANDARD
-#define LIB_STANDARD
-#endif
-#endif
-
-/* Unless inhibited or changed, use -lg to link for debugging. */
-#ifndef LIBS_DEBUG
-#define LIBS_DEBUG -lg
-#endif
-
-/* Some s/SYSTEM.h files define this to request special libraries. */
-#ifndef LIBS_SYSTEM
-#define LIBS_SYSTEM
-#endif
-
-/* Some m/MACHINE.h files define this to request special libraries. */
-#ifndef LIBS_MACHINE
-#define LIBS_MACHINE
-#endif
-
-#ifndef LIB_MATH
-# define LIB_MATH -lm
-#endif /* LIB_MATH */
-
-/* Some s/SYSTEM.h files define this to request special switches in ld. */
-#ifndef LD_SWITCH_SYSTEM
-#if !defined (__GNUC__) && (defined(COFF_ENCAPSULATE) || (defined (BSD_SYSTEM) && !defined (COFF)))
-#define LD_SWITCH_SYSTEM -X
-#else /* ! defined(COFF_ENCAPSULATE) || (defined (BSD_SYSTEM) && !defined (COFF)) */
-#define LD_SWITCH_SYSTEM
-#endif /* ! defined(COFF_ENCAPSULATE) || (defined (BSD_SYSTEM) && !defined (COFF)) */
-#endif /* LD_SWITCH_SYSTEM */
-
-/* This holds special options for linking temacs
- that should be used for linking anything else. */
-#ifndef LD_SWITCH_SYSTEM_TEMACS
-#define LD_SWITCH_SYSTEM_TEMACS
-#endif
-
-/* Some m/MACHINE.h files define this to request special switches in ld. */
-#ifndef LD_SWITCH_MACHINE
-#define LD_SWITCH_MACHINE
-#endif
-
-/* This holds special options for linking temacs
- that should be used for linking anything else. */
-#ifndef LD_SWITCH_MACHINE_TEMACS
-#define LD_SWITCH_MACHINE_TEMACS
-#endif
-
-/* Some m/MACHINE.h files define this to request special switches in cc. */
-#ifndef C_SWITCH_MACHINE
-#define C_SWITCH_MACHINE
-#endif
-
-/* Some s/SYSTEM.h files define this to request special switches in cc. */
-#ifndef C_SWITCH_SYSTEM
-#define C_SWITCH_SYSTEM
-#endif
-
-/* These macros are for switches specifically related to X Windows. */
-#ifndef C_SWITCH_X_MACHINE
-#define C_SWITCH_X_MACHINE
-#endif
-
-#ifndef C_SWITCH_X_SYSTEM
-#define C_SWITCH_X_SYSTEM
-#endif
-
-#ifndef C_SWITCH_X_SITE
-#define C_SWITCH_X_SITE
-#endif
-
-#ifndef LD_SWITCH_X_SITE
-#define LD_SWITCH_X_SITE
-#endif
-
-#ifndef LD_SWITCH_X_DEFAULT
-#define LD_SWITCH_X_DEFAULT
-#endif
-
-/* These can be passed in from config.h to define special load and
- compile switches needed by individual sites */
-#ifndef LD_SWITCH_SITE
-#define LD_SWITCH_SITE
-#endif
-
-#ifndef C_SWITCH_SITE
-#define C_SWITCH_SITE
-#endif
-
-#ifndef ORDINARY_LINK
-
-#ifndef CRT0_COMPILE
-#define CRT0_COMPILE $(CC) -c $(ALL_CFLAGS) C_SWITCH_ASM
-#endif
-
-#ifndef START_FILES
-#ifdef NO_REMAP
-#ifdef COFF_ENCAPSULATE
-#define START_FILES pre-crt0.o /usr/local/lib/gcc-crt0.o
-#else /* ! defined (COFF_ENCAPSULATE) */
-#define START_FILES pre-crt0.o /lib/crt0.o
-#endif /* ! defined (COFF_ENCAPSULATE) */
-#else /* ! defined (NO_REMAP) */
-#define START_FILES ecrt0.o
-#endif /* ! defined (NO_REMAP) */
-#endif /* START_FILES */
-STARTFILES = START_FILES
-
-#else /* ORDINARY_LINK */
-
-/* config.h might want to force START_FILES anyway */
-#ifdef START_FILES
-STARTFILES = START_FILES
-#endif /* START_FILES */
-
-#endif /* not ORDINARY_LINK */
-
-
-/* cc switches needed to make `asm' keyword work.
- Nothing special needed on most machines. */
-#ifndef C_SWITCH_ASM
-#define C_SWITCH_ASM
-#endif
-
-#ifdef USE_X_TOOLKIT
-#define USE_@X_TOOLKIT_TYPE@
-TOOLKIT_DEFINES = -DUSE_@X_TOOLKIT_TYPE@
-#else
-TOOLKIT_DEFINES =
-#endif
-
-/* DO NOT use -R. There is a special hack described in lastfile.c
- which is used instead. Some initialized data areas are modified
- at initial startup, then labeled as part of the text area when
- Emacs is dumped for the first time, and never changed again. */
-
-/* -Demacs is needed to make some files produce the correct version
- for use in Emacs.
-
- -DHAVE_CONFIG_H is needed for some other files to take advantage of
- the information in `config.h'. */
-
-/* C_SWITCH_X_SITE must come before C_SWITCH_X_MACHINE and C_SWITCH_X_SYSTEM
- since it may have -I options that should override those two. */
-ALL_CFLAGS=-Demacs -DHAVE_CONFIG_H $(TOOLKIT_DEFINES) $(MYCPPFLAG) -I. -I${srcdir} C_SWITCH_MACHINE C_SWITCH_SYSTEM C_SWITCH_SITE C_SWITCH_X_SITE C_SWITCH_X_MACHINE C_SWITCH_X_SYSTEM ${CFLAGS}
-.c.o:
- $(CC) -c $(CPPFLAGS) $(ALL_CFLAGS) $<
-
-#ifndef LIBX10_MACHINE
-#define LIBX10_MACHINE
-#endif
-
-#ifndef LIBX11_MACHINE
-#define LIBX11_MACHINE
-#endif
-
-#ifndef LIBX10_SYSTEM
-#define LIBX10_SYSTEM
-#endif
-
-#ifndef LIBX11_SYSTEM
-#define LIBX11_SYSTEM
-#endif
-
-#ifndef LIB_X11_LIB
-#define LIB_X11_LIB -lX11
-#endif
-
-#ifdef HAVE_X_WINDOWS
-#ifdef HAVE_MENUS
-
-/* Include xmenu.o in the list of X object files. */
-XOBJ= xterm.o xfns.o xselect.o xrdb.o fontset.o
-
-/* The X Menu stuff is present in the X10 distribution, but missing
- from X11. If we have X10, just use the installed library;
- otherwise, use our own copy. */
-#ifdef HAVE_X11
-#ifdef USE_X_TOOLKIT
-OLDXMENU=${lwlibdir}liblw.a
-LIBXMENU= $(OLDXMENU)
-#else /* not USE_X_TOOLKIT */
-OLDXMENU= ${oldXMenudir}libXMenu11.a
-LIBXMENU= $(OLDXMENU)
-#endif /* not USE_X_TOOLKIT */
-#else /* not HAVE_X11 */
-LIBXMENU= -lXMenu
-#endif /* not HAVE_X11 */
-
-#else /* not HAVE_MENUS */
-
-/* Otherwise, omit xmenu.o from the list of X object files, and
- don't worry about the menu library at all. */
-XOBJ= xterm.o xfns.o xselect.o xrdb.o fontset.o
-LIBXMENU=
-#endif /* not HAVE_MENUS */
-
-#ifdef USE_X_TOOLKIT
-#define @X_TOOLKIT_TYPE@
-#if defined (LUCID) || defined (ATHENA)
-#if HAVE_XAW3D
-LIBW= -lXaw3d
-#else
-LIBW= -lXaw
-#endif
-#endif
-#ifdef MOTIF
-#if defined (HAVE_MOTIF_2_1) && defined (HAVE_LIBXP)
-#define LIB_MOTIF_EXTRA -lXp
-#else
-#define LIB_MOTIF_EXTRA
-#endif
-#ifdef LIB_MOTIF
-LIBW= LIB_MOTIF LIB_MOTIF_EXTRA
-#else
-LIBW= -lXm LIB_MOTIF_EXTRA
-#endif
-#endif
-#ifdef OPEN_LOOK
-LIBW= -lXol
-#endif
-
-#ifdef HAVE_X11XTR6
-#ifdef NEED_LIBW
-LIBXTR6 = -lSM -lICE -lw
-#else
-LIBXTR6 = -lSM -lICE
-#endif
-#endif
-
-#ifndef LIBXMU
-#define LIBXMU -lXmu
-#endif
-
-#ifdef LIBXT_STATIC
-/* We assume the config files have defined STATIC_OPTION
- since that might depend on the operating system.
- (Don't forget you need different definitions with and without __GNUC__.) */
-LIBXT= STATIC_OPTION $(LIBW) LIBXMU -lXt $(LIBXTR6) -lXext DYNAMIC_OPTION
-#else /* not LIBXT_STATIC */
-LIBXT= $(LIBW) LIBXMU -lXt $(LIBXTR6) -lXext
-#endif /* not LIBXT_STATIC */
-
-#else /* not USE_X_TOOLKIT */
-LIBXT=
-#endif /* not USE_X_TOOLKIT */
-
-#if HAVE_XPM
-#ifndef LIBXPM
-#define LIBXPM -lXpm
-#endif /* not defined LIBXPM */
-#else /* not HAVE_XPM */
-#define LIBXPM
-#endif /* not HAVE_XPM */
-
-#if HAVE_JPEG
-#ifndef LIBJPEG
-#define LIBJPEG -ljpeg
-#endif /* not defined LIBJPEG */
-#else /* not HAVE_JPEG */
-#define LIBJPEG
-#endif /* not HAVE_JPEG */
-
-#if HAVE_PNG
-#ifndef LIBPNG
-#define LIBPNG -lpng -lz -lm
-#endif /* not defined LIBPNG */
-#else /* not HAVE_PNG */
-#define LIBPNG
-#endif /* not HAVE_PNG */
-
-#if HAVE_TIFF
-#ifndef LIBTIFF
-#define LIBTIFF -ltiff
-#endif /* not defined LIBTIFF */
-#else /* not HAVE_TIFF */
-#define LIBTIFF
-#endif /* not HAVE_TIFF */
-
-#if HAVE_GIF
-#ifndef LIBGIF
-#define LIBGIF -lungif
-#endif /* not defined LIBGIF */
-#else /* not HAVE_GIF */
-#define LIBGIF
-#endif /* not HAVE_GIF */
-
-#ifdef HAVE_X11
-/* LD_SWITCH_X_DEFAULT comes after everything else that specifies
- options for where to find X libraries, but before those libraries. */
-X11_LDFLAGS = LD_SWITCH_X_SITE LD_SWITCH_X_DEFAULT
-LIBX= $(LIBXMENU) $(X11_LDFLAGS) $(LIBXT) LIBTIFF LIBJPEG LIBPNG LIBGIF LIBXPM LIB_X11_LIB LIBX11_MACHINE LIBX11_SYSTEM
-#else /* not HAVE_X11 */
-LIBX= $(LIBXMENU) LD_SWITCH_X_SITE -lX10 LIBX10_MACHINE LIBX10_SYSTEM
-#endif /* not HAVE_X11 */
-#endif /* not HAVE_X_WINDOWS */
-
-LIBSOUND= @LIBSOUND@
-
-#ifndef ORDINARY_LINK
-/* Fix linking if compiled with GCC. */
-#ifdef __GNUC__
-
-#if __GNUC__ > 1
-
-#ifdef LINKER
-#define LINKER_WAS_SPECIFIED
-#endif
-
-/* Versions of GCC >= 2.0 put their library, libgcc.a, in obscure
- places that are difficult to figure out at make time. Fortunately,
- these same versions allow you to pass arbitrary flags on to the
- linker, so there's no reason not to use it as a linker.
-
- Well, it's not quite perfect. The `-nostdlib' keeps GCC from
- searching for libraries in its internal directories, so we have to
- ask GCC explicitly where to find libgcc.a. */
-
-#ifndef LINKER
-#define LINKER $(CC) -nostdlib
-#endif
-
-#ifndef LIB_GCC
-/* Ask GCC where to find libgcc.a. */
-#define LIB_GCC `$(CC) -print-libgcc-file-name`
-#endif /* not LIB_GCC */
-
-GNULIB_VAR = LIB_GCC
-
-#ifndef LINKER_WAS_SPECIFIED
-/* GCC passes any argument prefixed with -Xlinker directly to the
- linker. See prefix-args.c for an explanation of why we don't do
- this with the shell's `for' construct.
- Note that some people don't have '.' in their paths, so we must
- use ./prefix-args. */
-#define YMF_PASS_LDFLAGS(flags) `./prefix-args -Xlinker flags`
-#else
-#define YMF_PASS_LDFLAGS(flags) flags
-#endif
-
-#else /* __GNUC__ < 2 */
-
-#ifndef LIB_GCC
-#define LIB_GCC /usr/local/lib/gcc-gnulib
-#endif /* not LIB_GCC */
-GNULIB_VAR = `if [ -f LIB_GCC ] ; then echo LIB_GCC; else echo; fi`
-#endif /* __GNUC__ < 2 */
-#else /* not __GNUC__ */
-GNULIB_VAR =
-
-#endif /* not __GNUC__ */
-#endif /* not ORDINARY_LINK */
-
-/* Specify address for ld to start loading at,
- if requested by configuration. */
-#ifdef LD_TEXT_START_ADDR
-STARTFLAGS = -T LD_TEXT_START_ADDR -e __start
-#endif
-
-#ifdef ORDINARY_LINK
-LD = $(CC)
-#else
-#ifdef COFF_ENCAPSULATE
-LD=$(CC) -nostdlib
-#else /* not ORDINARY_LINK */
-#ifdef LINKER
-LD=LINKER
-#else /* not LINKER */
-LD=ld
-#endif /* not LINKER */
-#endif /* not COFF_ENCAPSULATE */
-#endif /* not ORDINARY_LINK */
-
-ALL_LDFLAGS = LD_SWITCH_SYSTEM LD_SWITCH_SYSTEM_TEMACS LD_SWITCH_MACHINE \
- LD_SWITCH_MACHINE_TEMACS LD_SWITCH_SITE $(LDFLAGS)
-
-/* A macro which other sections of Makefile can redefine to munge the
- flags before they're passed to LD. This is helpful if you have
- redefined LD to something odd, like "gcc".
- (The YMF prefix is a holdover from the old name "ymakefile".)
- */
-#ifndef YMF_PASS_LDFLAGS
-#define YMF_PASS_LDFLAGS(flags) flags
-#endif
-
-/* Allow config.h to specify a replacement file for unexec.c. */
-#ifndef UNEXEC
-#define UNEXEC unexec.o
-#endif
-#ifndef UNEXEC_SRC
-#define UNEXEC_SRC unexec.c
-#endif
-
-INTERVAL_SRC = intervals.h composite.h
-
-GETLOADAVG_LIBS = @GETLOADAVG_LIBS@
-
-#ifdef MSDOS
-#ifdef HAVE_X_WINDOWS
-MSDOS_OBJ = dosfns.o msdos.o
-#else
-MSDOS_OBJ = dosfns.o msdos.o w16select.o
-#endif
-#endif
-
-
-/* lastfile must follow all files
- whose initialized data areas should be dumped as pure by dump-emacs. */
-obj= dispnew.o frame.o scroll.o xdisp.o xmenu.o window.o \
- charset.o coding.o category.o ccl.o\
- cm.o term.o xfaces.o $(XOBJ) \
- emacs.o keyboard.o macros.o keymap.o sysdep.o \
- buffer.o filelock.o insdel.o marker.o \
- minibuf.o fileio.o dired.o filemode.o \
- cmds.o casetab.o casefiddle.o indent.o search.o regex.o undo.o \
- alloc.o data.o doc.o editfns.o callint.o \
- eval.o floatfns.o fns.o print.o lread.o \
- abbrev.o syntax.o UNEXEC mocklisp.o bytecode.o \
- process.o callproc.o \
- region-cache.o sound.o atimer.o \
- doprnt.o strftime.o intervals.o textprop.o composite.o md5.o \
- $(MSDOS_OBJ)
-
-/* Object files used on some machine or other.
- These go in the DOC file on all machines
- in case they are needed there. */
-SOME_MACHINE_OBJECTS = sunfns.o dosfns.o msdos.o \
- xterm.o xfns.o xmenu.o xselect.o xrdb.o
-
-
-#ifdef TERMINFO
-/* Used to be -ltermcap here. If your machine needs that,
- define LIBS_TERMCAP in the m/MACHINE.h file. */
-#ifndef LIBS_TERMCAP
-#define LIBS_TERMCAP -lcurses
-#endif /* LIBS_TERMCAP */
-termcapobj = terminfo.o
-#else /* ! defined (TERMINFO) */
-#ifndef LIBS_TERMCAP
-#define LIBS_TERMCAP
-termcapobj = termcap.o tparam.o
-#else /* LIBS_TERMCAP */
-termcapobj = tparam.o
-#endif /* LIBS_TERMCAP */
-#endif /* ! defined (TERMINFO) */
-
-
-#ifndef SYSTEM_MALLOC
-
-#ifdef DOUG_LEA_MALLOC
-#ifdef REL_ALLOC
-mallocobj = ralloc.o vm-limit.o
-#else /* ! defined (REL_ALLOC) */
-mallocobj = vm-limit.o
-#endif /* ! defined (REL_ALLOC) */
-#else /* ! defined (DOUG_LEA_MALLOC) */
-#ifdef REL_ALLOC
-mallocobj = gmalloc.o ralloc.o vm-limit.o
-#else /* ! defined (REL_ALLOC) */
-mallocobj = gmalloc.o vm-limit.o
-#endif /* ! defined (REL_ALLOC) */
-#endif /* ! defined (DOUG_LEA_MALLOC) */
-
-#endif /* SYSTEM_MALLOC */
-
-
-#ifndef HAVE_ALLOCA
-allocaobj = alloca.o
-#else
-allocaobj =
-#endif
-
-#ifdef USE_X_TOOLKIT
-widgetobj= widget.o
-#else /* not USE_X_TOOLKIT */
-widgetobj=
-#endif /* not USE_X_TOOLKIT */
-
-
-/* define otherobj as list of object files that make-docfile
- should not be told about. */
-otherobj= $(termcapobj) lastfile.o $(mallocobj) $(allocaobj) $(widgetobj) $(LIBOBJS)
-
-#ifdef HAVE_MOUSE
-#define MOUSE_SUPPORT ${lispsource}mouse.elc \
- ${lispsource}select.elc ${lispsource}scroll-bar.elc
-#else
-#define MOUSE_SUPPORT
-#endif
-
-#ifdef VMS
-#define VMS_SUPPORT ${lispsource}vmsproc.elc ${lispsource}vms-patch.elc
-#else
-#define VMS_SUPPORT
-#endif
-
-#ifdef MSDOS
-#define MSDOS_SUPPORT ${lispsource}ls-lisp.elc ${lispsource}disp-table.elc \
- ${lispsource}dos-fns.elc ${lispsource}dos-w32.elc ${lispsource}dos-vars.elc \
- ${lispsource}international/ccl.elc ${lispsource}international/codepage.elc
-
-#else
-#define MSDOS_SUPPORT
-#endif
-
-#ifdef WINDOWSNT
-#define WINNT_SUPPORT ${lispsource}ls-lisp.elc ${lispsource}w32-fns.elc \
- ${lispsource}dos-w32.elc
-#else
-#define WINNT_SUPPORT
-#endif
-
-/* List of Lisp files loaded into the dumped Emacs. It's arranged
- like this because it's easier to generate it semi-mechanically from
- loadup.el this way.
-
- Note that this list should not include lisp files which might not
- be present, like site-load.el and site-init.el; this makefile
- expects them all to be either present or buildable.
-
- Files which are loaded unconditionally should be in shortlisp as well.
- Files included conditionally here should be included (unconditionally)
- in SOME_MACHINE_LISP. */
-
-lisp= \
- ${lispsource}abbrev.elc \
- ${lispsource}buff-menu.elc \
- ${lispsource}byte-run.elc \
- ${lispsource}cus-start.el \
- ${lispsource}custom.elc \
- ${lispsource}emacs-lisp/lisp-mode.elc \
- ${lispsource}emacs-lisp/lisp.elc \
- ${lispsource}env.elc \
- ${lispsource}faces.elc \
- ${lispsource}files.elc \
- ${lispsource}format.elc \
- ${lispsource}facemenu.elc \
- MOUSE_SUPPORT \
- ${lispsource}float-sup.elc \
- ${lispsource}frame.elc\
- ${lispsource}help.elc \
- ${lispsource}indent.elc \
- ${lispsource}isearch.elc \
- ${lispsource}loadup.el \
- ${lispsource}loaddefs.el \
- ${lispsource}bindings.el \
- ${lispsource}map-ynp.elc \
- ${lispsource}menu-bar.elc \
- ${lispsource}international/mule.elc \
- ${lispsource}international/mule-conf.el \
- ${lispsource}international/mule-cmds.elc \
- ${lispsource}international/characters.elc \
- ${lispsource}international/utf-8.elc \
- ${lispsource}case-table.elc \
- ${lispsource}language/chinese.elc \
- ${lispsource}language/cyrillic.elc \
- ${lispsource}language/indian.elc \
- ${lispsource}language/devanagari.elc \
- ${lispsource}language/english.elc \
- ${lispsource}language/ethiopic.elc \
- ${lispsource}language/european.elc \
- ${lispsource}language/czech.elc \
- ${lispsource}language/slovak.elc \
- ${lispsource}language/romanian.elc \
- ${lispsource}language/greek.elc \
- ${lispsource}language/hebrew.elc \
- ${lispsource}language/japanese.elc \
- ${lispsource}language/korean.elc \
- ${lispsource}language/lao.elc \
- ${lispsource}language/thai.elc \
- ${lispsource}language/tibetan.elc \
- ${lispsource}language/vietnamese.elc \
- ${lispsource}language/misc-lang.elc \
- ${lispsource}paths.el \
- ${lispsource}register.elc \
- ${lispsource}replace.elc \
- ${lispsource}simple.elc \
- ${lispsource}startup.elc \
- ${lispsource}subr.elc \
- ${lispsource}term/tty-colors.elc \
- ${lispsource}textmodes/fill.elc \
- ${lispsource}textmodes/page.elc \
- ${lispsource}textmodes/paragraphs.elc \
- ${lispsource}textmodes/text-mode.elc \
- ${lispsource}vc-hooks.elc \
- ${lispsource}ediff-hook.elc \
- VMS_SUPPORT \
- MSDOS_SUPPORT \
- WINNT_SUPPORT \
- ${lispsource}widget.elc \
- ${lispsource}window.elc \
- ${lispsource}version.el
-
-/* These are relative file names for the Lisp files
- that are loaded unconditionally. This is used in make-docfile.
- It need not contain the files that are loaded conditionally
- because SOME_MACHINE_LISP has those. */
-shortlisp= \
- ../lisp/abbrev.elc \
- ../lisp/buff-menu.elc \
- ../lisp/byte-run.elc \
- ../lisp/cus-start.el \
- ../lisp/custom.elc \
- ../lisp/emacs-lisp/lisp-mode.elc \
- ../lisp/emacs-lisp/lisp.elc \
- ../lisp/facemenu.elc \
- ../lisp/faces.elc \
- ../lisp/files.elc \
- ../lisp/float-sup.elc \
- ../lisp/format.elc \
- ../lisp/frame.elc \
- ../lisp/help.elc \
- ../lisp/indent.elc \
- ../lisp/isearch.elc \
- ../lisp/loadup.el \
- ../lisp/loaddefs.el \
- ../lisp/bindings.el \
- ../lisp/map-ynp.elc \
- ../lisp/international/mule.elc \
- ../lisp/international/mule-conf.el \
- ../lisp/international/mule-cmds.elc \
- ../lisp/international/characters.elc \
- ../lisp/case-table.elc \
- ../lisp/language/chinese.elc \
- ../lisp/language/cyrillic.elc \
- ../lisp/language/indian.elc \
- ../lisp/language/devanagari.elc \
- ../lisp/language/english.elc \
- ../lisp/language/ethiopic.elc \
- ../lisp/language/european.elc \
- ../lisp/language/czech.elc \
- ../lisp/language/slovak.elc \
- ../lisp/language/romanian.elc \
- ../lisp/language/greek.elc \
- ../lisp/language/hebrew.elc \
- ../lisp/language/japanese.elc \
- ../lisp/language/korean.elc \
- ../lisp/language/lao.elc \
- ../lisp/language/thai.elc \
- ../lisp/language/tibetan.elc \
- ../lisp/language/vietnamese.elc \
- ../lisp/language/misc-lang.elc \
- ../lisp/paths.el \
- ../lisp/register.elc \
- ../lisp/replace.elc \
- ../lisp/simple.elc \
- ../lisp/startup.elc \
- ../lisp/subr.elc \
- ../lisp/term/tty-colors.elc \
- ../lisp/textmodes/fill.elc \
- ../lisp/textmodes/page.elc \
- ../lisp/textmodes/paragraphs.elc \
- ../lisp/textmodes/text-mode.elc \
- ../lisp/vc-hooks.elc \
- ../lisp/ediff-hook.elc \
- ../lisp/widget.elc \
- ../lisp/window.elc \
- ../lisp/version.el
-
-/* Lisp files that may or may not be used.
- We must unconditionally put them in the DOC file.
- We use ../lisp/ to start the file names
- to reduce the size of the argument list for make-docfile
- for the sake of systems which can't handle large ones. */
-SOME_MACHINE_LISP = ${dotdot}/lisp/menu-bar.elc ${dotdot}/lisp/mouse.elc \
- ${dotdot}/lisp/select.elc ${dotdot}/lisp/scroll-bar.elc \
- ${dotdot}/lisp/vmsproc.elc ${dotdot}/lisp/vms-patch.elc \
- ${dotdot}/lisp/ls-lisp.elc ${dotdot}/lisp/dos-fns.elc \
- ${dotdot}/lisp/w32-fns.elc ${dotdot}/lisp/dos-w32.elc \
- ${dotdot}/lisp/disp-table.elc ${dotdot}/lisp/dos-vars.elc \
- ${dotdot}/lisp/international/ccl.elc \
- ${dotdot}/lisp/international/codepage.elc
-
-/* Construct full set of libraries to be linked.
- Note that SunOS needs -lm to come before -lc; otherwise, you get
- duplicated symbols. If the standard libraries were compiled
- with GCC, we might need gnulib again after them. */
-LIBES = $(LOADLIBES) $(LIBS) $(LIBX) $(LIBSOUND) \
- LIBS_SYSTEM LIBS_MACHINE LIBS_TERMCAP \
- LIBS_DEBUG $(GETLOADAVG_LIBS) $(GNULIB_VAR) LIB_MATH LIB_STANDARD \
- $(GNULIB_VAR)
-
-/* Enable recompilation of certain other files depending on system type. */
-
-#ifndef OTHER_FILES
-#define OTHER_FILES
-#endif
-
-#ifndef OBJECTS_MACHINE
-#define OBJECTS_MACHINE
-#endif
-
-all: emacs OTHER_FILES
-
-emacs: temacs ${etc}DOC ${lisp}
-#ifdef CANNOT_DUMP
- rm -f emacs
- ln temacs emacs
-#else
-#ifdef HAVE_SHM
- LC_ALL=C ./temacs -nl -batch -l loadup dump
-#else /* ! defined (HAVE_SHM) */
- LC_ALL=C ./temacs -batch -l loadup dump
-#endif /* ! defined (HAVE_SHM) */
-#endif /* ! defined (CANNOT_DUMP) */
- -./emacs -q -batch -f list-load-path-shadows
-
-/* We run make-docfile twice because the command line may get too long
- on some systems. */
-/* ${SOME_MACHINE_OBJECTS} comes before ${obj} because some files may
- or may not be included in ${obj}, but they are always included in
- ${SOME_MACHINE_OBJECTS}. Since a file is processed when it is mentioned
- for the first time, this prevents any variation between configurations
- in the contents of the DOC file.
- Likewise for ${SOME_MACHINE_LISP}. */
-${etc}DOC: ${libsrc}make-docfile ${obj} ${shortlisp} ${SOME_MACHINE_LISP}
- -rm -f ${etc}DOC
- ${libsrc}make-docfile -d ${srcdir} ${SOME_MACHINE_OBJECTS} ${obj} > ${etc}DOC
- ${libsrc}make-docfile -a ${etc}DOC -d ${srcdir} ${SOME_MACHINE_LISP} ${shortlisp}
-
-${libsrc}make-docfile:
- cd ${libsrc}; ${MAKE} ${MFLAGS} make-docfile
-
-/* Some systems define this to cause parallel Make-ing. */
-#ifndef MAKE_PARALLEL
-#define MAKE_PARALLEL
-#endif
-
-temacs: MAKE_PARALLEL $(LOCALCPP) $(STARTFILES) stamp-oldxmenu ${obj} ${otherobj} OBJECTS_MACHINE prefix-args
- $(LD) YMF_PASS_LDFLAGS (${STARTFLAGS} ${ALL_LDFLAGS}) \
- -o temacs ${STARTFILES} ${obj} ${otherobj} \
- OBJECTS_MACHINE ${LIBES}
-
-/* We don't use ALL_LDFLAGS because LD_SWITCH_SYSTEM and LD_SWITCH_MACHINE
- often contain options that have to do with using Emacs's crt0,
- which are only good with temacs. */
-prefix-args: prefix-args.c $(config_h)
- $(CC) $(ALL_CFLAGS) $(LDFLAGS) ${srcdir}/prefix-args.c -o prefix-args
-
-/* Don't lose if this was not defined. */
-#ifndef OLDXMENU_OPTIONS
-#define OLDXMENU_OPTIONS
-#endif
-
-/* Don't lose if this was not defined. */
-#ifndef LWLIB_OPTIONS
-#define LWLIB_OPTIONS
-#endif
-
-#if defined (HAVE_X_WINDOWS) && defined (HAVE_X11) && defined (HAVE_MENUS)
-
-/* We use stamp-xmenu with these two deps
- to both ensure that lwlib gets remade based on its dependencies
- in its own makefile,
- and remake temacs if lwlib gets changed by this. */
-stamp-oldxmenu: ${OLDXMENU} ../src/$(OLDXMENU)
- touch stamp-oldxmenu
-/* Supply an ordering for parallel make. */
-../src/$(OLDXMENU): ${OLDXMENU}
-
-#ifdef USE_X_TOOLKIT
-$(OLDXMENU): really-lwlib
-
-/* Encode the values of these two macros in Make variables,
- so we can use $(...) to substitute their values within "...". */
-C_SWITCH_MACHINE_1 = C_SWITCH_MACHINE
-C_SWITCH_SYSTEM_1 = C_SWITCH_SYSTEM
-C_SWITCH_SITE_1 = C_SWITCH_SITE
-C_SWITCH_X_SITE_1 = C_SWITCH_X_SITE
-C_SWITCH_X_MACHINE_1 = C_SWITCH_X_MACHINE
-C_SWITCH_X_SYSTEM_1 = C_SWITCH_X_SYSTEM
-really-lwlib:
- cd ${lwlibdir}; ${MAKE} ${MFLAGS} LWLIB_OPTIONS \
- CC='${CC}' CFLAGS='${CFLAGS}' MAKE='${MAKE}' \
- "C_SWITCH_X_SITE=$(C_SWITCH_X_SITE_1)" \
- "C_SWITCH_X_MACHINE=$(C_SWITCH_X_MACHINE_1)" \
- "C_SWITCH_X_SYSTEM=$(C_SWITCH_X_SYSTEM_1)" \
- "C_SWITCH_SITE=$(C_SWITCH_SITE_1)" \
- "C_SWITCH_MACHINE=$(C_SWITCH_MACHINE_1)" \
- "C_SWITCH_SYSTEM=$(C_SWITCH_SYSTEM_1)"
- @true /* make -t should not create really-lwlib. */
-.PHONY: really-lwlib
-#else /* not USE_X_TOOLKIT */
-$(OLDXMENU): really-oldXMenu
-
-/* Encode the values of these two macros in Make variables,
- so we can use $(...) to substitute their values within "...". */
-C_SWITCH_MACHINE_1 = C_SWITCH_MACHINE
-C_SWITCH_SYSTEM_1 = C_SWITCH_SYSTEM
-C_SWITCH_SITE_1 = C_SWITCH_SITE
-C_SWITCH_X_SITE_1 = C_SWITCH_X_SITE
-C_SWITCH_X_MACHINE_1 = C_SWITCH_X_MACHINE
-C_SWITCH_X_SYSTEM_1 = C_SWITCH_X_SYSTEM
-really-oldXMenu:
- cd ${oldXMenudir}; ${MAKE} ${MFLAGS} OLDXMENU_OPTIONS \
- CC='${CC}' CFLAGS='${CFLAGS}' MAKE='${MAKE}' \
- "C_SWITCH_X_SITE=$(C_SWITCH_X_SITE_1)" \
- "C_SWITCH_X_MACHINE=$(C_SWITCH_X_MACHINE_1)" \
- "C_SWITCH_X_SYSTEM=$(C_SWITCH_X_SYSTEM_1)" \
- "C_SWITCH_SITE=$(C_SWITCH_SITE_1)" \
- "C_SWITCH_MACHINE=$(C_SWITCH_MACHINE_1)" \
- "C_SWITCH_SYSTEM=$(C_SWITCH_SYSTEM_1)"
- @true /* make -t should not create really-oldXMenu. */
-.PHONY: really-oldXMenu
-#endif /* not USE_X_TOOLKIT */
-#else /* not (HAVE_X_WINDOWS && HAVE_X11 && HAVE_MENUS) */
-
-/* We don't really need this, but satisfy the dependency. */
-stamp-oldxmenu:
- touch stamp-oldxmenu
-#endif /* not (HAVE_X_WINDOWS && HAVE_X11 && HAVE_MENUS) */
-
-../config.status:: epaths.in
- @echo "The file epaths.h needs to be set up from epaths.in."
- @echo "Please run the `configure' script again."
- exit 1
-
-../config.status:: config.in
- @echo "The file config.h needs to be set up from config.in."
- @echo "Please run the `configure' script again."
- exit 1
-
-/* Some machines have alloca built-in.
- They should define HAVE_ALLOCA, or may just let alloca.s
- be used but generate no code.
- Some have it written in assembler in alloca.s.
- Some use the C version in alloca.c (these define C_ALLOCA in config.h).
- */
-
-#ifdef C_ALLOCA
-/* We could put something in alloca.c to #define free and malloc
- whenever emacs was #defined, but that's not appropriate for all
- users of alloca in Emacs. Check out ../lib-src/getopt.c. */
-alloca.o : alloca.c
- $(CC) -c $(CPPFLAGS) -DEMACS_FREE=xfree \
- $(ALL_CFLAGS) ${srcdir}/alloca.c
-#else
-#ifndef HAVE_ALLOCA
-alloca.o : alloca.s $(config_h)
-/* $(CPP) is cc -E, which may get confused by filenames
- that do not end in .c. So copy file to a safe name. */
- -rm -f allocatem.c
- cp ${srcdir}/alloca.s allocatem.c
-/* Remove any ^L, blank lines, and preprocessor comments,
- since some assemblers barf on them. Use a different basename for the
- output file, since some stupid compilers (Green Hill's) use that
- name for the intermediate assembler file. */
- $(CPP) $(CPPFLAGS) $(ALL_CFLAGS) allocatem.c | \
- sed -e 's/\f//' -e 's/^#.*//' | \
- sed -n -e '/^..*$$/p' > allocax.s
- -rm -f alloca.o
-/* Xenix, in particular, needs to run assembler via cc. */
- $(CC) -c allocax.s
- mv allocax.o alloca.o
- -rm -f allocax.s allocatem.c
-#endif /* HAVE_ALLOCA */
-#endif /* ! defined (C_ALLOCA) */
-
-/* Nearly all the following files depend on lisp.h,
- but it is not included as a dependency because
- it is so often changed in ways that do not require any recompilation
- and so rarely changed in ways that do require any. */
-
-abbrev.o: abbrev.c buffer.h window.h dispextern.h commands.h charset.h \
- $(config_h)
-buffer.o: buffer.c buffer.h region-cache.h commands.h window.h \
- dispextern.h $(INTERVAL_SRC) blockinput.h atimer.h systime.h charset.h \
- $(config_h)
-callint.o: callint.c window.h commands.h buffer.h mocklisp.h \
- keyboard.h dispextern.h $(config_h)
-callproc.o: callproc.c epaths.h buffer.h commands.h $(config_h) \
- process.h systty.h syssignal.h charset.h coding.h ccl.h msdos.h \
- composite.h
-casefiddle.o: casefiddle.c syntax.h commands.h buffer.h composite.h $(config_h)
-casetab.o: casetab.c buffer.h $(config_h)
-category.o: category.c category.h buffer.h charset.h $(config_h)
-ccl.o: ccl.c ccl.h charset.h coding.h $(config_h)
-charset.o: charset.c charset.h buffer.h coding.h composite.h disptab.h \
- $(config_h)
-coding.o: coding.c coding.h ccl.h buffer.h charset.h $(config_h)
-cm.o: cm.c cm.h termhooks.h $(config_h)
-cmds.o: cmds.c syntax.h buffer.h charset.h commands.h window.h $(config_h) \
- msdos.h dispextern.h
-pre-crt0.o: pre-crt0.c
-ecrt0.o: ecrt0.c $(config_h)
- CRT0_COMPILE ${srcdir}/ecrt0.c
-dired.o: dired.c commands.h buffer.h $(config_h) charset.h coding.h regex.h \
- systime.h
-dispnew.o: dispnew.c commands.h frame.h window.h buffer.h dispextern.h \
- termchar.h termopts.h termhooks.h cm.h disptab.h systty.h systime.h \
- xterm.h blockinput.h atimer.h charset.h msdos.h composite.h keyboard.h \
- $(config_h)
-doc.o: doc.c $(config_h) epaths.h buffer.h keyboard.h charset.h
-doprnt.o: doprnt.c charset.h $(config_h)
-dosfns.o: buffer.h termchar.h termhooks.h frame.h msdos.h dosfns.h $(config_h)
-editfns.o: editfns.c window.h buffer.h systime.h $(INTERVAL_SRC) charset.h \
- coding.h dispextern.h $(config_h)
-emacs.o: emacs.c commands.h systty.h syssignal.h blockinput.h process.h \
- termhooks.h buffer.h atimer.h systime.h $(INTERVAL_SRC) $(config_h)
-fileio.o: fileio.c window.h buffer.h systime.h $(INTERVAL_SRC) charset.h \
- coding.h ccl.h msdos.h dispextern.h $(config_h)
-filelock.o: filelock.c buffer.h systime.h epaths.h $(config_h)
-filemode.o: filemode.c $(config_h)
-frame.o: frame.c xterm.h window.h frame.h termhooks.h commands.h keyboard.h \
- buffer.h charset.h fontset.h msdos.h dosfns.h dispextern.h $(config_h)
-fontset.o: dispextern.h fontset.h fontset.c ccl.h charset.h frame.h \
- keyboard.h $(config_h)
-getloadavg.o: getloadavg.c $(config_h)
-indent.o: indent.c frame.h window.h indent.h buffer.h $(config_h) termchar.h \
- termopts.h disptab.h region-cache.h charset.h composite.h dispextern.h \
- keyboard.h
-insdel.o: insdel.c window.h buffer.h $(INTERVAL_SRC) blockinput.h charset.h\
- dispextern.h atimer.h systime.h $(config_h)
-keyboard.o: keyboard.c termchar.h termhooks.h termopts.h buffer.h charset.h \
- commands.h frame.h window.h macros.h disptab.h keyboard.h syssignal.h \
- systty.h systime.h dispextern.h syntax.h $(INTERVAL_SRC) blockinput.h \
- atimer.h xterm.h puresize.h msdos.h $(config_h)
-keymap.o: keymap.c buffer.h commands.h keyboard.h termhooks.h blockinput.h \
- atimer.h systime.h puresize.h charset.h intervals.h $(config_h)
-lastfile.o: lastfile.c $(config_h)
-macros.o: macros.c window.h buffer.h commands.h macros.h keyboard.h \
- dispextern.h $(config_h)
-malloc.o: malloc.c $(config_h)
-gmalloc.o: gmalloc.c $(config_h)
-ralloc.o: ralloc.c $(config_h)
-vm-limit.o: vm-limit.c mem-limits.h $(config_h)
-marker.o: marker.c buffer.h charset.h $(config_h)
-minibuf.o: minibuf.c syntax.h dispextern.h frame.h window.h keyboard.h \
- buffer.h commands.h charset.h msdos.h $(config_h)
-mktime.o: mktime.c $(config_h)
-mocklisp.o: mocklisp.c buffer.h $(config_h)
-msdos.o: msdos.c msdos.h dosfns.h systime.h termhooks.h dispextern.h frame.h \
- termopts.h termchar.h charset.h coding.h ccl.h disptab.h window.h \
- keyboard.h $(config_h)
-process.o: process.c process.h buffer.h window.h termhooks.h termopts.h \
- commands.h syssignal.h systime.h systty.h syswait.h frame.h dispextern.h \
- blockinput.h atimer.h charset.h coding.h ccl.h msdos.h composite.h \
- keyboard.h $(config_h)
-regex.o: regex.c syntax.h buffer.h $(config_h) regex.h category.h charset.h
-region-cache.o: region-cache.c buffer.h region-cache.h
-scroll.o: scroll.c termchar.h dispextern.h frame.h msdos.h keyboard.h \
- $(config_h)
-search.o: search.c regex.h commands.h buffer.h region-cache.h syntax.h \
- blockinput.h atimer.h systime.h category.h charset.h composite.h $(config_h)
-strftime.o: strftime.c $(config_h)
-syntax.o: syntax.c syntax.h buffer.h commands.h category.h charset.h \
- composite.h $(config_h)
-sysdep.o: sysdep.c $(config_h) dispextern.h termhooks.h termchar.h termopts.h \
- frame.h syssignal.h systty.h systime.h syswait.h blockinput.h atimer.h \
- window.h msdos.h dosfns.h keyboard.h
-term.o: term.c termchar.h termhooks.h termopts.h $(config_h) cm.h frame.h \
- disptab.h dispextern.h keyboard.h charset.h coding.h ccl.h msdos.h
-termcap.o: termcap.c $(config_h)
-terminfo.o: terminfo.c $(config_h)
-tparam.o: tparam.c $(config_h)
-undo.o: undo.c buffer.h commands.h $(config_h)
-/* This hack is to discard any space that cpp might put at the beginning
- of UNEXEC when substituting it in. */
-UNEXEC_ALIAS=UNEXEC
-$(UNEXEC_ALIAS): UNEXEC_SRC $(config_h)
-w16select.o: w16select.c dispextern.h frame.h blockinput.h atimer.h systime.h \
- msdos.h $(config_h)
-widget.o: widget.c xterm.h frame.h dispextern.h widgetprv.h \
- $(srcdir)/../lwlib/lwlib.h $(config_h)
-window.o: window.c indent.h commands.h frame.h window.h buffer.h termchar.h \
- termhooks.h disptab.h keyboard.h dispextern.h msdos.h composite.h \
- $(config_h)
-xdisp.o: xdisp.c macros.h commands.h indent.h buffer.h dispextern.h coding.h \
- termchar.h frame.h window.h disptab.h termhooks.h charset.h $(config_h) \
- msdos.h composite.h fontset.h
-xfaces.o: xfaces.c dispextern.h frame.h xterm.h buffer.h blockinput.h \
- window.h charset.h msdos.h dosfns.h composite.h atimer.h systime.h $(config_h)
-xfns.o: xfns.c buffer.h frame.h window.h keyboard.h xterm.h dispextern.h \
- $(srcdir)/../lwlib/lwlib.h blockinput.h atimer.h systime.h epaths.h \
- charset.h $(config_h)
-xmenu.o: xmenu.c xterm.h termhooks.h window.h dispextern.h frame.h keyboard.h \
- $(srcdir)/../lwlib/lwlib.h blockinput.h atimer.h systime.h msdos.h \
- $(config_h)
-xterm.o: xterm.c xterm.h termhooks.h termopts.h termchar.h window.h \
- dispextern.h frame.h disptab.h blockinput.h atimer.h systime.h syssignal.h \
- keyboard.h gnu.h sink.h sinkmask.h charset.h ccl.h fontset.h composite.h \
- coding.h $(config_h)
-xselect.o: xselect.c dispextern.h frame.h xterm.h blockinput.h charset.h \
- coding.h ccl.h buffer.h atimer.h systime.h $(config_h)
-xrdb.o: xrdb.c $(config_h) epaths.h
-hftctl.o: hftctl.c $(config_h)
-sound.o: sound.c dispextern.h $(config_h)
-atimer.o: atimer.c atimer.h systime.h $(config_h)
-
-/* The files of Lisp proper */
-
-alloc.o: alloc.c frame.h window.h buffer.h puresize.h syssignal.h keyboard.h \
- blockinput.h atimer.h systime.h charset.h dispextern.h $(config_h) $(INTERVAL_SRC)
-bytecode.o: bytecode.c buffer.h syntax.h charset.h $(config_h)
-data.o: data.c buffer.h puresize.h charset.h syssignal.h keyboard.h $(config_h)
-eval.o: eval.c commands.h keyboard.h blockinput.h atimer.h systime.h \
- $(config_h)
-floatfns.o: floatfns.c $(config_h)
-fns.o: fns.c commands.h $(config_h) frame.h buffer.h charset.h keyboard.h \
- frame.h window.h dispextern.h $(INTERVAL_SRC)
-print.o: print.c process.h frame.h window.h buffer.h keyboard.h charset.h\
- $(config_h) dispextern.h msdos.h composite.h
-lread.o: lread.c commands.h keyboard.h buffer.h epaths.h charset.h $(config_h) \
- termhooks.h msdos.h
-
-/* Text properties support */
-textprop.o: textprop.c buffer.h window.h dispextern.h $(INTERVAL_SRC) \
- $(config_h)
-intervals.o: intervals.c buffer.h $(INTERVAL_SRC) keyboard.h puresize.h $(config_h)
-composite.o: composite.c buffer.h charset.h $(INTERVAL_SRC) $(config_h)
-
-/* System-specific programs to be made.
- OTHER_FILES and OBJECTS_MACHINE
- select which of these should be compiled. */
-
-sunfns.o: sunfns.c buffer.h window.h dispextern.h $(config_h)
-
-${libsrc}emacstool: ${libsrc}emacstool.c
- cd ${libsrc}; ${MAKE} ${MFLAGS} emacstool
-mostlyclean:
- rm -f temacs prefix-args core *.core \#* *.o libXMenu11.a liblw.a
- rm -f ../etc/DOC
-clean: mostlyclean
- rm -f emacs-* emacs bootstrap-emacs
-/**/# This is used in making a distribution.
-/**/# Do not use it on development directories!
-distclean: clean
- rm -f epaths.h config.h Makefile Makefile.c config.stamp stamp-oldxmenu ../etc/DOC-*
-maintainer-clean: distclean
- @echo "This command is intended for maintainers to use;"
- @echo "it deletes files that may require special tools to rebuild."
- rm -f TAGS
-versionclean:
- -rm -f emacs emacs-* ../etc/DOC*
-extraclean: distclean
- -rm -f *~ \#* m/?*~ s/?*~
-
-/* The rule for the [sm] files has to be written a little funny to
- avoid looking like a C comment to CPP. */
-SOURCES = *.[ch] [sm]/?* COPYING Makefile.in \
- config.in epaths.in README COPYING ChangeLog vms.pp-trans
-unlock:
- chmod u+w $(SOURCES)
-
-relock:
- chmod -w $(SOURCES)
- chmod +w epaths.h
-
-/* Arrange to make a tags table TAGS-LISP for ../lisp,
- plus TAGS for the C files, which includes ../lisp/TAGS by reference. */
-
-ctagsfiles1 = [xyzXYZ]*.[hc]
-ctagsfiles2 = [a-wA-W]*.[hc]
-
-TAGS: $(srcdir)/$(ctagsfiles1) $(srcdir)/$(ctagsfiles2)
- ../lib-src/etags --include=TAGS-LISP --include=${lwlibdir}/TAGS \
- --regex='/[ ]*DEFVAR_[A-Z_ (]+"\([^"]+\)"/' \
- $(srcdir)/$(ctagsfiles1) $(srcdir)/$(ctagsfiles2)
-frc:
-TAGS-LISP: frc
- $(MAKE) -f ${lispsource}Makefile TAGS-LISP ETAGS=../lib-src/etags
-
-$(lwlibdir)TAGS:
- (cd $(lwlibdir); $(MAKE) -f $(lwlibdir)Makefile tags ETAGS=../lib-src/etags)
-
-tags: TAGS TAGS-LISP $(lwlibdir)TAGS
-.PHONY: tags
-
-
-/* Bootstrapping. */
-
-bootstrap: bootstrap-emacs
-
-/* Build a temacs with a sufficiently large PURESIZE to load the
- Lisp files from loadup.el in source form. */
-
-bootstrap-temacs:
- LC_ALL=C $(MAKE) $(MFLAGS) temacs ALL_CFLAGS="$(ALL_CFLAGS) -DPURESIZE=5000000 -I../src"
-
-/* Build a DOC file. */
-
-bootstrap-doc: ${libsrc}make-docfile
- -rm -f ${etc}DOC
- els=`echo ${shortlisp} ${SOME_MACHINE_LISP} \
- | sed -e "s/\\.elc/.el/g"`; \
- ${libsrc}make-docfile -d ${srcdir} $$els ${obj} > ${etc}DOC
-
-/* Dump an Emacs executable named bootstrap-emacs containing the
- files from loadup.el in source form. */
-
-bootstrap-emacs: bootstrap-temacs bootstrap-doc
-#ifdef CANNOT_DUMP
- ln temacs bootstrap-emacs
-#else
-#ifdef HAVE_SHM
- ./temacs -nl -batch -l loadup bootstrap
-#else /* ! defined (HAVE_SHM) */
- ./temacs --batch --load loadup bootstrap
-#endif /* ! defined (HAVE_SHM) */
-#endif /* ! defined (CANNOT_DUMP) */
- mv -f emacs bootstrap-emacs
- rm -f temacs
-
+++ /dev/null
-#include <X11/Xlib.h>
-#include <X11/X.h>
-#include <X11/Xutil.h>
-#include <X11/Xresource.h>
-#include "XTests.h"
-#include <stdio.h>
-
-static Display *dpy;
-
-static void
-quit (dpy)
- Display *dpy;
-{
- XCloseDisplay (dpy);
- exit (0);
-}
-
-static Colormap screen_colormap;
-
-static unsigned long
-obtain_color (color)
- char *color;
-{
- int exists;
- XColor color_def;
-
- if (!screen_colormap)
- screen_colormap = DefaultColormap (dpy, DefaultScreen (dpy));
-
- exists = XParseColor (dpy, screen_colormap, color, &color_def)
- && XAllocColor (dpy, screen_colormap, &color_def);
- if (exists)
- return color_def.pixel;
-
- fprintf (stderr, "Can't get color; using black.");
- return BlackPixel (dpy, DefaultScreen (dpy));
-}
-
-static char *visual_strings[] =
-{
- "StaticGray ",
- "GrayScale ",
- "StaticColor",
- "PseudoColor",
- "TrueColor ",
- "DirectColor"
-};
-
-main (argc,argv)
- int argc;
- char *argv[];
-{
- char *dpy_string;
- int n;
- long mask;
- Visual *my_visual;
- XVisualInfo *vinfo, visual_template;
- XEvent event;
- Window window;
- Screen *scr;
- XGCValues gc_values;
- GC fill_gc, pix_gc, line_xor_gc, line_xor_inv_gc;
- int i;
- int x, y, width, height, geometry, gravity;
- char *geo;
- char default_geo[] = "80x40+0+0";
- int depth;
- Pixmap pix;
- char *string = "Kill the head and the body will die.";
- char dash_list[] = {4, 4};
- int dashes = 2;
-
- if (argc < 2)
- dpy_string = "localhost:0.0";
- else
- dpy_string = argv[1];
-
- if (argc >= 3)
- {
- XSizeHints hints;
-
- printf ("Geometry: %s\t(default: %s)\n", argv[2], default_geo);
- geo = argv[2];
- XWMGeometry (dpy, DefaultScreen (dpy), geo, default_geo,
- 3, &hints, &x, &y, &width, &height, &gravity);
- }
-
- dpy = XOpenDisplay (dpy_string);
- if (!dpy)
- {
- printf ("Can' open display %s\n", dpy_string);
- exit (1);
- }
-
- window = XCreateSimpleWindow (dpy, DefaultRootWindow (dpy),
- 300, 300, 300, 300, 1,
- BlackPixel (dpy, DefaultScreen (dpy)),
- WhitePixel (dpy, DefaultScreen (dpy)));
- XSelectInput (dpy, window, ButtonPressMask | KeyPressMask
- | EnterWindowMask | LeaveWindowMask);
-
- gc_values.foreground = obtain_color ("blue");
- gc_values.background = WhitePixel (dpy, DefaultScreen (dpy));
- fill_gc = XCreateGC (dpy, window, GCForeground | GCBackground,
- &gc_values);
-
- gc_values.foreground = obtain_color ("red");
- gc_values.line_width = 3;
- gc_values.line_style = LineOnOffDash;
- gc_values.cap_style = CapRound;
- gc_values.join_style = JoinRound;
- line_xor_gc = XCreateGC (dpy, window,
- GCForeground | GCBackground | GCLineStyle
- | GCJoinStyle | GCCapStyle | GCLineWidth,
- &gc_values);
- XSetDashes (dpy, line_xor_gc, 0, dash_list, dashes);
-
- line_xor_inv_gc = XCreateGC (dpy, window,
- GCForeground | GCBackground | GCLineWidth,
- &gc_values);
-
- depth = DefaultDepthOfScreen (ScreenOfDisplay (dpy, DefaultScreen (dpy)));
- pix = XCreateBitmapFromData (dpy, window, page_glyf_bits,
- page_glyf_width, page_glyf_height);
-
- XMapWindow (dpy, window);
- XFlush (dpy);
-
- while (1)
- {
- XNextEvent (dpy, &event);
- switch (event.type)
- {
- case ButtonPress:
- switch (event.xbutton.button)
- {
- case Button1:
- XDrawLine (dpy, window, line_xor_gc, 25, 75, 300, 75);
- break;
-
- case Button2:
- XDrawLine (dpy, window, line_xor_inv_gc, 25, 25, 300, 25);
- break;
-
- case Button3:
- XDrawLine (dpy, window, line_xor_gc, 25, 25, 25, 125);
- break;
- }
- break;
-
- case KeyPress:
- {
- char buf[20];
- int n;
- XComposeStatus status;
- KeySym keysym;
-
- n = XLookupString (&event, buf, 20, &keysym,
- (XComposeStatus *) &status);
-
- if (n == 1 && buf[0] == 'q')
- quit (dpy);
- }
- break;
-
- case EnterNotify:
- XCopyPlane (dpy, pix, window, fill_gc, 0, 0,
- page_glyf_width, page_glyf_height, 100, 100, 1L);
- XFillRectangle (dpy, window, fill_gc, 50, 50, 50, 50);
- break;
-
- case LeaveNotify:
- XClearWindow (dpy, window);
- break;
- }
-
- XFlush (dpy);
- }
-}
+++ /dev/null
-#define page_glyf_width 30
-#define page_glyf_height 10
-static char page_glyf_bits[] = {
- 0xf0, 0xff, 0xff, 0x03, 0x08, 0x00, 0x00, 0x04, 0xc4, 0x19, 0xf3, 0x08,
- 0x42, 0xa5, 0x14, 0x10, 0xc1, 0xa5, 0x70, 0x20, 0x41, 0xbc, 0x16, 0x20,
- 0x42, 0xa4, 0x14, 0x10, 0x44, 0x24, 0xf3, 0x08, 0x08, 0x00, 0x00, 0x04,
- 0xf0, 0xff, 0xff, 0x03};
+++ /dev/null
-/* Definitions file for GNU Emacs running on ConvexOS. */
-
-#include "bsd4-3.h"
-
-/* First pty name is /dev/pty?0. We have to search for it. */
-#undef FIRST_PTY_LETTER
-#define FIRST_PTY_LETTER first_pty_letter
-
-/* getpgrp requires no arguments. */
-#define GETPGRP_NO_ARG
+++ /dev/null
-/* Environment-hacking for GNU Emacs subprocess
- 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. */
-
-
-#include "config.h"
-#include "lisp.h"
-
-#ifdef MAINTAIN_ENVIRONMENT
-
-#ifdef VMS
-you lose -- this is un*x-only
-#endif
-
-/* alist of (name-string . value-string) */
-Lisp_Object Venvironment_alist;
-extern char **environ;
-
-void
-set_environment_alist (str, val)
- register Lisp_Object str, val;
-{
- register Lisp_Object tem;
-
- tem = Fassoc (str, Venvironment_alist);
- if (NULL (tem))
- if (NULL (val))
- ;
- else
- Venvironment_alist = Fcons (Fcons (str, val), Venvironment_alist);
- else
- if (NULL (val))
- Venvironment_alist = Fdelq (tem, Venvironment_alist);
- else
- XCONS (tem)->cdr = val;
-}
-
-
-
-static void
-initialize_environment_alist ()
-{
- register unsigned char **e, *s;
- extern char *index ();
-
- for (e = (unsigned char **) environ; *e; e++)
- {
- s = (unsigned char *) index (*e, '=');
- if (s)
- set_environment_alist (make_string (*e, s - *e),
- build_string (s + 1));
- }
-}
-
-\f
-unsigned char *
-getenv_1 (str, ephemeral)
- register unsigned char *str;
- int ephemeral; /* if ephmeral, don't need to gc-proof */
-{
- register Lisp_Object env;
- int len = strlen (str);
-
- for (env = Venvironment_alist; CONSP (env); env = XCONS (env)->cdr)
- {
- register Lisp_Object car = XCONS (env)->car;
- register Lisp_Object tem = XCONS (car)->car;
-
- if ((len == XSTRING (tem)->size) &&
- (!bcmp (str, XSTRING (tem)->data, len)))
- {
- /* Found it in the lisp environment */
- tem = XCONS (car)->cdr;
- if (ephemeral)
- /* Caller promises that gc won't make him lose */
- return XSTRING (tem)->data;
- else
- {
- register unsigned char **e;
- unsigned char *s;
- int ll = XSTRING (tem)->size;
-
- /* Look for element in the original unix environment */
- for (e = (unsigned char **) environ; *e; e++)
- if (!bcmp (str, *e, len) && *(*e + len) == '=')
- {
- s = *e + len + 1;
- if (strlen (s) >= ll)
- /* User hasn't either hasn't munged it or has set it
- to something shorter -- we don't have to cons */
- goto copy;
- else
- goto cons;
- };
- cons:
- /* User has setenv'ed it to a diferent value, and our caller
- isn't guaranteeing that he won't stash it away somewhere.
- We can't just return a pointer to the lisp string, as that
- will be corrupted when gc happens. So, we cons (in such
- a way that it can't be freed -- though this isn't such a
- problem since the only callers of getenv (as opposed to
- those of egetenv) are very early, before the user -could-
- have frobbed the environment. */
- s = (unsigned char *) xmalloc (ll + 1);
- copy:
- bcopy (XSTRING (tem)->data, s, ll + 1);
- return (s);
- }
- }
- }
- return ((unsigned char *) 0);
-}
-
-/* unsigned -- stupid delcaration in lisp.h */ char *
-getenv (str)
- register unsigned char *str;
-{
- return ((char *) getenv_1 (str, 0));
-}
-
-unsigned char *
-egetenv (str)
- register unsigned char *str;
-{
- return (getenv_1 (str, 1));
-}
-\f
-
-#if (1 == 1) /* use caller-alloca versions, rather than callee-malloc */
-int
-size_of_current_environ ()
-{
- register int size;
- Lisp_Object tem;
-
- tem = Flength (Venvironment_alist);
-
- size = (XINT (tem) + 1) * sizeof (unsigned char *);
- /* + 1 for environment-terminating 0 */
-
- for (tem = Venvironment_alist; !NULL (tem); tem = XCONS (tem)->cdr)
- {
- register Lisp_Object str, val;
-
- str = XCONS (XCONS (tem)->car)->car;
- val = XCONS (XCONS (tem)->car)->cdr;
-
- size += (XSTRING (str)->size +
- XSTRING (val)->size +
- 2); /* 1 for '=', 1 for '\000' */
- }
- return size;
-}
-
-void
-get_current_environ (memory_block)
- unsigned char **memory_block;
-{
- register unsigned char **e, *s;
- register int len;
- register Lisp_Object tem;
-
- e = memory_block;
-
- tem = Flength (Venvironment_alist);
-
- s = (unsigned char *) memory_block
- + (XINT (tem) + 1) * sizeof (unsigned char *);
-
- for (tem = Venvironment_alist; !NULL (tem); tem = XCONS (tem)->cdr)
- {
- register Lisp_Object str, val;
-
- str = XCONS (XCONS (tem)->car)->car;
- val = XCONS (XCONS (tem)->car)->cdr;
-
- *e++ = s;
- len = XSTRING (str)->size;
- bcopy (XSTRING (str)->data, s, len);
- s += len;
- *s++ = '=';
- len = XSTRING (val)->size;
- bcopy (XSTRING (val)->data, s, len);
- s += len;
- *s++ = '\000';
- }
- *e = 0;
-}
-
-#else
-/* dead code (this function mallocs, caller frees) superseded by above (which allows caller to use alloca) */
-unsigned char **
-current_environ ()
-{
- unsigned char **env;
- register unsigned char **e, *s;
- register int len, env_len;
- Lisp_Object tem;
- Lisp_Object str, val;
-
- tem = Flength (Venvironment_alist);
-
- env_len = (XINT (tem) + 1) * sizeof (char *);
- /* + 1 for terminating 0 */
-
- len = 0;
- for (tem = Venvironment_alist; !NULL (tem); tem = XCONS (tem)->cdr)
- {
- str = XCONS (XCONS (tem)->car)->car;
- val = XCONS (XCONS (tem)->car)->cdr;
-
- len += (XSTRING (str)->size +
- XSTRING (val)->size +
- 2);
- }
-
- e = env = (unsigned char **) xmalloc (env_len + len);
- s = (unsigned char *) env + env_len;
-
- for (tem = Venvironment_alist; !NULL (tem); tem = XCONS (tem)->cdr)
- {
- str = XCONS (XCONS (tem)->car)->car;
- val = XCONS (XCONS (tem)->car)->cdr;
-
- *e++ = s;
- len = XSTRING (str)->size;
- bcopy (XSTRING (str)->data, s, len);
- s += len;
- *s++ = '=';
- len = XSTRING (val)->size;
- bcopy (XSTRING (val)->data, s, len);
- s += len;
- *s++ = '\000';
- }
- *e = 0;
-
- return env;
-}
-
-#endif /* dead code */
-
-\f
-DEFUN ("getenv", Fgetenv, Sgetenv, 1, 2, "sEnvironment variable: \np",
- "Return the value of environment variable VAR, as a string.\n\
-When invoked interactively, print the value in the echo area.\n\
-VAR is a string, the name of the variable,\n\
- or the symbol t, meaning to return an alist representing the\n\
- current environment.")
- (str, interactivep)
- Lisp_Object str, interactivep;
-{
- Lisp_Object val;
-
- if (str == Qt) /* If arg is t, return whole environment */
- return (Fcopy_alist (Venvironment_alist));
-
- CHECK_STRING (str, 0);
- val = Fcdr (Fassoc (str, Venvironment_alist));
- if (!NULL (interactivep))
- {
- if (NULL (val))
- message ("%s not defined in environment", XSTRING (str)->data);
- else
- message ("\"%s\"", XSTRING (val)->data);
- }
- return val;
-}
-
-DEFUN ("setenv", Fsetenv, Ssetenv, 1, 2,
- "sEnvironment variable: \nsSet %s to value: ",
- "Set the value of environment variable VAR to VALUE.\n\
-Both args must be strings. Returns VALUE.")
- (str, val)
- Lisp_Object str;
- Lisp_Object val;
-{
- Lisp_Object tem;
-
- CHECK_STRING (str, 0);
- if (!NULL (val))
- CHECK_STRING (val, 0);
-
- set_environment_alist (str, val);
- return val;
-}
-\f
-
-syms_of_environ ()
-{
- staticpro (&Venvironment_alist);
- defsubr (&Ssetenv);
- defsubr (&Sgetenv);
-}
-
-init_environ ()
-{
- Venvironment_alist = Qnil;
- initialize_environment_alist ();
-}
-
-#endif /* MAINTAIN_ENVIRONMENT */
+++ /dev/null
-/* Machine description file for MS-DOS
-
- Copyright (C) 1993 Free Software Foundation, Inc.
-
-This file is part of GNU Emacs.
-
-GNU Emacs is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Emacs is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Emacs; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-/* Note: lots of stuff here was taken from m-dos386.h in demacs. */
-
-
-/* The following three symbols give information on
- the size of various data types. */
-
-#define SHORTBITS 16 /* Number of bits in a short */
-#define INTBITS 32 /* Number of bits in an int */
-#define LONGBITS 32 /* Number of bits in a long */
-
-/* Define BIG_ENDIAN iff lowest-numbered byte in a word
- is the most significant byte. */
-
-/* #define BIG_ENDIAN */
-
-/* Define NO_ARG_ARRAY if you cannot take the address of the first of a
- * group of arguments and treat it as an array of the arguments. */
-
-/* #define NO_ARG_ARRAY */
-
-/* Define WORD_MACHINE if addresses and such have
- * to be corrected before they can be used as byte counts. */
-
-/* #define WORD_MACHINE */
-
-/* Define how to take a char and sign-extend into an int.
- On machines where char is signed, this is a no-op. */
-
-#define SIGN_EXTEND_CHAR(c) (c)
-
-/* Now define a symbol for the cpu type, if your compiler
- does not define it automatically:
- Ones defined so far include vax, m68000, ns16000, pyramid,
- orion, tahoe, APOLLO and many others */
-
-#define INTEL386
-
-/* Use type int rather than a union, to represent Lisp_Object */
-/* This is desirable for most machines. */
-
-#define NO_UNION_TYPE
-
-/* Define EXPLICIT_SIGN_EXTEND if XINT must explicitly sign-extend
- the 24-bit bit field into an int. In other words, if bit fields
- are always unsigned.
-
- If you use NO_UNION_TYPE, this flag does not matter. */
-
-#define EXPLICIT_SIGN_EXTEND
-
-/* Data type of load average, as read out of kmem. */
-
-/* #define LOAD_AVE_TYPE long */
-
-/* Convert that into an integer that is 100 for a load average of 1.0 */
-
-/* #define LOAD_AVE_CVT(x) (int) (((double) (x)) * 100.0 / FSCALE) */
-
-/* Define CANNOT_DUMP on machines where unexec does not work.
- Then the function dump-emacs will not be defined
- and temacs will do (load "loadup") automatically unless told otherwise. */
-
-/* #define CANNOT_DUMP */
-
-/* Define VIRT_ADDR_VARIES if the virtual addresses of
- pure and impure space as loaded can vary, and even their
- relative order cannot be relied on.
-
- Otherwise Emacs assumes that text space precedes data space,
- numerically. */
-
-/* #define VIRT_ADDR_VARIES */
-
-/* Define C_ALLOCA if this machine does not support a true alloca
- and the one written in C should be used instead.
- Define HAVE_ALLOCA to say that the system provides a properly
- working alloca function and it should be used.
- Define neither one if an assembler-language alloca
- in the file alloca.s should be used. */
-
-#define HAVE_ALLOCA
-#define alloca(x) __builtin_alloca(x)
-
-/* Define NO_REMAP if memory segmentation makes it not work well
- to change the boundary between the text section and data section
- when Emacs is dumped. If you define this, the preloaded Lisp
- code will not be sharable; but that's better than failing completely. */
-
-#define NO_REMAP
-
-/* We need a little extra space, see ../../lisp/loadup.el */
-#define PURESIZE 240000
-
-/* We have (the code to control) a mouse. */
-#define HAVE_MOUSE
+++ /dev/null
-/* Definitions for Emacs running on Mach version 2 (non-kernelized system).
- 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 2, or (at your option)
-any later version.
-
-GNU Emacs is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Emacs; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "bsd4-3.h"
-
-/* SYSTEM_TYPE should indicate the kind of system you are using.
- It sets the Lisp variable system-type. We'll need to undo the bsd one. */
-
-#undef SYSTEM_TYPE
-#define SYSTEM_TYPE "next-mach"
-
-#define LD_SWITCH_SYSTEM -X -noseglinkedit
-
-/* Don't use -lc on the NeXT. */
-#define LIB_STANDARD -lsys_s
-#define LIB_MATH -lm
-
-#define environ _environ
-
-#define START_FILES pre-crt0.o
-#define UNEXEC unexnext.o
-
-/* start_of_text isn't actually used, so make it compile without error. */
-#define TEXT_START 0
-/* This seems to be right for end_of_text, but it may not be used anyway. */
-#define TEXT_END get_etext ()
-/* This seems to be right for end_of_data, but it may not be used anyway. */
-#define DATA_END get_edata ()
-
-/* Defining KERNEL_FILE causes lossage because sys/file.h
- stupidly gets confused by it. */
-#undef KERNEL_FILE
+++ /dev/null
-/* Block-relocating memory allocator.
- 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. */
-
-/* This package works by allocating blocks from a zone of memory
- above that used by malloc (). When malloc needs more space that
- would enter our zone, we relocate blocks upward. The bottom of
- our zone is kept in the variable `virtual_break_value'. The top
- of our zone is indicated by `real_break_value'.
-
- As blocks are freed, a free list is maintained and we attempt
- to satisfy further requests for space using a first-fit policy.
- If there are holes, but none fit, memory is compacted and a new
- block is obtained at the top of the zone.
-
- NOTE that our blocks are always rounded to page boundaries. */
-
-/*
- NOTES:
-
- Once this is stable, I can speed things up by intially leaving a large
- gap between real_break_value and true_break_value, or maybe making
- a large hole before the first block.
-
- If we also kept track of size_wanted, we could gain some
- extra space upon compactification.
-
- Perhaps we should just note a hole when malloc does doing sbrk(-n)?
-
- Relocating downward upon freeing the first block would simplify
- other things.
-
- When r_alloc places a block in a hole, we could easily check if there's
- much more than required, and leave a hole.
- */
-\f
-#include "mem_limits.h"
-
-static POINTER r_alloc_sbrk ();
-static POINTER sbrk ();
-static POINTER brk ();
-
-/* Variable `malloc' uses for the function which gets more space
- from the system. */
-extern POINTER (*__morecore) ();
-
-/* List of variables which point into the associated data block. */
-struct other_pointer
-{
- POINTER *location;
- struct other_pointer *next;
-};
-
-/* List describing all the user's pointers to relocatable blocks. */
-typedef struct rel_pointers
-{
- struct rel_pointers *next;
- struct rel_pointers *prev;
- struct other_pointer *others; /* Other variables which use this block. */
- POINTER *location; /* Location of the block's pointer. */
- POINTER block; /* Address of the actual data. */
- int size; /* The size of the block. */
-} relocatable_pointer;
-
-#define REL_NIL ((struct rel_pointers *) 0)
-
-static relocatable_pointer *pointer_list;
-static relocatable_pointer *last_pointer;
-
-#define MAX_HOLES 2
-
-/* Vector of available holes among allocated blocks. This can include
- a hole at the beginning of the list, but never the end. */
-typedef struct
-{
- POINTER address;
- unsigned int size;
-} hole_descriptor;
-
-static hole_descriptor r_alloc_holes[MAX_HOLES];
-
-/* Number of holes currently available. */
-static int holes;
-
-/* The process break value (i.e., curbrk) */
-static POINTER real_break_value;
-
-/* The REAL (i.e., page aligned) break value. */
-static POINTER true_break_value;
-
-/* Address of start of data space in use by relocatable blocks.
- This is what `malloc' thinks is the process break value. */
-static POINTER virtual_break_value;
-
-/* Nonzero if we have told `malloc' to start using `r_alloc_sbrk'
- instead of calling `sbrk' directly. */
-int r_alloc_in_use;
-
-#define PAGE (getpagesize ())
-#define ALIGNED(addr) (((unsigned int) (addr) & (PAGE - 1)) == 0)
-#define ROUNDUP(size) (((unsigned int) (size) + PAGE) & ~(PAGE - 1))
-
-/*
- Level number of warnings already issued.
- 0 -- no warnings issued.
- 1 -- 75% warning already issued.
- 2 -- 85% warning already issued.
-*/
-static int warnlevel;
-
-/* Function to call to issue a warning;
- 0 means don't issue them. */
-static void (*warnfunction) ();
-\f
-/* Call this to start things off. It determines the current process
- break value, as well as the `true' break value--because the system
- allocates memory in page increments, if the break value is not page
- aligned it means that space up to the next page boundary is actually
- available. */
-
-void
-malloc_init (start, warn_func)
- POINTER start;
- void (*warn_func) ();
-{
- r_alloc_in_use = 1;
- __morecore = r_alloc_sbrk;
-
- virtual_break_value = real_break_value = sbrk (0);
- if (ALIGNED (real_break_value))
- true_break_value = real_break_value;
- else
- true_break_value = (POINTER) ROUNDUP (real_break_value);
-
- if (start)
- data_space_start = start;
- lim_data = 0;
- warnlevel = 0;
- warnfunction = warn_func;
-
- get_lim_data ();
-}
-
-/* Get more space for us to use. Return a pointer to SIZE more
- bytes of space. SIZE is internally rounded up to a page boundary,
- and requests for integral pages prefetch an extra page. */
-
-static POINTER
-get_more_space (size)
- unsigned int size;
-{
- unsigned int margin = true_break_value - real_break_value;
- unsigned int get;
- POINTER old_break = real_break_value;
-
- if (size == 0)
- return real_break_value;
-
- if (size <= margin)
- {
- real_break_value += size;
- return old_break;
- }
-
- get = ROUNDUP (size - margin);
- if (sbrk (get) < (POINTER) 0)
- return NULL;
-
- true_break_value += get;
- real_break_value = (old_break + size);
-
- return old_break;
-}
-
-/* Relinquish size bytes of space to the system. Space is only returned
- in page increments. If successful, return real_break_value. */
-
-static POINTER
-return_space (size)
- unsigned int size;
-{
- unsigned int margin = (true_break_value - real_break_value) + size;
- unsigned int to_return = (margin / PAGE) * PAGE;
- unsigned new_margin = margin % PAGE;
-
- true_break_value -= to_return;
- if (! brk (true_break_value))
- return NULL;
-
- real_break_value = true_break_value - new_margin;
- return real_break_value;
-}
-\f
-/* Record a new hole in memory beginning at ADDRESS of size SIZE.
- Holes are ordered by location. Adjacent holes are merged.
- Holes are zero filled before being noted. */
-
-static void
-note_hole (address, size)
- POINTER address;
- int size;
-{
- register int this_hole = holes - 1; /* Start at the last hole. */
- register POINTER end = address + size; /* End of the hole. */
- register int i;
-
- if (holes)
- {
- /* Find the hole which should precede this new one. */
- while (this_hole >= 0 && r_alloc_holes[this_hole].address > address)
- this_hole--;
-
- /* Can we merge with preceding? */
- if (this_hole >= 0
- && r_alloc_holes[this_hole].address + r_alloc_holes[this_hole].size
- == address)
- {
- r_alloc_holes[this_hole].size += size;
-
- if (this_hole == holes - 1)
- return;
-
- /* Can we also merge with following? */
- if (end == r_alloc_holes[this_hole + 1].address)
- {
- r_alloc_holes[this_hole].size
- += r_alloc_holes[this_hole + 1].size;
-
- for (i = this_hole + 1; i < holes - 1; i++)
- r_alloc_holes[i] = r_alloc_holes[i + 1];
- holes--;
- }
-
- return;
- }
-
- if (this_hole < holes - 1) /* there are following holes */
- {
- register int next_hole = this_hole + 1;
-
- /* Can we merge with the next hole? */
- if (end == r_alloc_holes[next_hole].address)
- {
- r_alloc_holes[next_hole].address = address;
- r_alloc_holes[next_hole].size += size;
- return;
- }
-
- /* Can't merge, so insert. */
- for (i = holes; i > next_hole; i--)
- r_alloc_holes[i] = r_alloc_holes[i - 1];
- r_alloc_holes[next_hole].address = address;
- r_alloc_holes[next_hole].size = size;
- holes++;
-
- return;
- }
- else /* Simply add this hole at the end. */
- {
- r_alloc_holes[holes].address = address;
- r_alloc_holes[holes].size = size;
- holes++;
-
- return;
- }
-
- abort ();
- }
- else /* Make the first hole. */
- {
- holes = 1;
- r_alloc_holes[0].address = address;
- r_alloc_holes[0].size = size;
- }
-}
-
-/* Mark hole HOLE as no longer available by re-organizing the vector.
- HOLE is the Nth hole, beginning with 0. This doesn *not* affect memory
- organization. */
-
-static void
-delete_hole (hole)
- int hole;
-{
- register int i;
-
- for (i = hole; i < holes - 1; i++)
- r_alloc_holes[i] = r_alloc_holes[i + 1];
-
- holes--;
-}
-\f
-/* Insert a newly allocated pointer, NEW_PTR, at the appropriate
- place in our list. */
-
-static void
-insert (new_ptr)
- register relocatable_pointer *new_ptr;
-{
- register relocatable_pointer *this_ptr = pointer_list;
-
- while (this_ptr != REL_NIL && this_ptr->block < new_ptr->block)
- this_ptr = this_ptr->next;
-
- if (this_ptr == REL_NIL)
- abort (); /* Use `attach' for appending. */
-
- new_ptr->next = this_ptr;
- new_ptr->prev = this_ptr->prev;
- this_ptr->prev = new_ptr;
-
- if (this_ptr == pointer_list)
- pointer_list = new_ptr;
- else
- new_ptr->prev->next = new_ptr;
-}
-
-/* Attach a newly allocated pointer, NEW_PTR, to the end of our list. */
-
-static void
-attach (new_ptr)
- relocatable_pointer *new_ptr;
-{
- if (pointer_list == REL_NIL)
- {
- pointer_list = new_ptr;
- last_pointer = new_ptr;
- new_ptr->next = new_ptr->prev = REL_NIL;
- }
- else
- {
- new_ptr->next = REL_NIL;
- last_pointer->next = new_ptr;
- new_ptr->prev = last_pointer;
- last_pointer = new_ptr;
- }
-}
-
-static relocatable_pointer *
-find_block (block)
- POINTER block;
-{
- register relocatable_pointer *this_ptr = pointer_list;
-
- while (this_ptr != REL_NIL && this_ptr->block != block)
- this_ptr = this_ptr->next;
-
- return this_ptr;
-}
-
-static relocatable_pointer *
-find_location (address)
- POINTER *address;
-{
- register relocatable_pointer *this_ptr = pointer_list;
-
- while (this_ptr != REL_NIL && this_ptr->location != address)
- {
- struct other_pointer *op = this_ptr->others;
-
- while (op != (struct other_pointer *) 0)
- {
- if (op->location == address)
- return this_ptr;
-
- op = op->next;
- }
-
- this_ptr = this_ptr->next;
- }
-
- return this_ptr;
-}
-
-\f
-static void compactify ();
-
-/* Record of last new block allocated. */
-static relocatable_pointer *last_record;
-
-/* Allocate a block of size SIZE and record that PTR points to it.
- If successful, store the address of the block in *PTR and return
- it as well. Otherwise return NULL. */
-
-POINTER
-r_alloc (ptr, size)
- POINTER *ptr;
- int size;
-{
- register relocatable_pointer *record
- = (relocatable_pointer *) malloc (sizeof (relocatable_pointer));
- register POINTER block;
-
- /* If we can't get space to record this pointer, fail. */
- if (record == 0)
- return NULL;
-
- last_record = record;
-
- if (holes) /* Search for a hole the right size. */
- {
- int i;
-
- for (i = 0; i < holes; i++)
- if (r_alloc_holes[i].size >= size)
- {
- record->location = ptr;
- record->others = (struct other_pointer *) 0;
- record->block = *ptr = r_alloc_holes[i].address;
- if (r_alloc_holes[i].size > ROUNDUP (size))
- {
- record->size = ROUNDUP (size);
- r_alloc_holes[i].size -= ROUNDUP (size);
- r_alloc_holes[i].address += ROUNDUP (size);
- }
- else
- {
- record->size = r_alloc_holes[i].size;
- delete_hole (i);
- }
- insert (record);
-
- *ptr = record->block;
- return record->block;
- }
-
- /* No holes large enough. Burp. */
- compactify ();
- }
-
- /* No holes: grow the process. */
- block = get_more_space (size);
- if (block == NULL)
- {
- free (record);
- return NULL;
- }
-
- /* Return the address of the block. */
- *ptr = block;
-
- /* Record and append this pointer to our list. */
- record->location = ptr;
- record->others = (struct other_pointer *) 0;
- record->block = block;
- record->size = size;
- attach (record);
-
- return block;
-}
-
-/* Declare VAR to be a pointer which points into the block of r_alloc'd
- memory at BLOCK.
-
- If VAR is already delcared for this block, simply return.
- If VAR currently points to some other block, remove that declaration
- of it, then install the new one.
-
- Return 0 if successful, -1 otherwise. */
-
-int
-r_alloc_declare (var, block)
- POINTER *var;
- register POINTER block;
-{
- register relocatable_pointer *block_ptr = find_block (block);
- relocatable_pointer *var_ptr = find_location (var);
- register struct other_pointer *other;
-
- if (block_ptr == REL_NIL)
- abort ();
-
- if (var_ptr != REL_NIL) /* Var already declared somewhere. */
- {
- register struct other_pointer *po;
-
- if (var_ptr == block_ptr) /* Var already points to this block. */
- return 0;
-
- po = (struct other_pointer *) 0;
- other = var_ptr->others;
- while (other && other->location != var)
- {
- po = other;
- other = other->next;
- }
-
- if (!other) /* This only happens if the location is */
- abort (); /* the main pointer and not an `other' */
-
- if (po) /* In the chain */
- {
- po->next = other->next;
- free (other);
- }
- else /* Only element of the chain */
- {
- free (var_ptr->others);
- var_ptr->others = (struct other_pointer *) 0;
- }
- }
-
- /* Install this variable as an `other' element */
-
- other = (struct other_pointer *) malloc (sizeof (struct other_pointer));
-
- if (other == 0)
- return -1;
-
- /* If the malloc relocated this data block, adjust this variable. */
- if (block != block_ptr->block)
- {
- int offset = block_ptr->block - block;
-
- *var += offset;
- }
-
- other->location = var;
- other->next = (struct other_pointer *) 0;
-
- if (block_ptr->others == (struct other_pointer *) 0)
- block_ptr->others = other;
- else
- {
- register struct other_pointer *op = block_ptr->others;
-
- while (op->next != (struct other_pointer *) 0)
- op = op->next;
- op->next = other;
- }
-
- return 0;
-}
-\f
-/* Recursively free the linked list of `other' pointers to a block. */
-
-static void
-free_others (another)
- struct other_pointer *another;
-{
- if (another == (struct other_pointer *) 0)
- return;
-
- free_others (another->next);
- free (another);
-}
-
-/* Remove the element pointed to by PTR from the doubly linked list.
- Record the newly freed space in `holes', unless it was at the end,
- in which case return that space to the system. Return 0 if successful,
- -1 otherwise. */
-
-int
-r_alloc_free (ptr)
- register POINTER *ptr;
-{
- register relocatable_pointer *this_ptr = find_block (*ptr);
-
- if (this_ptr == REL_NIL)
- return -1;
- else
- {
- register relocatable_pointer *prev = this_ptr->prev;
- register relocatable_pointer *next = this_ptr->next;
- if (next && prev) /* Somewhere in the middle */
- {
- next->prev = prev;
- prev->next = next;
- }
- else if (prev) /* Last block */
- {
- prev->next = REL_NIL;
- last_pointer = prev;
- return_space (this_ptr->size);
- free_others (this_ptr->others);
- free (this_ptr);
-
- return 0;
- }
- else if (next) /* First block */
- {
- next->prev = REL_NIL;
- pointer_list = next;
- }
- else if (this_ptr = pointer_list) /* ONLY block */
- {
- pointer_list = REL_NIL;
- last_pointer = REL_NIL;
- if (holes) /* A hole precedes this block. */
- {
- holes = 0;
- return_space (real_break_value - virtual_break_value);
- }
- else
- return_space (this_ptr->size);
-
- if (real_break_value != virtual_break_value)
- abort ();
-
- free_others (this_ptr->others);
- free (this_ptr);
- /* Turn off r_alloc_in_use? */
-
- return 0;
- }
- else
- abort (); /* Weird shit */
-
- free_others (this_ptr->others);
- free (this_ptr);
- bzero (this_ptr->block, this_ptr->size);
- note_hole (this_ptr->block, this_ptr->size);
-
- if (holes == MAX_HOLES)
- compactify ();
- }
-
- return 0;
-}
-
-/* Change the size of the block pointed to by the thing in PTR.
- If neccessary, r_alloc a new block and copy the data there.
- Return a pointer to the block if successfull, NULL otherwise.
-
- Note that if the size requested is less than the actual bloc size,
- nothing is done and the pointer is simply returned. */
-
-POINTER
-r_re_alloc (ptr, size)
- POINTER *ptr;
- int size;
-{
- register relocatable_pointer *this_ptr = find_block (*ptr);
- POINTER block;
-
- if (! this_ptr)
- return NULL;
-
- if (this_ptr->size >= size) /* Already have enough space. */
- return *ptr;
-
- /* Here we could try relocating the blocks just above... */
- block = r_alloc (ptr, size);
- if (block)
- {
- bcopy (this_ptr->block, block, this_ptr->size);
- if (this_ptr->others)
- last_record->others = this_ptr->others;
-
- if (! r_alloc_free (this_ptr->block))
- abort ();
-
- *ptr = block;
- return block;
- }
-
- return NULL;
-}
-\f
-
-/* Move and relocate all blocks from FIRST_PTR to LAST_PTR, inclusive,
- downwards to space starting at ADDRESS. */
-
-static int
-move_blocks_downward (first_ptr, last_ptr, address)
- relocatable_pointer *first_ptr, *last_ptr;
- POINTER address;
-{
- int size = (last_ptr->block + last_ptr->size) - first_ptr->block;
- register relocatable_pointer *this_ptr = first_ptr;
- register offset = first_ptr->block - address;
- register struct other_pointer *op;
-
- /* Move all the data. */
- bcopy (first_ptr->block, address, size);
-
- /* Now relocate all the pointers to those blocks. */
- while (1)
- {
- this_ptr->block -= offset;
- *this_ptr->location = this_ptr->block;
-
- op = this_ptr->others;
- while (op != (struct other_pointer *) 0)
- {
- *op->location -= offset;
- op = op->next;
- }
-
- if (this_ptr == last_ptr)
- return;
- else
- this_ptr = this_ptr->next;
- }
-
- return size;
-}
-
-/* Burp our memory zone. */
-
-static void
-compactify ()
-{
- register relocatable_pointer *this_ptr = pointer_list;
- relocatable_pointer *first_to_move;
- register relocatable_pointer *last_to_move;
- hole_descriptor *this_hole = &r_alloc_holes[0];
- register hole_descriptor *next_hole;
- register POINTER end; /* First address after hole */
- unsigned int space_regained = 0;
-
- while (holes) /* While there are holes */
- {
- /* Find the first block after this hole. */
- end = this_hole->address + this_hole->size;
- while (this_ptr && this_ptr->block != end)
- this_ptr = this_ptr->next;
-
- if (! this_ptr)
- abort ();
-
- next_hole = this_hole + 1;
- last_to_move = first_to_move = this_ptr;
- this_ptr = this_ptr->next;
-
- /* Note all blocks located before the next hole. */
- while (this_ptr && this_ptr->block < next_hole->address)
- {
- last_to_move = this_ptr;
- this_ptr = this_ptr->next;
- }
- space_regained +=
- move_blocks_downward (first_to_move, last_to_move, this_hole->address);
-
- holes--;
- this_hole = next_hole;
- }
-
- return_space (space_regained);
-}
-\f
-/* Relocate the list elements from the beginning of the list up to and
- including UP_TO_THIS_PTR to the area beginning at FREE_SPACE, which is
- after all current blocks.
-
- First copy all the data, then adjust the pointers and reorganize
- the list. NOTE that this *only* works for contiguous blocks. */
-
-static unsigned int
-relocate_to_end (up_to_this_ptr, free_space)
- register relocatable_pointer *up_to_this_ptr;
- POINTER free_space;
-{
- register relocatable_pointer *this_ptr;
- POINTER block_start = pointer_list->block;
- POINTER block_end = up_to_this_ptr->block + up_to_this_ptr->size;
- unsigned int total_size = block_end - block_start;
- unsigned int offset = (int) (free_space - block_start);
-
- bcopy (block_start, free_space, total_size);
- for (this_ptr = up_to_this_ptr; this_ptr; this_ptr = this_ptr->prev)
- {
- struct other_pointer *op = this_ptr->others;
-
- *this_ptr->location += offset;
- this_ptr->block += offset;
-
- while (op != (struct other_pointer *) 0)
- {
- *op->location += offset;
- op = op->next;
- }
- }
-
- /* Connect the head to the tail. */
- last_pointer->next = pointer_list;
- pointer_list->prev = last_pointer;
-
- /* Disconnect */
- up_to_this_ptr->next->prev = REL_NIL;
- pointer_list = up_to_this_ptr->next;
- up_to_this_ptr->next = REL_NIL;
- last_pointer = up_to_this_ptr;
-
- return total_size; /* of space relocated. */
-}
-\f
-/* Relocate the list elements from FROM_THIS_PTR to (and including)
- the last to the zone beginning at FREE_SPACE, which is located
- before any blocks.
-
- First copy all the data, then adjust the pointers and reorganize
- the list. NOTE that this *only* works for contiguous blocks. */
-
-static unsigned int
-relocate_to_beginning (from_this_ptr, free_space)
- register relocatable_pointer *from_this_ptr;
- POINTER free_space;
-{
- POINTER block_start = from_this_ptr->block;
- POINTER block_end = last_pointer->block + last_pointer->size;
- unsigned int total_size = (int) (block_end - block_start);
- unsigned int offset = (int) (from_this_ptr->block - free_space);
- register relocatable_pointer *this_ptr;
-
- bcopy (block_start, free_space, total_size);
- for (this_ptr = from_this_ptr; this_ptr; this_ptr = this_ptr->next)
- {
- struct other_pointer *op = this_ptr->others;
-
- *this_ptr->location -= offset;
- this_ptr->block -= offset;
-
- while (op != (struct other_pointer *) 0)
- {
- *op->location -= offset;
- op = op->next;
- }
- }
-
- /* Connect the end to the beginning. */
- last_pointer->next = pointer_list;
- pointer_list->prev = last_pointer;
-
- /* Disconnect and reset first and last. */
- from_this_ptr->prev->next = REL_NIL;
- last_pointer = from_this_ptr->prev;
- pointer_list = from_this_ptr;
- pointer_list->prev = REL_NIL;
-
- return total_size; /* of space moved. */
-}
-\f
-/* Relocate any blocks neccessary, either upwards or downwards,
- to obtain a space of SIZE bytes. Assumes we have at least one block. */
-
-static unsigned int
-relocate (size)
- register int size;
-{
- register relocatable_pointer *ptr;
- register int got = 0;
-
- if (size > 0) /* Up: Relocate enough blocs to get SIZE. */
- {
- register POINTER new_space;
-
- for (ptr = pointer_list; got < size && ptr; ptr = ptr->next)
- got += ptr->size;
-
- if (ptr == REL_NIL)
- ptr = last_pointer;
-
- new_space = get_more_space (size);
- if (!new_space)
- return 0;
-
- return (relocate_to_end (ptr, pointer_list->block + size));
- }
-
- if (size < 0) /* Down: relocate as many blocs as will
- fit in SIZE bytes of space. */
- {
- register POINTER to_zone;
- unsigned int moved;
-
- for (ptr = last_pointer; got >= size && ptr; ptr = ptr->prev)
- got -= ptr->size;
-
- if (ptr == REL_NIL)
- ptr = pointer_list;
- else
- {
- /* Back off one block to be <= size */
- got += ptr->size;
- ptr = ptr->next;
- }
-
- if (got >= size)
- {
- to_zone = virtual_break_value - size + got;
- moved = relocate_to_beginning (ptr, to_zone);
- if (moved)
- return_space (moved);
-
- return moved;
- }
-
- return 0;
- }
-
- abort ();
-}
-\f
-/* This function encapsulates `sbrk' to preserve the relocatable blocks.
- It is called just like `sbrk'. When relocatable blocks are in use,
- `malloc' must use this function instead of `sbrk'. */
-
-POINTER
-r_alloc_sbrk (size)
- unsigned int size;
-{
- POINTER new_zone; /* Start of the zone we will return. */
-
-#if 0
- if (! r_alloc_in_use)
- return (POINTER) sbrk (size);
-#endif
-
- if (size == 0)
- return virtual_break_value;
-
- if (size > 0) /* Get more space */
- {
- register unsigned int space;
-
- if (pointer_list == REL_NIL)
- {
- POINTER space = get_more_space (size);
-
- virtual_break_value = real_break_value;
- return space;
- }
-
- new_zone = virtual_break_value;
-
- /* Check if there is a hole just before the buffer zone. */
- if (holes && r_alloc_holes[0].address == virtual_break_value)
- {
- if (r_alloc_holes[0].size > size)
- {
- /* Adjust the hole size. */
- r_alloc_holes[0].size -= size;
- r_alloc_holes[0].address += size;
- virtual_break_value += size;
-
- return new_zone;
- }
-
- if (r_alloc_holes[0].size == size)
- {
- virtual_break_value += size;
- delete_hole (0);
-
- return new_zone;
- }
-
- /* Adjust the size requested by space
- already available in this hole. */
- size -= r_alloc_holes[0].size;
- virtual_break_value += r_alloc_holes[0].size;
- delete_hole (0);
- }
-
- space = relocate (size);
- if (!space)
- return (POINTER) -1;
-
-#ifdef REL_ALLOC_SAVE_SPACE
- move_blocks_downward
-#else
- bzero (new_zone, space);
- if (space > size)
- note_hole (new_zone + size, space - size);
-#endif /* REL_ALLOC_SAVE_SPACE */
-
- virtual_break_value += size;
- return new_zone;
- }
- else /* Return space to system */
- {
- int moved;
- int left_over;
- POINTER old_break_value;
-
- if (pointer_list == REL_NIL)
- {
- POINTER space = return_space (-size);
- virtual_break_value = real_break_value;
-
- return space;
- }
-
- if (holes && r_alloc_holes[0].address == virtual_break_value)
- {
- size -= r_alloc_holes[0].size;
- delete_hole (0);
- }
-
- moved = relocate (size);
- old_break_value = virtual_break_value;
-
- if (!moved)
- return (POINTER) -1;
-
- left_over = moved + size;
- virtual_break_value += size;
-
- if (left_over)
- {
-#ifdef REL_ALLOC_SAVE_SPACE
- move_blocks_downward
-#else
- bzero (virtual_break_value, left_over);
- note_hole (virtual_break_value, left_over);
-#endif /* not REL_ALLOC_SAVE_SPACE */
- }
-
- return old_break_value;
- }
-}
-
-/* For debugging */
-
-#include <stdio.h>
-
-void
-memory_trace ()
-{
- relocatable_pointer *ptr;
- int i;
-
- fprintf (stderr, "virtual: 0x%x\n real: 0x%x\n true: 0x%x\n\n",
- virtual_break_value, real_break_value, true_break_value);
- fprintf (stderr, "Blocks:\n");
- for (ptr = pointer_list; ptr; ptr = ptr->next)
- {
- fprintf (stderr, " address: 0x%x\n", ptr->block);
- fprintf (stderr, " size: 0x%x\n", ptr->size);
- if (ptr->others)
- {
- struct other_pointer *op = ptr->others;
- fprintf (stderr, " others:", ptr->size);
- while (op)
- {
- fprintf (stderr, " 0x%x", op->location);
- op = op->next;
- }
- fprintf (stderr, "\n");
- }
- }
-
- if (holes)
- {
- fprintf (stderr, "\nHoles:\n");
- for (i = 0; i < holes; i++)
- {
- fprintf (stderr, " address: 0x%x\n", r_alloc_holes[i].address);
- fprintf (stderr, " size: 0x%x\n", r_alloc_holes[i].size);
- }
- }
-
- fprintf (stderr, "\n\n");
-}
+++ /dev/null
-/* casper@fwi.uva.nl says this file is not needed
- and sol2.h should work. */
-
-#include "sol2.h"
-
-/* Take care of libucb.a as well as X Windows. */
-#undef LD_SWITCH_SYSTEM
-#ifndef __GNUC__
-#define LD_SWITCH_SYSTEM -R/usr/openwin/lib:/usr/ucblib
-#else /* GCC */
-#define LD_SWITCH_SYSTEM -Xlinker -R/usr/openwin/lib:/usr/ucblib
-#endif /* GCC */
-
-/* Link with libucb.a. */
-#ifdef LIB_STANDARD
-#undef LIB_STANDARD
-#define LIB_STANDARD -lc -L/usr/ucblib -lucb
-#endif
+++ /dev/null
-/* 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 2, or (at your option)
-any later version.
-
-GNU Emacs is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Emacs; see the file COPYING. If not, write to
-the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-Boston, MA 02111-1307, USA.
-
-In other words, you are welcome to use, share and improve this program.
-You are forbidden to forbid anyone else to use, share and improve
-what you give them. Help stamp out software-hoarding! */
-
-
-/*
- * unexec.c - Convert a running program into an a.out file.
- *
- * Author: Spencer W. Thomas
- * Computer Science Dept.
- * University of Utah
- * Date: Tue Mar 2 1982
- * Modified heavily since then.
- *
- * Synopsis:
- * unexec (new_name, a_name, data_start, bss_start, entry_address)
- * char *new_name, *a_name;
- * unsigned data_start, bss_start, entry_address;
- *
- * Takes a snapshot of the program and makes an a.out format file in the
- * file named by the string argument new_name.
- * If a_name is non-NULL, the symbol table will be taken from the given file.
- * On some machines, an existing a_name file is required.
- *
- * The boundaries within the a.out file may be adjusted with the data_start
- * and bss_start arguments. Either or both may be given as 0 for defaults.
- *
- * Data_start gives the boundary between the text segment and the data
- * segment of the program. The text segment can contain shared, read-only
- * program code and literal data, while the data segment is always unshared
- * and unprotected. Data_start gives the lowest unprotected address.
- * The value you specify may be rounded down to a suitable boundary
- * as required by the machine you are using.
- *
- * Specifying zero for data_start means the boundary between text and data
- * should not be the same as when the program was loaded.
- * If NO_REMAP is defined, the argument data_start is ignored and the
- * segment boundaries are never changed.
- *
- * Bss_start indicates how much of the data segment is to be saved in the
- * a.out file and restored when the program is executed. It gives the lowest
- * unsaved address, and is rounded up to a page boundary. The default when 0
- * is given assumes that the entire data segment is to be stored, including
- * the previous data and bss as well as any additional storage allocated with
- * break (2).
- *
- * The new file is set up to start at entry_address.
- *
- * If you make improvements I'd like to get them too.
- * harpo!utah-cs!thomas, thomas@Utah-20
- *
- */
-
-/* Even more heavily modified by james@bigtex.cactus.org of Dell Computer Co.
- * ELF support added.
- *
- * Basic theory: the data space of the running process needs to be
- * dumped to the output file. Normally we would just enlarge the size
- * of .data, scooting everything down. But we can't do that in ELF,
- * because there is often something between the .data space and the
- * .bss space.
- *
- * In the temacs dump below, notice that the Global Offset Table
- * (.got) and the Dynamic link data (.dynamic) come between .data1 and
- * .bss. It does not work to overlap .data with these fields.
- *
- * The solution is to create a new .data segment. This segment is
- * filled with data from the current process. Since the contents of
- * various sections refer to sections by index, the new .data segment
- * is made the last in the table to avoid changing any existing index.
-
- * This is an example of how the section headers are changed. "Addr"
- * is a process virtual address. "Offset" is a file offset.
-
-raid:/nfs/raid/src/dist-18.56/src> dump -h temacs
-
-temacs:
-
- **** SECTION HEADER TABLE ****
-[No] Type Flags Addr Offset Size Name
- Link Info Adralgn Entsize
-
-[1] 1 2 0x80480d4 0xd4 0x13 .interp
- 0 0 0x1 0
-
-[2] 5 2 0x80480e8 0xe8 0x388 .hash
- 3 0 0x4 0x4
-
-[3] 11 2 0x8048470 0x470 0x7f0 .dynsym
- 4 1 0x4 0x10
-
-[4] 3 2 0x8048c60 0xc60 0x3ad .dynstr
- 0 0 0x1 0
-
-[5] 9 2 0x8049010 0x1010 0x338 .rel.plt
- 3 7 0x4 0x8
-
-[6] 1 6 0x8049348 0x1348 0x3 .init
- 0 0 0x4 0
-
-[7] 1 6 0x804934c 0x134c 0x680 .plt
- 0 0 0x4 0x4
-
-[8] 1 6 0x80499cc 0x19cc 0x3c56f .text
- 0 0 0x4 0
-
-[9] 1 6 0x8085f3c 0x3df3c 0x3 .fini
- 0 0 0x4 0
-
-[10] 1 2 0x8085f40 0x3df40 0x69c .rodata
- 0 0 0x4 0
-
-[11] 1 2 0x80865dc 0x3e5dc 0xd51 .rodata1
- 0 0 0x4 0
-
-[12] 1 3 0x8088330 0x3f330 0x20afc .data
- 0 0 0x4 0
-
-[13] 1 3 0x80a8e2c 0x5fe2c 0x89d .data1
- 0 0 0x4 0
-
-[14] 1 3 0x80a96cc 0x606cc 0x1a8 .got
- 0 0 0x4 0x4
-
-[15] 6 3 0x80a9874 0x60874 0x80 .dynamic
- 4 0 0x4 0x8
-
-[16] 8 3 0x80a98f4 0x608f4 0x449c .bss
- 0 0 0x4 0
-
-[17] 2 0 0 0x608f4 0x9b90 .symtab
- 18 371 0x4 0x10
-
-[18] 3 0 0 0x6a484 0x8526 .strtab
- 0 0 0x1 0
-
-[19] 3 0 0 0x729aa 0x93 .shstrtab
- 0 0 0x1 0
-
-[20] 1 0 0 0x72a3d 0x68b7 .comment
- 0 0 0x1 0
-
-raid:/nfs/raid/src/dist-18.56/src> dump -h xemacs
-
-xemacs:
-
- **** SECTION HEADER TABLE ****
-[No] Type Flags Addr Offset Size Name
- Link Info Adralgn Entsize
-
-[1] 1 2 0x80480d4 0xd4 0x13 .interp
- 0 0 0x1 0
-
-[2] 5 2 0x80480e8 0xe8 0x388 .hash
- 3 0 0x4 0x4
-
-[3] 11 2 0x8048470 0x470 0x7f0 .dynsym
- 4 1 0x4 0x10
-
-[4] 3 2 0x8048c60 0xc60 0x3ad .dynstr
- 0 0 0x1 0
-
-[5] 9 2 0x8049010 0x1010 0x338 .rel.plt
- 3 7 0x4 0x8
-
-[6] 1 6 0x8049348 0x1348 0x3 .init
- 0 0 0x4 0
-
-[7] 1 6 0x804934c 0x134c 0x680 .plt
- 0 0 0x4 0x4
-
-[8] 1 6 0x80499cc 0x19cc 0x3c56f .text
- 0 0 0x4 0
-
-[9] 1 6 0x8085f3c 0x3df3c 0x3 .fini
- 0 0 0x4 0
-
-[10] 1 2 0x8085f40 0x3df40 0x69c .rodata
- 0 0 0x4 0
-
-[11] 1 2 0x80865dc 0x3e5dc 0xd51 .rodata1
- 0 0 0x4 0
-
-[12] 1 3 0x8088330 0x3f330 0x20afc .data
- 0 0 0x4 0
-
-[13] 1 3 0x80a8e2c 0x5fe2c 0x89d .data1
- 0 0 0x4 0
-
-[14] 1 3 0x80a96cc 0x606cc 0x1a8 .got
- 0 0 0x4 0x4
-
-[15] 6 3 0x80a9874 0x60874 0x80 .dynamic
- 4 0 0x4 0x8
-
-[16] 8 3 0x80c6800 0x7d800 0 .bss
- 0 0 0x4 0
-
-[17] 2 0 0 0x7d800 0x9b90 .symtab
- 18 371 0x4 0x10
-
-[18] 3 0 0 0x87390 0x8526 .strtab
- 0 0 0x1 0
-
-[19] 3 0 0 0x8f8b6 0x93 .shstrtab
- 0 0 0x1 0
-
-[20] 1 0 0 0x8f949 0x68b7 .comment
- 0 0 0x1 0
-
-[21] 1 3 0x80a98f4 0x608f4 0x1cf0c .data
- 0 0 0x4 0
-
- * This is an example of how the file header is changed. "Shoff" is
- * the section header offset within the file. Since that table is
- * after the new .data section, it is moved. "Shnum" is the number of
- * sections, which we increment.
- *
- * "Phoff" is the file offset to the program header. "Phentsize" and
- * "Shentsz" are the program and section header entries sizes respectively.
- * These can be larger than the apparent struct sizes.
-
-raid:/nfs/raid/src/dist-18.56/src> dump -f temacs
-
-temacs:
-
- **** ELF HEADER ****
-Class Data Type Machine Version
-Entry Phoff Shoff Flags Ehsize
-Phentsize Phnum Shentsz Shnum Shstrndx
-
-1 1 2 3 1
-0x80499cc 0x34 0x792f4 0 0x34
-0x20 5 0x28 21 19
-
-raid:/nfs/raid/src/dist-18.56/src> dump -f xemacs
-
-xemacs:
-
- **** ELF HEADER ****
-Class Data Type Machine Version
-Entry Phoff Shoff Flags Ehsize
-Phentsize Phnum Shentsz Shnum Shstrndx
-
-1 1 2 3 1
-0x80499cc 0x34 0x96200 0 0x34
-0x20 5 0x28 22 19
-
- * These are the program headers. "Offset" is the file offset to the
- * segment. "Vaddr" is the memory load address. "Filesz" is the
- * segment size as it appears in the file, and "Memsz" is the size in
- * memory. Below, the third segment is the code and the fourth is the
- * data: the difference between Filesz and Memsz is .bss
-
-raid:/nfs/raid/src/dist-18.56/src> dump -o temacs
-
-temacs:
- ***** PROGRAM EXECUTION HEADER *****
-Type Offset Vaddr Paddr
-Filesz Memsz Flags Align
-
-6 0x34 0x8048034 0
-0xa0 0xa0 5 0
-
-3 0xd4 0 0
-0x13 0 4 0
-
-1 0x34 0x8048034 0
-0x3f2f9 0x3f2f9 5 0x1000
-
-1 0x3f330 0x8088330 0
-0x215c4 0x25a60 7 0x1000
-
-2 0x60874 0x80a9874 0
-0x80 0 7 0
-
-raid:/nfs/raid/src/dist-18.56/src> dump -o xemacs
-
-xemacs:
- ***** PROGRAM EXECUTION HEADER *****
-Type Offset Vaddr Paddr
-Filesz Memsz Flags Align
-
-6 0x34 0x8048034 0
-0xa0 0xa0 5 0
-
-3 0xd4 0 0
-0x13 0 4 0
-
-1 0x34 0x8048034 0
-0x3f2f9 0x3f2f9 5 0x1000
-
-1 0x3f330 0x8088330 0
-0x3e4d0 0x3e4d0 7 0x1000
-
-2 0x60874 0x80a9874 0
-0x80 0 7 0
-
-
- */
-\f
-/* Modified by wtien@urbana.mcd.mot.com of Motorola Inc.
- *
- * The above mechanism does not work if the unexeced ELF file is being
- * re-layout by other applications (such as `strip'). All the applications
- * that re-layout the internal of ELF will layout all sections in ascending
- * order of their file offsets. After the re-layout, the data2 section will
- * still be the LAST section in the section header vector, but its file offset
- * is now being pushed far away down, and causes part of it not to be mapped
- * in (ie. not covered by the load segment entry in PHDR vector), therefore
- * causes the new binary to fail.
- *
- * The solution is to modify the unexec algorithm to insert the new data2
- * section header right before the new bss section header, so their file
- * offsets will be in the ascending order. Since some of the section's (all
- * sections AFTER the bss section) indexes are now changed, we also need to
- * modify some fields to make them point to the right sections. This is done
- * by macro PATCH_INDEX. All the fields that need to be patched are:
- *
- * 1. ELF header e_shstrndx field.
- * 2. section header sh_link and sh_info field.
- * 3. symbol table entry st_shndx field.
- *
- * The above example now should look like:
-
- **** SECTION HEADER TABLE ****
-[No] Type Flags Addr Offset Size Name
- Link Info Adralgn Entsize
-
-[1] 1 2 0x80480d4 0xd4 0x13 .interp
- 0 0 0x1 0
-
-[2] 5 2 0x80480e8 0xe8 0x388 .hash
- 3 0 0x4 0x4
-
-[3] 11 2 0x8048470 0x470 0x7f0 .dynsym
- 4 1 0x4 0x10
-
-[4] 3 2 0x8048c60 0xc60 0x3ad .dynstr
- 0 0 0x1 0
-
-[5] 9 2 0x8049010 0x1010 0x338 .rel.plt
- 3 7 0x4 0x8
-
-[6] 1 6 0x8049348 0x1348 0x3 .init
- 0 0 0x4 0
-
-[7] 1 6 0x804934c 0x134c 0x680 .plt
- 0 0 0x4 0x4
-
-[8] 1 6 0x80499cc 0x19cc 0x3c56f .text
- 0 0 0x4 0
-
-[9] 1 6 0x8085f3c 0x3df3c 0x3 .fini
- 0 0 0x4 0
-
-[10] 1 2 0x8085f40 0x3df40 0x69c .rodata
- 0 0 0x4 0
-
-[11] 1 2 0x80865dc 0x3e5dc 0xd51 .rodata1
- 0 0 0x4 0
-
-[12] 1 3 0x8088330 0x3f330 0x20afc .data
- 0 0 0x4 0
-
-[13] 1 3 0x80a8e2c 0x5fe2c 0x89d .data1
- 0 0 0x4 0
-
-[14] 1 3 0x80a96cc 0x606cc 0x1a8 .got
- 0 0 0x4 0x4
-
-[15] 6 3 0x80a9874 0x60874 0x80 .dynamic
- 4 0 0x4 0x8
-
-[16] 1 3 0x80a98f4 0x608f4 0x1cf0c .data
- 0 0 0x4 0
-
-[17] 8 3 0x80c6800 0x7d800 0 .bss
- 0 0 0x4 0
-
-[18] 2 0 0 0x7d800 0x9b90 .symtab
- 19 371 0x4 0x10
-
-[19] 3 0 0 0x87390 0x8526 .strtab
- 0 0 0x1 0
-
-[20] 3 0 0 0x8f8b6 0x93 .shstrtab
- 0 0 0x1 0
-
-[21] 1 0 0 0x8f949 0x68b7 .comment
- 0 0 0x1 0
-
- */
-\f
-#include <sys/types.h>
-#include <stdio.h>
-#include <sys/stat.h>
-#include <memory.h>
-#include <string.h>
-#include <errno.h>
-#include <unistd.h>
-#include <fcntl.h>
-#include <elf.h>
-#include <sys/mman.h>
-
-#ifdef __alpha__
-# include <sym.h> /* get COFF debugging symbol table declaration */
-#endif
-
-#if __GNU_LIBRARY__ - 0 >= 6
-# include <link.h> /* get ElfW etc */
-#endif
-
-#ifndef ElfW
-# ifdef __STDC__
-# define ElfW(type) Elf32_##type
-# else
-# define ElfW(type) Elf32_/**/type
-# endif
-#endif
-
-#ifndef emacs
-#define fatal(a, b, c) fprintf (stderr, a, b, c), exit (1)
-#else
-#include <config.h>
-extern void fatal (char *, ...);
-#endif
-
-#ifndef ELF_BSS_SECTION_NAME
-#define ELF_BSS_SECTION_NAME ".bss"
-#endif
-
-/* Get the address of a particular section or program header entry,
- * accounting for the size of the entries.
- */
-/*
- On PPC Reference Platform running Solaris 2.5.1
- the plt section is also of type NOBI like the bss section.
- (not really stored) and therefore sections after the bss
- section start at the plt offset. The plt section is always
- the one just before the bss section.
- Thus, we modify the test from
- if (NEW_SECTION_H (nn).sh_offset >= new_data2_offset)
- to
- if (NEW_SECTION_H (nn).sh_offset >=
- OLD_SECTION_H (old_bss_index-1).sh_offset)
- This is just a hack. We should put the new data section
- before the .plt section.
- And we should not have this routine at all but use
- the libelf library to read the old file and create the new
- file.
- The changed code is minimal and depends on prep set in m/prep.h
- Erik Deumens
- Quantum Theory Project
- University of Florida
- deumens@qtp.ufl.edu
- Apr 23, 1996
- */
-
-#define OLD_SECTION_H(n) \
- (*(ElfW(Shdr) *) ((byte *) old_section_h + old_file_h->e_shentsize * (n)))
-#define NEW_SECTION_H(n) \
- (*(ElfW(Shdr) *) ((byte *) new_section_h + new_file_h->e_shentsize * (n)))
-#define OLD_PROGRAM_H(n) \
- (*(ElfW(Phdr) *) ((byte *) old_program_h + old_file_h->e_phentsize * (n)))
-#define NEW_PROGRAM_H(n) \
- (*(ElfW(Phdr) *) ((byte *) new_program_h + new_file_h->e_phentsize * (n)))
-
-#define PATCH_INDEX(n) \
- do { \
- if ((int) (n) >= old_bss_index) \
- (n)++; } while (0)
-typedef unsigned char byte;
-
-/* Round X up to a multiple of Y. */
-
-int
-round_up (x, y)
- int x, y;
-{
- int rem = x % y;
- if (rem == 0)
- return x;
- return x - rem + y;
-}
-
-/* ****************************************************************
- * unexec
- *
- * driving logic.
- *
- * In ELF, this works by replacing the old .bss section with a new
- * .data section, and inserting an empty .bss immediately afterwards.
- *
- */
-void
-unexec (new_name, old_name, data_start, bss_start, entry_address)
- char *new_name, *old_name;
- unsigned data_start, bss_start, entry_address;
-{
- int new_file, old_file, new_file_size;
-
- /* Pointers to the base of the image of the two files. */
- caddr_t old_base, new_base;
-
- /* Pointers to the file, program and section headers for the old and new
- * files.
- */
- ElfW(Ehdr) *old_file_h, *new_file_h;
- ElfW(Phdr) *old_program_h, *new_program_h;
- ElfW(Shdr) *old_section_h, *new_section_h;
-
- /* Point to the section name table in the old file */
- char *old_section_names;
-
- ElfW(Addr) old_bss_addr, new_bss_addr;
- ElfW(Word) old_bss_size, new_data2_size;
- ElfW(Off) new_data2_offset;
- ElfW(Addr) new_data2_addr;
-
- int n, nn, old_bss_index, old_data_index, new_data2_index;
- struct stat stat_buf;
-
- /* Open the old file & map it into the address space. */
-
- old_file = open (old_name, O_RDONLY);
-
- if (old_file < 0)
- fatal ("Can't open %s for reading: errno %d\n", old_name, errno);
-
- if (fstat (old_file, &stat_buf) == -1)
- fatal ("Can't fstat (%s): errno %d\n", old_name, errno);
-
- old_base = mmap (0, stat_buf.st_size, PROT_READ, MAP_SHARED, old_file, 0);
-
- if (old_base == (caddr_t) -1)
- fatal ("Can't mmap (%s): errno %d\n", old_name, errno);
-
-#ifdef DEBUG
- fprintf (stderr, "mmap (%s, %x) -> %x\n", old_name, stat_buf.st_size,
- old_base);
-#endif
-
- /* Get pointers to headers & section names */
-
- old_file_h = (ElfW(Ehdr) *) old_base;
- old_program_h = (ElfW(Phdr) *) ((byte *) old_base + old_file_h->e_phoff);
- old_section_h = (ElfW(Shdr) *) ((byte *) old_base + old_file_h->e_shoff);
- old_section_names = (char *) old_base
- + OLD_SECTION_H (old_file_h->e_shstrndx).sh_offset;
-
- /* Find the old .bss section. Figure out parameters of the new
- * data2 and bss sections.
- */
-
- for (old_bss_index = 1; old_bss_index < (int) old_file_h->e_shnum;
- old_bss_index++)
- {
-#ifdef DEBUG
- fprintf (stderr, "Looking for .bss - found %s\n",
- old_section_names + OLD_SECTION_H (old_bss_index).sh_name);
-#endif
- if (!strcmp (old_section_names + OLD_SECTION_H (old_bss_index).sh_name,
- ELF_BSS_SECTION_NAME))
- break;
- }
- if (old_bss_index == old_file_h->e_shnum)
- fatal ("Can't find .bss in %s.\n", old_name, 0);
-
- old_bss_addr = OLD_SECTION_H (old_bss_index).sh_addr;
- old_bss_size = OLD_SECTION_H (old_bss_index).sh_size;
-#if defined(emacs) || !defined(DEBUG)
- new_bss_addr = (ElfW(Addr)) sbrk (0);
-#else
- new_bss_addr = old_bss_addr + old_bss_size + 0x1234;
-#endif
- new_data2_addr = old_bss_addr;
- new_data2_size = new_bss_addr - old_bss_addr;
- new_data2_offset = OLD_SECTION_H (old_bss_index).sh_offset;
-
-#ifdef DEBUG
- fprintf (stderr, "old_bss_index %d\n", old_bss_index);
- fprintf (stderr, "old_bss_addr %x\n", old_bss_addr);
- fprintf (stderr, "old_bss_size %x\n", old_bss_size);
- fprintf (stderr, "new_bss_addr %x\n", new_bss_addr);
- fprintf (stderr, "new_data2_addr %x\n", new_data2_addr);
- fprintf (stderr, "new_data2_size %x\n", new_data2_size);
- fprintf (stderr, "new_data2_offset %x\n", new_data2_offset);
-#endif
-
- if ((unsigned) new_bss_addr < (unsigned) old_bss_addr + old_bss_size)
- fatal (".bss shrank when undumping???\n", 0, 0);
-
- /* Set the output file to the right size and mmap it. Set
- * pointers to various interesting objects. stat_buf still has
- * old_file data.
- */
-
- new_file = open (new_name, O_RDWR | O_CREAT, 0666);
- if (new_file < 0)
- fatal ("Can't creat (%s): errno %d\n", new_name, errno);
-
- new_file_size = stat_buf.st_size + old_file_h->e_shentsize + new_data2_size;
-
- if (ftruncate (new_file, new_file_size))
- fatal ("Can't ftruncate (%s): errno %d\n", new_name, errno);
-
-#ifdef UNEXEC_USE_MAP_PRIVATE
- new_base = mmap (0, new_file_size, PROT_READ | PROT_WRITE, MAP_PRIVATE,
- new_file, 0);
-#else
- new_base = mmap (0, new_file_size, PROT_READ | PROT_WRITE, MAP_SHARED,
- new_file, 0);
-#endif
-
- if (new_base == (caddr_t) -1)
- fatal ("Can't mmap (%s): errno %d\n", new_name, errno);
-
- new_file_h = (ElfW(Ehdr) *) new_base;
- new_program_h = (ElfW(Phdr) *) ((byte *) new_base + old_file_h->e_phoff);
- new_section_h = (ElfW(Shdr) *)
- ((byte *) new_base + old_file_h->e_shoff + new_data2_size);
-
- /* Make our new file, program and section headers as copies of the
- * originals.
- */
-
- memcpy (new_file_h, old_file_h, old_file_h->e_ehsize);
- memcpy (new_program_h, old_program_h,
- old_file_h->e_phnum * old_file_h->e_phentsize);
-
- /* Modify the e_shstrndx if necessary. */
- PATCH_INDEX (new_file_h->e_shstrndx);
-
- /* Fix up file header. We'll add one section. Section header is
- * further away now.
- */
-
- new_file_h->e_shoff += new_data2_size;
- new_file_h->e_shnum += 1;
-
-#ifdef DEBUG
- fprintf (stderr, "Old section offset %x\n", old_file_h->e_shoff);
- fprintf (stderr, "Old section count %d\n", old_file_h->e_shnum);
- fprintf (stderr, "New section offset %x\n", new_file_h->e_shoff);
- fprintf (stderr, "New section count %d\n", new_file_h->e_shnum);
-#endif
-
- /* Fix up a new program header. Extend the writable data segment so
- * that the bss area is covered too. Find that segment by looking
- * for a segment that ends just before the .bss area. Make sure
- * that no segments are above the new .data2. Put a loop at the end
- * to adjust the offset and address of any segment that is above
- * data2, just in case we decide to allow this later.
- */
-
- for (n = new_file_h->e_phnum - 1; n >= 0; n--)
- {
- /* Compute maximum of all requirements for alignment of section. */
- int alignment = (NEW_PROGRAM_H (n)).p_align;
- if ((OLD_SECTION_H (old_bss_index)).sh_addralign > alignment)
- alignment = OLD_SECTION_H (old_bss_index).sh_addralign;
-
- if (NEW_PROGRAM_H (n).p_vaddr + NEW_PROGRAM_H (n).p_filesz > old_bss_addr)
- fatal ("Program segment above .bss in %s\n", old_name, 0);
-
- if (NEW_PROGRAM_H (n).p_type == PT_LOAD
- && (round_up ((NEW_PROGRAM_H (n)).p_vaddr
- + (NEW_PROGRAM_H (n)).p_filesz,
- alignment)
- == round_up (old_bss_addr, alignment)))
- break;
- }
- if (n < 0)
- fatal ("Couldn't find segment next to .bss in %s\n", old_name, 0);
-
- NEW_PROGRAM_H (n).p_filesz += new_data2_size;
- NEW_PROGRAM_H (n).p_memsz = NEW_PROGRAM_H (n).p_filesz;
-
-#if 0 /* Maybe allow section after data2 - does this ever happen? */
- for (n = new_file_h->e_phnum - 1; n >= 0; n--)
- {
- if (NEW_PROGRAM_H (n).p_vaddr
- && NEW_PROGRAM_H (n).p_vaddr >= new_data2_addr)
- NEW_PROGRAM_H (n).p_vaddr += new_data2_size - old_bss_size;
-
- if (NEW_PROGRAM_H (n).p_offset >= new_data2_offset)
- NEW_PROGRAM_H (n).p_offset += new_data2_size;
- }
-#endif
-
- /* Fix up section headers based on new .data2 section. Any section
- * whose offset or virtual address is after the new .data2 section
- * gets its value adjusted. .bss size becomes zero and new address
- * is set. data2 section header gets added by copying the existing
- * .data header and modifying the offset, address and size.
- */
- for (old_data_index = 1; old_data_index < (int) old_file_h->e_shnum;
- old_data_index++)
- if (!strcmp (old_section_names + OLD_SECTION_H (old_data_index).sh_name,
- ".data"))
- break;
- if (old_data_index == old_file_h->e_shnum)
- fatal ("Can't find .data in %s.\n", old_name, 0);
-
- /* Walk through all section headers, insert the new data2 section right
- before the new bss section. */
- for (n = 1, nn = 1; n < (int) old_file_h->e_shnum; n++, nn++)
- {
- caddr_t src;
- /* If it is bss section, insert the new data2 section before it. */
- if (n == old_bss_index)
- {
- /* Steal the data section header for this data2 section. */
- memcpy (&NEW_SECTION_H (nn), &OLD_SECTION_H (old_data_index),
- new_file_h->e_shentsize);
-
- NEW_SECTION_H (nn).sh_addr = new_data2_addr;
- NEW_SECTION_H (nn).sh_offset = new_data2_offset;
- NEW_SECTION_H (nn).sh_size = new_data2_size;
- /* Use the bss section's alignment. This will assure that the
- new data2 section always be placed in the same spot as the old
- bss section by any other application. */
- NEW_SECTION_H (nn).sh_addralign = OLD_SECTION_H (n).sh_addralign;
-
- /* Now copy over what we have in the memory now. */
- memcpy (NEW_SECTION_H (nn).sh_offset + new_base,
- (caddr_t) OLD_SECTION_H (n).sh_addr,
- new_data2_size);
- nn++;
- }
-
- memcpy (&NEW_SECTION_H (nn), &OLD_SECTION_H (n),
- old_file_h->e_shentsize);
-
- /* The new bss section's size is zero, and its file offset and virtual
- address should be off by NEW_DATA2_SIZE. */
- if (n == old_bss_index)
- {
- /* NN should be `old_bss_index + 1' at this point. */
- NEW_SECTION_H (nn).sh_offset += new_data2_size;
- NEW_SECTION_H (nn).sh_addr += new_data2_size;
- /* Let the new bss section address alignment be the same as the
- section address alignment followed the old bss section, so
- this section will be placed in exactly the same place. */
- NEW_SECTION_H (nn).sh_addralign = OLD_SECTION_H (nn).sh_addralign;
- NEW_SECTION_H (nn).sh_size = 0;
- }
- else
- {
- /* Any section that was original placed AFTER the bss
- section should now be off by NEW_DATA2_SIZE. */
-#ifdef SOLARIS_POWERPC
- /* On PPC Reference Platform running Solaris 2.5.1
- the plt section is also of type NOBI like the bss section.
- (not really stored) and therefore sections after the bss
- section start at the plt offset. The plt section is always
- the one just before the bss section.
- It would be better to put the new data section before
- the .plt section, or use libelf instead.
- Erik Deumens, deumens@qtp.ufl.edu. */
- if (NEW_SECTION_H (nn).sh_offset
- >= OLD_SECTION_H (old_bss_index-1).sh_offset)
- NEW_SECTION_H (nn).sh_offset += new_data2_size;
-#else
- if (round_up (NEW_SECTION_H (nn).sh_offset,
- OLD_SECTION_H (old_bss_index).sh_addralign)
- >= new_data2_offset)
- NEW_SECTION_H (nn).sh_offset += new_data2_size;
-#endif
- /* Any section that was originally placed after the section
- header table should now be off by the size of one section
- header table entry. */
- if (NEW_SECTION_H (nn).sh_offset > new_file_h->e_shoff)
- NEW_SECTION_H (nn).sh_offset += new_file_h->e_shentsize;
- }
-
- /* If any section hdr refers to the section after the new .data
- section, make it refer to next one because we have inserted
- a new section in between. */
-
- PATCH_INDEX (NEW_SECTION_H (nn).sh_link);
- /* For symbol tables, info is a symbol table index,
- so don't change it. */
- if (NEW_SECTION_H (nn).sh_type != SHT_SYMTAB
- && NEW_SECTION_H (nn).sh_type != SHT_DYNSYM)
- PATCH_INDEX (NEW_SECTION_H (nn).sh_info);
-
- /* Now, start to copy the content of sections. */
- if (NEW_SECTION_H (nn).sh_type == SHT_NULL
- || NEW_SECTION_H (nn).sh_type == SHT_NOBITS)
- continue;
-
- /* Write out the sections. .data and .data1 (and data2, called
- ".data" in the strings table) get copied from the current process
- instead of the old file. */
- if (!strcmp (old_section_names + NEW_SECTION_H (n).sh_name, ".data")
- || !strcmp ((old_section_names + NEW_SECTION_H (n).sh_name),
- ".data1"))
- src = (caddr_t) OLD_SECTION_H (n).sh_addr;
- else
- src = old_base + OLD_SECTION_H (n).sh_offset;
-
- memcpy (NEW_SECTION_H (nn).sh_offset + new_base, src,
- NEW_SECTION_H (nn).sh_size);
-
-#ifdef __alpha__
- /* Update Alpha COFF symbol table: */
- if (strcmp (old_section_names + OLD_SECTION_H (n).sh_name, ".mdebug")
- == 0)
- {
- pHDRR symhdr = (pHDRR) (NEW_SECTION_H (nn).sh_offset + new_base);
-
- symhdr->cbLineOffset += new_data2_size;
- symhdr->cbDnOffset += new_data2_size;
- symhdr->cbPdOffset += new_data2_size;
- symhdr->cbSymOffset += new_data2_size;
- symhdr->cbOptOffset += new_data2_size;
- symhdr->cbAuxOffset += new_data2_size;
- symhdr->cbSsOffset += new_data2_size;
- symhdr->cbSsExtOffset += new_data2_size;
- symhdr->cbFdOffset += new_data2_size;
- symhdr->cbRfdOffset += new_data2_size;
- symhdr->cbExtOffset += new_data2_size;
- }
-#endif /* __alpha__ */
-
- /* If it is the symbol table, its st_shndx field needs to be patched. */
- if (NEW_SECTION_H (nn).sh_type == SHT_SYMTAB
- || NEW_SECTION_H (nn).sh_type == SHT_DYNSYM)
- {
- ElfW(Shdr) *spt = &NEW_SECTION_H (nn);
- unsigned int num = spt->sh_size / spt->sh_entsize;
- ElfW(Sym) * sym = (ElfW(Sym) *) (NEW_SECTION_H (nn).sh_offset +
- new_base);
- for (; num--; sym++)
- {
- if ((sym->st_shndx == SHN_UNDEF)
- || (sym->st_shndx == SHN_ABS)
- || (sym->st_shndx == SHN_COMMON))
- continue;
-
- PATCH_INDEX (sym->st_shndx);
- }
- }
- }
-
- /* Update the symbol values of _edata and _end. */
- for (n = new_file_h->e_shnum - 1; n; n--)
- {
- byte *symnames;
- ElfW(Sym) *symp, *symendp;
-
- if (NEW_SECTION_H (n).sh_type != SHT_DYNSYM
- && NEW_SECTION_H (n).sh_type != SHT_SYMTAB)
- continue;
-
- symnames = ((byte *) new_base
- + NEW_SECTION_H (NEW_SECTION_H (n).sh_link).sh_offset);
- symp = (ElfW(Sym) *) (NEW_SECTION_H (n).sh_offset + new_base);
- symendp = (ElfW(Sym) *) ((byte *)symp + NEW_SECTION_H (n).sh_size);
-
- for (; symp < symendp; symp ++)
- if (strcmp ((char *) (symnames + symp->st_name), "_end") == 0
- || strcmp ((char *) (symnames + symp->st_name), "_edata") == 0)
- memcpy (&symp->st_value, &new_bss_addr, sizeof (new_bss_addr));
- }
-
- /* This loop seeks out relocation sections for the data section, so
- that it can undo relocations performed by the runtime linker. */
- for (n = new_file_h->e_shnum - 1; n; n--)
- {
- ElfW(Shdr) section = NEW_SECTION_H (n);
- switch (section.sh_type) {
- default:
- break;
- case SHT_REL:
- case SHT_RELA:
- /* This code handles two different size structs, but there should
- be no harm in that provided that r_offset is always the first
- member. */
- nn = section.sh_info;
- if (!strcmp (old_section_names + NEW_SECTION_H (nn).sh_name, ".data")
- || !strcmp ((old_section_names + NEW_SECTION_H (nn).sh_name),
- ".data1"))
- {
- ElfW(Addr) offset = NEW_SECTION_H (nn).sh_addr -
- NEW_SECTION_H (nn).sh_offset;
- caddr_t reloc = old_base + section.sh_offset, end;
- for (end = reloc + section.sh_size; reloc < end;
- reloc += section.sh_entsize)
- {
- ElfW(Addr) addr = ((ElfW(Rel) *) reloc)->r_offset - offset;
-#ifdef __alpha__
- /* The Alpha ELF binutils currently have a bug that
- sometimes results in relocs that contain all
- zeroes. Work around this for now... */
- if (((ElfW(Rel) *) reloc)->r_offset == 0)
- continue;
-#endif
- memcpy (new_base + addr, old_base + addr, sizeof(ElfW(Addr)));
- }
- }
- break;
- }
- }
-
-#ifdef UNEXEC_USE_MAP_PRIVATE
- if (lseek (new_file, 0, SEEK_SET) == -1)
- fatal ("Can't rewind (%s): errno %d\n", new_name, errno);
-
- if (write (new_file, new_base, new_file_size) != new_file_size)
- fatal ("Can't write (%s): errno %d\n", new_name, errno);
-#endif
-
- /* Close the files and make the new file executable. */
-
- if (close (old_file))
- fatal ("Can't close (%s): errno %d\n", old_name, errno);
-
- if (close (new_file))
- fatal ("Can't close (%s): errno %d\n", new_name, errno);
-
- if (stat (new_name, &stat_buf) == -1)
- fatal ("Can't stat (%s): errno %d\n", new_name, errno);
-
- n = umask (777);
- umask (n);
- stat_buf.st_mode |= 0111 & ~n;
- if (chmod (new_name, stat_buf.st_mode) == -1)
- fatal ("Can't chmod (%s): errno %d\n", new_name, errno);
-}
+++ /dev/null
-/* 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 2, or (at your option)
-any later version.
-
-GNU Emacs is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Emacs; see the file COPYING. If not, write to
-the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-Boston, MA 02111-1307, USA.
-
-In other words, you are welcome to use, share and improve this program.
-You are forbidden to forbid anyone else to use, share and improve
-what you give them. Help stamp out software-hoarding! */
-
-
-/*
- * unexec.c - Convert a running program into an a.out file.
- *
- * Author: Spencer W. Thomas
- * Computer Science Dept.
- * University of Utah
- * Date: Tue Mar 2 1982
- * Modified heavily since then.
- *
- * Synopsis:
- * unexec (new_name, a_name, data_start, bss_start, entry_address)
- * char *new_name, *a_name;
- * unsigned data_start, bss_start, entry_address;
- *
- * Takes a snapshot of the program and makes an a.out format file in the
- * file named by the string argument new_name.
- * If a_name is non-NULL, the symbol table will be taken from the given file.
- * On some machines, an existing a_name file is required.
- *
- * The boundaries within the a.out file may be adjusted with the data_start
- * and bss_start arguments. Either or both may be given as 0 for defaults.
- *
- * Data_start gives the boundary between the text segment and the data
- * segment of the program. The text segment can contain shared, read-only
- * program code and literal data, while the data segment is always unshared
- * and unprotected. Data_start gives the lowest unprotected address.
- * The value you specify may be rounded down to a suitable boundary
- * as required by the machine you are using.
- *
- * Specifying zero for data_start means the boundary between text and data
- * should not be the same as when the program was loaded.
- * If NO_REMAP is defined, the argument data_start is ignored and the
- * segment boundaries are never changed.
- *
- * Bss_start indicates how much of the data segment is to be saved in the
- * a.out file and restored when the program is executed. It gives the lowest
- * unsaved address, and is rounded up to a page boundary. The default when 0
- * is given assumes that the entire data segment is to be stored, including
- * the previous data and bss as well as any additional storage allocated with
- * break (2).
- *
- * The new file is set up to start at entry_address.
- *
- * If you make improvements I'd like to get them too.
- * harpo!utah-cs!thomas, thomas@Utah-20
- *
- */
-
-/* Even more heavily modified by james@bigtex.cactus.org of Dell Computer Co.
- * ELF support added.
- *
- * Basic theory: the data space of the running process needs to be
- * dumped to the output file. Normally we would just enlarge the size
- * of .data, scooting everything down. But we can't do that in ELF,
- * because there is often something between the .data space and the
- * .bss space.
- *
- * In the temacs dump below, notice that the Global Offset Table
- * (.got) and the Dynamic link data (.dynamic) come between .data1 and
- * .bss. It does not work to overlap .data with these fields.
- *
- * The solution is to create a new .data segment. This segment is
- * filled with data from the current process. Since the contents of
- * various sections refer to sections by index, the new .data segment
- * is made the last in the table to avoid changing any existing index.
-
- * This is an example of how the section headers are changed. "Addr"
- * is a process virtual address. "Offset" is a file offset.
-
-raid:/nfs/raid/src/dist-18.56/src> dump -h temacs
-
-temacs:
-
- **** SECTION HEADER TABLE ****
-[No] Type Flags Addr Offset Size Name
- Link Info Adralgn Entsize
-
-[1] 1 2 0x80480d4 0xd4 0x13 .interp
- 0 0 0x1 0
-
-[2] 5 2 0x80480e8 0xe8 0x388 .hash
- 3 0 0x4 0x4
-
-[3] 11 2 0x8048470 0x470 0x7f0 .dynsym
- 4 1 0x4 0x10
-
-[4] 3 2 0x8048c60 0xc60 0x3ad .dynstr
- 0 0 0x1 0
-
-[5] 9 2 0x8049010 0x1010 0x338 .rel.plt
- 3 7 0x4 0x8
-
-[6] 1 6 0x8049348 0x1348 0x3 .init
- 0 0 0x4 0
-
-[7] 1 6 0x804934c 0x134c 0x680 .plt
- 0 0 0x4 0x4
-
-[8] 1 6 0x80499cc 0x19cc 0x3c56f .text
- 0 0 0x4 0
-
-[9] 1 6 0x8085f3c 0x3df3c 0x3 .fini
- 0 0 0x4 0
-
-[10] 1 2 0x8085f40 0x3df40 0x69c .rodata
- 0 0 0x4 0
-
-[11] 1 2 0x80865dc 0x3e5dc 0xd51 .rodata1
- 0 0 0x4 0
-
-[12] 1 3 0x8088330 0x3f330 0x20afc .data
- 0 0 0x4 0
-
-[13] 1 3 0x80a8e2c 0x5fe2c 0x89d .data1
- 0 0 0x4 0
-
-[14] 1 3 0x80a96cc 0x606cc 0x1a8 .got
- 0 0 0x4 0x4
-
-[15] 6 3 0x80a9874 0x60874 0x80 .dynamic
- 4 0 0x4 0x8
-
-[16] 8 3 0x80a98f4 0x608f4 0x449c .bss
- 0 0 0x4 0
-
-[17] 2 0 0 0x608f4 0x9b90 .symtab
- 18 371 0x4 0x10
-
-[18] 3 0 0 0x6a484 0x8526 .strtab
- 0 0 0x1 0
-
-[19] 3 0 0 0x729aa 0x93 .shstrtab
- 0 0 0x1 0
-
-[20] 1 0 0 0x72a3d 0x68b7 .comment
- 0 0 0x1 0
-
-raid:/nfs/raid/src/dist-18.56/src> dump -h xemacs
-
-xemacs:
-
- **** SECTION HEADER TABLE ****
-[No] Type Flags Addr Offset Size Name
- Link Info Adralgn Entsize
-
-[1] 1 2 0x80480d4 0xd4 0x13 .interp
- 0 0 0x1 0
-
-[2] 5 2 0x80480e8 0xe8 0x388 .hash
- 3 0 0x4 0x4
-
-[3] 11 2 0x8048470 0x470 0x7f0 .dynsym
- 4 1 0x4 0x10
-
-[4] 3 2 0x8048c60 0xc60 0x3ad .dynstr
- 0 0 0x1 0
-
-[5] 9 2 0x8049010 0x1010 0x338 .rel.plt
- 3 7 0x4 0x8
-
-[6] 1 6 0x8049348 0x1348 0x3 .init
- 0 0 0x4 0
-
-[7] 1 6 0x804934c 0x134c 0x680 .plt
- 0 0 0x4 0x4
-
-[8] 1 6 0x80499cc 0x19cc 0x3c56f .text
- 0 0 0x4 0
-
-[9] 1 6 0x8085f3c 0x3df3c 0x3 .fini
- 0 0 0x4 0
-
-[10] 1 2 0x8085f40 0x3df40 0x69c .rodata
- 0 0 0x4 0
-
-[11] 1 2 0x80865dc 0x3e5dc 0xd51 .rodata1
- 0 0 0x4 0
-
-[12] 1 3 0x8088330 0x3f330 0x20afc .data
- 0 0 0x4 0
-
-[13] 1 3 0x80a8e2c 0x5fe2c 0x89d .data1
- 0 0 0x4 0
-
-[14] 1 3 0x80a96cc 0x606cc 0x1a8 .got
- 0 0 0x4 0x4
-
-[15] 6 3 0x80a9874 0x60874 0x80 .dynamic
- 4 0 0x4 0x8
-
-[16] 8 3 0x80c6800 0x7d800 0 .bss
- 0 0 0x4 0
-
-[17] 2 0 0 0x7d800 0x9b90 .symtab
- 18 371 0x4 0x10
-
-[18] 3 0 0 0x87390 0x8526 .strtab
- 0 0 0x1 0
-
-[19] 3 0 0 0x8f8b6 0x93 .shstrtab
- 0 0 0x1 0
-
-[20] 1 0 0 0x8f949 0x68b7 .comment
- 0 0 0x1 0
-
-[21] 1 3 0x80a98f4 0x608f4 0x1cf0c .data
- 0 0 0x4 0
-
- * This is an example of how the file header is changed. "Shoff" is
- * the section header offset within the file. Since that table is
- * after the new .data section, it is moved. "Shnum" is the number of
- * sections, which we increment.
- *
- * "Phoff" is the file offset to the program header. "Phentsize" and
- * "Shentsz" are the program and section header entries sizes respectively.
- * These can be larger than the apparent struct sizes.
-
-raid:/nfs/raid/src/dist-18.56/src> dump -f temacs
-
-temacs:
-
- **** ELF HEADER ****
-Class Data Type Machine Version
-Entry Phoff Shoff Flags Ehsize
-Phentsize Phnum Shentsz Shnum Shstrndx
-
-1 1 2 3 1
-0x80499cc 0x34 0x792f4 0 0x34
-0x20 5 0x28 21 19
-
-raid:/nfs/raid/src/dist-18.56/src> dump -f xemacs
-
-xemacs:
-
- **** ELF HEADER ****
-Class Data Type Machine Version
-Entry Phoff Shoff Flags Ehsize
-Phentsize Phnum Shentsz Shnum Shstrndx
-
-1 1 2 3 1
-0x80499cc 0x34 0x96200 0 0x34
-0x20 5 0x28 22 19
-
- * These are the program headers. "Offset" is the file offset to the
- * segment. "Vaddr" is the memory load address. "Filesz" is the
- * segment size as it appears in the file, and "Memsz" is the size in
- * memory. Below, the third segment is the code and the fourth is the
- * data: the difference between Filesz and Memsz is .bss
-
-raid:/nfs/raid/src/dist-18.56/src> dump -o temacs
-
-temacs:
- ***** PROGRAM EXECUTION HEADER *****
-Type Offset Vaddr Paddr
-Filesz Memsz Flags Align
-
-6 0x34 0x8048034 0
-0xa0 0xa0 5 0
-
-3 0xd4 0 0
-0x13 0 4 0
-
-1 0x34 0x8048034 0
-0x3f2f9 0x3f2f9 5 0x1000
-
-1 0x3f330 0x8088330 0
-0x215c4 0x25a60 7 0x1000
-
-2 0x60874 0x80a9874 0
-0x80 0 7 0
-
-raid:/nfs/raid/src/dist-18.56/src> dump -o xemacs
-
-xemacs:
- ***** PROGRAM EXECUTION HEADER *****
-Type Offset Vaddr Paddr
-Filesz Memsz Flags Align
-
-6 0x34 0x8048034 0
-0xa0 0xa0 5 0
-
-3 0xd4 0 0
-0x13 0 4 0
-
-1 0x34 0x8048034 0
-0x3f2f9 0x3f2f9 5 0x1000
-
-1 0x3f330 0x8088330 0
-0x3e4d0 0x3e4d0 7 0x1000
-
-2 0x60874 0x80a9874 0
-0x80 0 7 0
-
-
- */
-\f
-/* Modified by wtien@urbana.mcd.mot.com of Motorola Inc.
- *
- * The above mechanism does not work if the unexeced ELF file is being
- * re-layout by other applications (such as `strip'). All the applications
- * that re-layout the internal of ELF will layout all sections in ascending
- * order of their file offsets. After the re-layout, the data2 section will
- * still be the LAST section in the section header vector, but its file offset
- * is now being pushed far away down, and causes part of it not to be mapped
- * in (ie. not covered by the load segment entry in PHDR vector), therefore
- * causes the new binary to fail.
- *
- * The solution is to modify the unexec algorithm to insert the new data2
- * section header right before the new bss section header, so their file
- * offsets will be in the ascending order. Since some of the section's (all
- * sections AFTER the bss section) indexes are now changed, we also need to
- * modify some fields to make them point to the right sections. This is done
- * by macro PATCH_INDEX. All the fields that need to be patched are:
- *
- * 1. ELF header e_shstrndx field.
- * 2. section header sh_link and sh_info field.
- * 3. symbol table entry st_shndx field.
- *
- * The above example now should look like:
-
- **** SECTION HEADER TABLE ****
-[No] Type Flags Addr Offset Size Name
- Link Info Adralgn Entsize
-
-[1] 1 2 0x80480d4 0xd4 0x13 .interp
- 0 0 0x1 0
-
-[2] 5 2 0x80480e8 0xe8 0x388 .hash
- 3 0 0x4 0x4
-
-[3] 11 2 0x8048470 0x470 0x7f0 .dynsym
- 4 1 0x4 0x10
-
-[4] 3 2 0x8048c60 0xc60 0x3ad .dynstr
- 0 0 0x1 0
-
-[5] 9 2 0x8049010 0x1010 0x338 .rel.plt
- 3 7 0x4 0x8
-
-[6] 1 6 0x8049348 0x1348 0x3 .init
- 0 0 0x4 0
-
-[7] 1 6 0x804934c 0x134c 0x680 .plt
- 0 0 0x4 0x4
-
-[8] 1 6 0x80499cc 0x19cc 0x3c56f .text
- 0 0 0x4 0
-
-[9] 1 6 0x8085f3c 0x3df3c 0x3 .fini
- 0 0 0x4 0
-
-[10] 1 2 0x8085f40 0x3df40 0x69c .rodata
- 0 0 0x4 0
-
-[11] 1 2 0x80865dc 0x3e5dc 0xd51 .rodata1
- 0 0 0x4 0
-
-[12] 1 3 0x8088330 0x3f330 0x20afc .data
- 0 0 0x4 0
-
-[13] 1 3 0x80a8e2c 0x5fe2c 0x89d .data1
- 0 0 0x4 0
-
-[14] 1 3 0x80a96cc 0x606cc 0x1a8 .got
- 0 0 0x4 0x4
-
-[15] 6 3 0x80a9874 0x60874 0x80 .dynamic
- 4 0 0x4 0x8
-
-[16] 1 3 0x80a98f4 0x608f4 0x1cf0c .data
- 0 0 0x4 0
-
-[17] 8 3 0x80c6800 0x7d800 0 .bss
- 0 0 0x4 0
-
-[18] 2 0 0 0x7d800 0x9b90 .symtab
- 19 371 0x4 0x10
-
-[19] 3 0 0 0x87390 0x8526 .strtab
- 0 0 0x1 0
-
-[20] 3 0 0 0x8f8b6 0x93 .shstrtab
- 0 0 0x1 0
-
-[21] 1 0 0 0x8f949 0x68b7 .comment
- 0 0 0x1 0
-
- */
-\f
-#include <config.h>
-#include <sys/types.h>
-#include <stdio.h>
-#include <sys/stat.h>
-#include <memory.h>
-#include <string.h>
-#include <errno.h>
-#include <unistd.h>
-#include <fcntl.h>
-#include <elf.h>
-#include <syms.h> /* for HDRR declaration */
-#include <sys/mman.h>
-
-#ifndef emacs
-#define fatal(a, b, c) fprintf(stderr, a, b, c), exit(1)
-#else
-extern void fatal(char *, ...);
-#endif
-
-/* Get the address of a particular section or program header entry,
- * accounting for the size of the entries.
- */
-
-#define OLD_SECTION_H(n) \
- (*(Elf32_Shdr *) ((byte *) old_section_h + old_file_h->e_shentsize * (n)))
-#define NEW_SECTION_H(n) \
- (*(Elf32_Shdr *) ((byte *) new_section_h + new_file_h->e_shentsize * (n)))
-#define OLD_PROGRAM_H(n) \
- (*(Elf32_Phdr *) ((byte *) old_program_h + old_file_h->e_phentsize * (n)))
-#define NEW_PROGRAM_H(n) \
- (*(Elf32_Phdr *) ((byte *) new_program_h + new_file_h->e_phentsize * (n)))
-
-#define PATCH_INDEX(n) \
- do { \
- if ((n) >= old_bss_index) \
- (n)++; } while (0)
-typedef unsigned char byte;
-
-/* Round X up to a multiple of Y. */
-
-int
-round_up (x, y)
- int x, y;
-{
- int rem = x % y;
- if (rem == 0)
- return x;
- return x - rem + y;
-}
-
-/* Return the index of the section named NAME.
- SECTION_NAMES, FILE_NAME and FILE_H give information
- about the file we are looking in.
-
- If we don't find the section NAME, that is a fatal error
- if NOERROR is 0; we return -1 if NOERROR is nonzero. */
-
-static int
-find_section (name, section_names, file_name, old_file_h, old_section_h, noerror)
- char *name;
- char *section_names;
- char *file_name;
- Elf32_Ehdr *old_file_h;
- Elf32_Shdr *old_section_h;
- int noerror;
-{
- int idx;
-
- for (idx = 1; idx < old_file_h->e_shnum; idx++)
- {
-#ifdef DEBUG
- fprintf (stderr, "Looking for %s - found %s\n", name,
- section_names + OLD_SECTION_H (idx).sh_name);
-#endif
- if (!strcmp (section_names + OLD_SECTION_H (idx).sh_name,
- name))
- break;
- }
- if (idx == old_file_h->e_shnum)
- {
- if (noerror)
- return -1;
- else
- fatal ("Can't find .bss in %s.\n", file_name, 0);
- }
-
- return idx;
-}
-
-/* ****************************************************************
- * unexec
- *
- * driving logic.
- *
- * In ELF, this works by replacing the old .bss section with a new
- * .data section, and inserting an empty .bss immediately afterwards.
- *
- */
-void
-unexec (new_name, old_name, data_start, bss_start, entry_address)
- char *new_name, *old_name;
- unsigned data_start, bss_start, entry_address;
-{
- extern unsigned int bss_end;
- int new_file, old_file, new_file_size;
-
- /* Pointers to the base of the image of the two files. */
- caddr_t old_base, new_base;
-
- /* Pointers to the file, program and section headers for the old and new
- files. */
- Elf32_Ehdr *old_file_h, *new_file_h;
- Elf32_Phdr *old_program_h, *new_program_h;
- Elf32_Shdr *old_section_h, *new_section_h;
-
- /* Point to the section name table in the old file. */
- char *old_section_names;
-
- Elf32_Addr old_bss_addr, new_bss_addr;
- Elf32_Word old_bss_size, new_data2_size;
- Elf32_Off new_data2_offset;
- Elf32_Addr new_data2_addr;
- Elf32_Addr new_offsets_shift;
-
- int n, nn, old_bss_index, old_data_index, new_data2_index;
- int old_mdebug_index;
- struct stat stat_buf;
-
- /* Open the old file & map it into the address space. */
-
- old_file = open (old_name, O_RDONLY);
-
- if (old_file < 0)
- fatal ("Can't open %s for reading: errno %d\n", old_name, errno);
-
- if (fstat (old_file, &stat_buf) == -1)
- fatal ("Can't fstat(%s): errno %d\n", old_name, errno);
-
- old_base = mmap (0, stat_buf.st_size, PROT_READ, MAP_SHARED, old_file, 0);
-
- if (old_base == (caddr_t) -1)
- fatal ("Can't mmap(%s): errno %d\n", old_name, errno);
-
-#ifdef DEBUG
- fprintf (stderr, "mmap(%s, %x) -> %x\n", old_name, stat_buf.st_size,
- old_base);
-#endif
-
- /* Get pointers to headers & section names. */
-
- old_file_h = (Elf32_Ehdr *) old_base;
- old_program_h = (Elf32_Phdr *) ((byte *) old_base + old_file_h->e_phoff);
- old_section_h = (Elf32_Shdr *) ((byte *) old_base + old_file_h->e_shoff);
- old_section_names
- = (char *) old_base + OLD_SECTION_H (old_file_h->e_shstrndx).sh_offset;
-
- /* Find the mdebug section, if any. */
-
- old_mdebug_index = find_section (".mdebug", old_section_names,
- old_name, old_file_h, old_section_h, 1);
-
- /* Find the old .bss section. */
-
- old_bss_index = find_section (".bss", old_section_names,
- old_name, old_file_h, old_section_h, 0);
-
- /* Find the old .data section. Figure out parameters of
- the new data2 and bss sections. */
-
- old_data_index = find_section (".data", old_section_names,
- old_name, old_file_h, old_section_h, 0);
-
- old_bss_addr = OLD_SECTION_H (old_bss_index).sh_addr;
- old_bss_size = OLD_SECTION_H (old_bss_index).sh_size;
-#if defined(emacs) || !defined(DEBUG)
- bss_end = (unsigned int) sbrk (0);
- new_bss_addr = (Elf32_Addr) bss_end;
-#else
- new_bss_addr = old_bss_addr + old_bss_size + 0x1234;
-#endif
- new_data2_addr = old_bss_addr;
- new_data2_size = new_bss_addr - old_bss_addr;
- new_data2_offset = OLD_SECTION_H (old_data_index).sh_offset +
- (new_data2_addr - OLD_SECTION_H (old_data_index).sh_addr);
- new_offsets_shift = new_bss_addr -
- ((old_bss_addr & ~0xfff) + ((old_bss_addr & 0xfff) ? 0x1000 : 0));
-
-#ifdef DEBUG
- fprintf (stderr, "old_bss_index %d\n", old_bss_index);
- fprintf (stderr, "old_bss_addr %x\n", old_bss_addr);
- fprintf (stderr, "old_bss_size %x\n", old_bss_size);
- fprintf (stderr, "new_bss_addr %x\n", new_bss_addr);
- fprintf (stderr, "new_data2_addr %x\n", new_data2_addr);
- fprintf (stderr, "new_data2_size %x\n", new_data2_size);
- fprintf (stderr, "new_data2_offset %x\n", new_data2_offset);
- fprintf (stderr, "new_offsets_shift %x\n", new_offsets_shift);
-#endif
-
- if ((unsigned) new_bss_addr < (unsigned) old_bss_addr + old_bss_size)
- fatal (".bss shrank when undumping???\n", 0, 0);
-
- /* Set the output file to the right size and mmap it. Set
- pointers to various interesting objects. stat_buf still has
- old_file data. */
-
- new_file = open (new_name, O_RDWR | O_CREAT, 0666);
- if (new_file < 0)
- fatal ("Can't creat (%s): errno %d\n", new_name, errno);
-
- new_file_size = stat_buf.st_size + old_file_h->e_shentsize + new_offsets_shift;
-
- if (ftruncate (new_file, new_file_size))
- fatal ("Can't ftruncate (%s): errno %d\n", new_name, errno);
-
- new_base = mmap (0, new_file_size, PROT_READ | PROT_WRITE, MAP_SHARED,
- new_file, 0);
-
- if (new_base == (caddr_t) -1)
- fatal ("Can't mmap (%s): errno %d\n", new_name, errno);
-
- new_file_h = (Elf32_Ehdr *) new_base;
- new_program_h = (Elf32_Phdr *) ((byte *) new_base + old_file_h->e_phoff);
- new_section_h
- = (Elf32_Shdr *) ((byte *) new_base + old_file_h->e_shoff
- + new_offsets_shift);
-
- /* Make our new file, program and section headers as copies of the
- originals. */
-
- memcpy (new_file_h, old_file_h, old_file_h->e_ehsize);
- memcpy (new_program_h, old_program_h,
- old_file_h->e_phnum * old_file_h->e_phentsize);
-
- /* Modify the e_shstrndx if necessary. */
- PATCH_INDEX (new_file_h->e_shstrndx);
-
- /* Fix up file header. We'll add one section. Section header is
- further away now. */
-
- new_file_h->e_shoff += new_offsets_shift;
- new_file_h->e_shnum += 1;
-
-#ifdef DEBUG
- fprintf (stderr, "Old section offset %x\n", old_file_h->e_shoff);
- fprintf (stderr, "Old section count %d\n", old_file_h->e_shnum);
- fprintf (stderr, "New section offset %x\n", new_file_h->e_shoff);
- fprintf (stderr, "New section count %d\n", new_file_h->e_shnum);
-#endif
-
- /* Fix up a new program header. Extend the writable data segment so
- that the bss area is covered too. Find that segment by looking
- for a segment that ends just before the .bss area. Make sure
- that no segments are above the new .data2. Put a loop at the end
- to adjust the offset and address of any segment that is above
- data2, just in case we decide to allow this later. */
-
- for (n = new_file_h->e_phnum - 1; n >= 0; n--)
- {
- /* Compute maximum of all requirements for alignment of section. */
- int alignment = (NEW_PROGRAM_H (n)).p_align;
- if ((OLD_SECTION_H (old_bss_index)).sh_addralign > alignment)
- alignment = OLD_SECTION_H (old_bss_index).sh_addralign;
-
- /* Supposedly this condition is okay for the SGI. */
-#if 0
- if (NEW_PROGRAM_H (n).p_vaddr + NEW_PROGRAM_H (n).p_filesz > old_bss_addr)
- fatal ("Program segment above .bss in %s\n", old_name, 0);
-#endif
-
- if (NEW_PROGRAM_H (n).p_type == PT_LOAD
- && (round_up ((NEW_PROGRAM_H (n)).p_vaddr
- + (NEW_PROGRAM_H (n)).p_filesz,
- alignment)
- == round_up (old_bss_addr, alignment)))
- break;
- }
- if (n < 0)
- fatal ("Couldn't find segment next to .bss in %s\n", old_name, 0);
-
- NEW_PROGRAM_H (n).p_filesz += new_offsets_shift;
- NEW_PROGRAM_H (n).p_memsz = NEW_PROGRAM_H (n).p_filesz;
-
-#if 1 /* Maybe allow section after data2 - does this ever happen? */
- for (n = new_file_h->e_phnum - 1; n >= 0; n--)
- {
- if (NEW_PROGRAM_H (n).p_vaddr
- && NEW_PROGRAM_H (n).p_vaddr >= new_data2_addr)
- NEW_PROGRAM_H (n).p_vaddr += new_offsets_shift - old_bss_size;
-
- if (NEW_PROGRAM_H (n).p_offset >= new_data2_offset)
- NEW_PROGRAM_H (n).p_offset += new_offsets_shift;
- }
-#endif
-
- /* Fix up section headers based on new .data2 section. Any section
- whose offset or virtual address is after the new .data2 section
- gets its value adjusted. .bss size becomes zero and new address
- is set. data2 section header gets added by copying the existing
- .data header and modifying the offset, address and size. */
- for (old_data_index = 1; old_data_index < old_file_h->e_shnum;
- old_data_index++)
- if (!strcmp (old_section_names + OLD_SECTION_H (old_data_index).sh_name,
- ".data"))
- break;
- if (old_data_index == old_file_h->e_shnum)
- fatal ("Can't find .data in %s.\n", old_name, 0);
-
- /* Walk through all section headers, insert the new data2 section right
- before the new bss section. */
- for (n = 1, nn = 1; n < old_file_h->e_shnum; n++, nn++)
- {
- caddr_t src;
-
- /* If it is bss section, insert the new data2 section before it. */
- if (n == old_bss_index)
- {
- /* Steal the data section header for this data2 section. */
- memcpy (&NEW_SECTION_H (nn), &OLD_SECTION_H (old_data_index),
- new_file_h->e_shentsize);
-
- NEW_SECTION_H (nn).sh_addr = new_data2_addr;
- NEW_SECTION_H (nn).sh_offset = new_data2_offset;
- NEW_SECTION_H (nn).sh_size = new_data2_size;
- /* Use the bss section's alignment. This will assure that the
- new data2 section always be placed in the same spot as the old
- bss section by any other application. */
- NEW_SECTION_H (nn).sh_addralign = OLD_SECTION_H (n).sh_addralign;
-
- /* Now copy over what we have in the memory now. */
- memcpy (NEW_SECTION_H (nn).sh_offset + new_base,
- (caddr_t) OLD_SECTION_H (n).sh_addr,
- new_data2_size);
- nn++;
- memcpy (&NEW_SECTION_H (nn), &OLD_SECTION_H (n),
- old_file_h->e_shentsize);
-
- /* The new bss section's size is zero, and its file offset and virtual
- address should be off by NEW_OFFSETS_SHIFT. */
- NEW_SECTION_H (nn).sh_offset += new_offsets_shift;
- NEW_SECTION_H (nn).sh_addr = new_bss_addr;
- /* Let the new bss section address alignment be the same as the
- section address alignment followed the old bss section, so
- this section will be placed in exactly the same place. */
- NEW_SECTION_H (nn).sh_addralign = OLD_SECTION_H (nn).sh_addralign;
- NEW_SECTION_H (nn).sh_size = 0;
- }
- else
- {
- memcpy (&NEW_SECTION_H (nn), &OLD_SECTION_H (n),
- old_file_h->e_shentsize);
-
- /* Any section that was original placed AFTER the bss
- section must now be adjusted by NEW_OFFSETS_SHIFT. */
-
- if (NEW_SECTION_H (nn).sh_offset >= new_data2_offset)
- NEW_SECTION_H (nn).sh_offset += new_offsets_shift;
- }
-
- /* If any section hdr refers to the section after the new .data
- section, make it refer to next one because we have inserted
- a new section in between. */
-
- PATCH_INDEX (NEW_SECTION_H (nn).sh_link);
- /* For symbol tables, info is a symbol table index,
- so don't change it. */
- if (NEW_SECTION_H (nn).sh_type != SHT_SYMTAB
- && NEW_SECTION_H (nn).sh_type != SHT_DYNSYM)
- PATCH_INDEX (NEW_SECTION_H (nn).sh_info);
-
- /* Now, start to copy the content of sections. */
- if (NEW_SECTION_H (nn).sh_type == SHT_NULL
- || NEW_SECTION_H (nn).sh_type == SHT_NOBITS)
- continue;
-
- /* Write out the sections. .data and .data1 (and data2, called
- ".data" in the strings table) get copied from the current process
- instead of the old file. */
- if (!strcmp (old_section_names + NEW_SECTION_H (nn).sh_name, ".data")
- || !strcmp (old_section_names + NEW_SECTION_H (nn).sh_name, ".data1")
-#ifdef IRIX6_5
- /* Under IRIX 6.5 gcc places objects with adresses relative to
- shared symbols in the section .rodata, which are adjusted at
- startup time. Unfortunately they aren't adjusted after unexec,
- so with this configuration we must get .rodata also from memory.
- Do any other configurations need this, too?
- <Wolfgang.Glas@hfm.tu-graz.ac.at> 1999-06-08. */
- || !strcmp (old_section_names + NEW_SECTION_H (nn).sh_name, ".rodata")
-#endif
- || !strcmp (old_section_names + NEW_SECTION_H (nn).sh_name, ".got"))
- src = (caddr_t) OLD_SECTION_H (n).sh_addr;
- else
- src = old_base + OLD_SECTION_H (n).sh_offset;
-
- memcpy (NEW_SECTION_H (nn).sh_offset + new_base, src,
- NEW_SECTION_H (nn).sh_size);
-
- /* Adjust the HDRR offsets in .mdebug and copy the
- line data if it's in its usual 'hole' in the object.
- Makes the new file debuggable with dbx.
- patches up two problems: the absolute file offsets
- in the HDRR record of .mdebug (see /usr/include/syms.h), and
- the ld bug that gets the line table in a hole in the
- elf file rather than in the .mdebug section proper.
- David Anderson. davea@sgi.com Jan 16,1994. */
- if (n == old_mdebug_index)
- {
-#define MDEBUGADJUST(__ct,__fileaddr) \
- if (n_phdrr->__ct > 0) \
- { \
- n_phdrr->__fileaddr += movement; \
- }
-
- HDRR * o_phdrr = (HDRR *)((byte *)old_base + OLD_SECTION_H (n).sh_offset);
- HDRR * n_phdrr = (HDRR *)((byte *)new_base + NEW_SECTION_H (nn).sh_offset);
- unsigned movement = new_offsets_shift;
-
- MDEBUGADJUST (idnMax, cbDnOffset);
- MDEBUGADJUST (ipdMax, cbPdOffset);
- MDEBUGADJUST (isymMax, cbSymOffset);
- MDEBUGADJUST (ioptMax, cbOptOffset);
- MDEBUGADJUST (iauxMax, cbAuxOffset);
- MDEBUGADJUST (issMax, cbSsOffset);
- MDEBUGADJUST (issExtMax, cbSsExtOffset);
- MDEBUGADJUST (ifdMax, cbFdOffset);
- MDEBUGADJUST (crfd, cbRfdOffset);
- MDEBUGADJUST (iextMax, cbExtOffset);
- /* The Line Section, being possible off in a hole of the object,
- requires special handling. */
- if (n_phdrr->cbLine > 0)
- {
- if (o_phdrr->cbLineOffset > (OLD_SECTION_H (n).sh_offset
- + OLD_SECTION_H (n).sh_size))
- {
- /* line data is in a hole in elf. do special copy and adjust
- for this ld mistake.
- */
- n_phdrr->cbLineOffset += movement;
-
- memcpy (n_phdrr->cbLineOffset + new_base,
- o_phdrr->cbLineOffset + old_base, n_phdrr->cbLine);
- }
- else
- {
- /* somehow line data is in .mdebug as it is supposed to be. */
- MDEBUGADJUST (cbLine, cbLineOffset);
- }
- }
- }
-
- /* If it is the symbol table, its st_shndx field needs to be patched. */
- if (NEW_SECTION_H (nn).sh_type == SHT_SYMTAB
- || NEW_SECTION_H (nn).sh_type == SHT_DYNSYM)
- {
- Elf32_Shdr *spt = &NEW_SECTION_H (nn);
- unsigned int num = spt->sh_size / spt->sh_entsize;
- Elf32_Sym * sym = (Elf32_Sym *) (NEW_SECTION_H (nn).sh_offset
- + new_base);
- for (; num--; sym++)
- {
- /* don't patch special section indices. */
- if (sym->st_shndx == SHN_UNDEF
- || sym->st_shndx >= SHN_LORESERVE)
- continue;
-
- PATCH_INDEX (sym->st_shndx);
- }
- }
- }
-
- /* Close the files and make the new file executable. */
-
- if (close (old_file))
- fatal ("Can't close (%s): errno %d\n", old_name, errno);
-
- if (close (new_file))
- fatal ("Can't close (%s): errno %d\n", new_name, errno);
-
- if (stat (new_name, &stat_buf) == -1)
- fatal ("Can't stat (%s): errno %d\n", new_name, errno);
-
- n = umask (777);
- umask (n);
- stat_buf.st_mode |= 0111 & ~n;
- if (chmod (new_name, stat_buf.st_mode) == -1)
- fatal ("Can't chmod (%s): errno %d\n", new_name, errno);
-}
+++ /dev/null
-#include <X11/Xlib.h>
-#include <X11/Xatom.h>
-#include <X11/keysym.h>
-#include <X11/cursorfont.h>
-#include <X11/Xutil.h>
-#include <X11/X10.h>
-
-#define XMOUSEBUFSIZE 64
-
-#ifndef sigmask
-#define sigmask(no) (1L << ((no) - 1))
-#endif
-
-#define BLOCK_INPUT_DECLARE() int BLOCK_INPUT_mask
-#ifdef SIGIO
-#define BLOCK_INPUT() EMACS_SIGBLOCKX (SIGIO, BLOCK_INPUT_mask)
-#define UNBLOCK_INPUT() \
- do { int _dummy; EMACS_SIGSETMASK (BLOCK_INPUT_mask, _dummy); } while (0)
-#else /* not SIGIO */
-#define BLOCK_INPUT()
-#define UNBLOCK_INPUT()
-#endif /* SIGIO */
-
-#define CLASS "Emacs" /* class id for GNU Emacs, used in .Xdefaults, etc. */
+++ /dev/null
-/* Bitmaps and things for scrollbars.
- Copyright (C) 1989 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. */
-
-
-static void install_vertical_scrollbar ();
-static void install_horizontal_scrollbar ();
-static void x_set_horizontal_scrollbar ();
-static void x_set_vertical_scrollbar ();
-
-/* Prefix-characters for scroll bar commands in Vglobal_mouse_map.
- Choice of prefix depends on which region of the scroll bar. */
-
-enum scroll_bar_prefix
- { VSCROLL_BAR_PREFIX = 050, VSCROLL_SLIDER_PREFIX /* unused */,
- VSCROLL_THUMBUP_PREFIX, VSCROLL_THUMBDOWN_PREFIX,
- HSCROLL_BAR_PREFIX, HSCROLL_SLIDER_PREFIX /* unused */,
- HSCROLL_THUMBLEFT_PREFIX, HSCROLL_THUMBRIGHT_PREFIX };
-
-#define CROSS_WIDTH 16
-#define CROSS_HEIGHT 16
-
-#define CROSS_MASK_WIDTH 16
-#define CROSS_MASK_HEIGHT 16
-
-/* Vertical and Horizontal scroll bar widths. */
-#define VSCROLL_WIDTH 18
-#define HSCROLL_HEIGHT 18
-
-#ifdef HAVE_X11
-
-/* Arrow cursors for scroll bars. */
-
-Cursor up_arrow_cursor, down_arrow_cursor, v_double_arrow_cursor;
-Cursor left_arrow_cursor, right_arrow_cursor, h_double_arrow_cursor;
-
-static char cross_bits[] =
- {
- 0x00, 0x00, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
- 0x80, 0x01, 0xfe, 0x7f, 0xfe, 0x7f, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
- 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x00, 0x00
- };
-
-static char gray_bits[] =
- {
- 0x55, 0x55, 0xaa, 0xaa, 0x55, 0x55, 0xaa, 0xaa,
- 0x55, 0x55, 0xaa, 0xaa, 0x55, 0x55, 0xaa, 0xaa,
- 0x55, 0x55, 0xaa, 0xaa, 0x55, 0x55, 0xaa, 0xaa,
- 0x55, 0x55, 0xaa, 0xaa, 0x55, 0x55, 0xaa, 0xaa
- };
-
-static char up_arrow_bits[] =
- {
- 0x00, 0x00, 0x80, 0x01, 0xc0, 0x03, 0xe0, 0x07, 0xf0, 0x0f, 0xf8, 0x1f,
- 0xfc, 0x3f, 0xfe, 0x7f, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
- 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0xff, 0xff
- };
-
-static char down_arrow_bits[] =
- {
- 0xff, 0xff, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01,
- 0x80, 0x01, 0x80, 0x01, 0xfe, 0x7f, 0xfc, 0x3f, 0xf8, 0x1f, 0xf0, 0x0f,
- 0xe0, 0x07, 0xc0, 0x03, 0x80, 0x01, 0x00, 0x00
- };
-
-static char left_arrow_bits[] =
- {
- 0x00, 0x80, 0x80, 0x80, 0xc0, 0x80, 0xe0, 0x80, 0xf0, 0x80, 0xf8, 0x80,
- 0xfc, 0x80, 0xfe, 0xff, 0xfe, 0xff, 0xfc, 0x80, 0xf8, 0x80, 0xf0, 0x80,
- 0xe0, 0x80, 0xc0, 0x80, 0x80, 0x80, 0x00, 0x80
- };
-
-static char right_arrow_bits[] =
- {
- 0x01, 0x00, 0x01, 0x01, 0x01, 0x03, 0x01, 0x07, 0x01, 0x0f, 0x01, 0x1f,
- 0x01, 0x3f, 0xff, 0x7f, 0xff, 0x7f, 0x01, 0x3f, 0x01, 0x1f, 0x01, 0x0f,
- 0x01, 0x07, 0x01, 0x03, 0x01, 0x01, 0x01, 0x00
- };
-
-static char cross_mask_bits[] =
- {
- 0xc0, 0x03, 0xc0, 0x03, 0xc0, 0x03, 0xc0, 0x03, 0xc0, 0x03, 0xc0, 0x03,
- 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xc0, 0x03, 0xc0, 0x03,
- 0xc0, 0x03, 0xc0, 0x03, 0xc0, 0x03, 0xc0, 0x03
- };
-#else /* not HAVE_X11 */
-static short cross_bits[] =
- {
- 0x0000, 0x0180, 0x0180, 0x0180,
- 0x0180, 0x0180, 0x0180, 0x7ffe,
- 0x7ffe, 0x0180, 0x0180, 0x0180,
- 0x0180, 0x0180, 0x0180, 0x0000,
- };
-
-static short gray_bits[] = {
- 0xaaaa, 0x5555, 0xaaaa, 0x5555,
- 0xaaaa, 0x5555, 0xaaaa, 0x5555,
- 0xaaaa, 0x5555, 0xaaaa, 0x5555,
- 0xaaaa, 0x5555, 0xaaaa, 0x5555};
-
-static short cross_mask_bits[] =
- {
- 0x03c0, 0x03c0, 0x03c0, 0x03c0,
- 0x03c0, 0x03c0, 0xffff, 0xffff,
- 0xffff, 0xffff, 0x03c0, 0x03c0,
- 0x03c0, 0x03c0, 0x03c0, 0x03c0,
- };
-#endif /* X10 */
+++ /dev/null
-/* X Selection processing for emacs
- Copyright (C) 1990, 1992, 1993 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 2, or (at your option)
-any later version.
-
-GNU Emacs is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Emacs; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-#include "config.h"
-#include "lisp.h"
-#include "xterm.h"
-#include "buffer.h"
-#include "frame.h"
-
-#ifdef HAVE_X11
-
-/* Macros for X Selections */
-#define MAX_SELECTION(dpy) (((dpy)->max_request_size << 2) - 100)
-#define SELECTION_LENGTH(len,format) ((len) * ((format) >> 2))
-
-/* The timestamp of the last input event we received from the X server. */
-unsigned long last_event_timestamp;
-
-/* t if a mouse button is depressed. */
-extern Lisp_Object Vmouse_grabbed;
-
-/* When emacs became the PRIMARY selection owner. */
-Time x_begin_selection_own;
-
-/* When emacs became the SECONDARY selection owner. */
-Time x_begin_secondary_selection_own;
-
-/* When emacs became the CLIPBOARD selection owner. */
-Time x_begin_clipboard_own;
-
-/* The value of the current CLIPBOARD selection. */
-Lisp_Object Vx_clipboard_value;
-
-/* The value of the current PRIMARY selection. */
-Lisp_Object Vx_selection_value;
-
-/* The value of the current SECONDARY selection. */
-Lisp_Object Vx_secondary_selection_value;
-
-/* Types of selections we may make. */
-Lisp_Object Qprimary, Qsecondary, Qclipboard;
-
-/* Emacs' selection property identifiers. */
-Atom Xatom_emacs_selection;
-Atom Xatom_emacs_secondary_selection;
-
-/* Clipboard selection atom. */
-Atom Xatom_clipboard_selection;
-
-/* Clipboard atom. */
-Atom Xatom_clipboard;
-
-/* Atom for indicating incremental selection transfer. */
-Atom Xatom_incremental;
-
-/* Atom for indicating multiple selection request list */
-Atom Xatom_multiple;
-
-/* Atom for what targets emacs handles. */
-Atom Xatom_targets;
-
-/* Atom for indicating timstamp selection request */
-Atom Xatom_timestamp;
-
-/* Atom requesting we delete our selection. */
-Atom Xatom_delete;
-
-/* Selection magic. */
-Atom Xatom_insert_selection;
-
-/* Type of property for INSERT_SELECTION. */
-Atom Xatom_pair;
-
-/* More selection magic. */
-Atom Xatom_insert_property;
-
-/* Atom for indicating property type TEXT */
-Atom Xatom_text;
-
-/* Kinds of protocol things we may receive. */
-Atom Xatom_wm_take_focus;
-Atom Xatom_wm_save_yourself;
-Atom Xatom_wm_delete_window;
-
-/* Communication with window managers. */
-Atom Xatom_wm_protocols;
-
-/* These are to handle incremental selection transfer. */
-Window incr_requestor;
-Atom incr_property;
-int incr_nbytes;
-unsigned char *incr_value;
-unsigned char *incr_ptr;
-
-/* Declarations for handling cut buffers.
-
- Whenever we set a cut buffer or read a cut buffer's value, we cache
- it in cut_buffer_value. We look for PropertyNotify events about
- the CUT_BUFFER properties, and invalidate our cache accordingly.
- We ignore PropertyNotify events that we suspect were caused by our
- own changes to the cut buffers, so we can keep the cache valid
- longer.
-
- IS ALL THIS HAIR WORTH IT? Well, these functions get called every
- time an element goes into or is retrieved from the kill ring, and
- those ought to be quick. It's not fun in time or space to wait for
- 50k cut buffers to fly back and forth across the net. */
-
-/* The number of CUT_BUFFER properties defined under X. */
-#define NUM_CUT_BUFFERS (8)
-
-/* cut_buffer_atom[n] is the atom naming the nth cut buffer. */
-static Atom cut_buffer_atom[NUM_CUT_BUFFERS] = {
- XA_CUT_BUFFER0, XA_CUT_BUFFER1, XA_CUT_BUFFER2, XA_CUT_BUFFER3,
- XA_CUT_BUFFER4, XA_CUT_BUFFER5, XA_CUT_BUFFER6, XA_CUT_BUFFER7
-};
-
-/* cut_buffer_value is an eight-element vector;
- (aref cut_buffer_value n) is the cached value of cut buffer n, or
- Qnil if cut buffer n is unset. */
-static Lisp_Object cut_buffer_value;
-
-/* Bit N of cut_buffer_cached is true if (aref cut_buffer_value n) is
- known to be valid. This is cleared by PropertyNotify events
- handled by x_invalidate_cut_buffer_cache. It would be wonderful if
- that routine could just set the appropriate element of
- cut_buffer_value to some special value meaning "uncached", but that
- would lose if a GC happened to be in progress.
-
- Bit N of cut_buffer_just_set is true if cut buffer N has been set since
- the last PropertyNotify event; since we get an event even when we set
- the property ourselves, we should ignore one event after setting
- a cut buffer, so we don't have to throw away our cache. */
-#ifdef __STDC__
-volatile
-#endif
-static cut_buffer_cached, cut_buffer_just_set;
-
-\f
-/* Acquiring ownership of a selection. */
-
-
-/* Request selection ownership if we do not already have it. */
-
-static int
-own_selection (selection_type, time)
- Atom selection_type;
- Time time;
-{
- Window owner_window, selecting_window;
-
- if ((selection_type == XA_PRIMARY
- && !NILP (Vx_selection_value))
- || (selection_type == XA_SECONDARY
- && !NILP (Vx_secondary_selection_value))
- || (selection_type == Xatom_clipboard
- && !NILP (Vx_clipboard_value)))
- return 1;
-
- selecting_window = FRAME_X_WINDOW (selected_frame);
- XSetSelectionOwner (x_current_display, selection_type,
- selecting_window, time);
- owner_window = XGetSelectionOwner (x_current_display, selection_type);
-
- if (owner_window != selecting_window)
- return 0;
-
- return 1;
-}
-
-/* Become the selection owner and make our data the selection value.
- If we are already the owner, merely change data and timestamp values.
- This avoids generating SelectionClear events for ourselves. */
-
-DEFUN ("x-set-selection", Fx_set_selection, Sx_set_selection,
- 2, 2, "",
- "Set the value of SELECTION to STRING.\n\
-SELECTION may be `primary', `secondary', or `clipboard'.\n\
-\n\
-Selections are a mechanism for cutting and pasting information between\n\
-X Windows clients. Emacs's kill ring commands set the `primary'\n\
-selection to the top string of the kill ring, making it available to\n\
-other clients, like xterm. Those commands also use the `primary'\n\
-selection to retrieve information from other clients.\n\
-\n\
-According to the Inter-Client Communications Conventions Manual:\n\
-\n\
-The `primary' selection \"... is used for all commands that take only a\n\
- single argument and is the principal means of communication between\n\
- clients that use the selection mechanism.\" In Emacs, this means\n\
- that the kill ring commands set the primary selection to the text\n\
- put in the kill ring.\n\
-\n\
-The `secondary' selection \"... is used as the second argument to\n\
- commands taking two arguments (for example, `exchange primary and\n\
- secondary selections'), and as a means of obtaining data when there\n\
- is a primary selection and the user does not want to disturb it.\"\n\
- I am not sure how Emacs should use the secondary selection; if you\n\
- come up with ideas, this function will at least let you get at it.\n\
-\n\
-The `clipboard' selection \"... is used to hold data that is being\n\
- transferred between clients, that is, data that usually is being\n\
- cut or copied, and then pasted.\" It seems that the `clipboard'\n\
- selection is for the most part equivalent to the `primary'\n\
- selection, so Emacs sets them both.\n\
-\n\
-Also see `x-selection', and the `interprogram-cut-function' variable.")
- (selection, string)
- register Lisp_Object selection, string;
-{
- Atom selection_type;
- Lisp_Object val;
- Time event_time = last_event_timestamp;
- CHECK_STRING (string, 0);
-
- val = Qnil;
-
- if (NILP (selection) || EQ (selection, Qprimary))
- {
- BLOCK_INPUT;
- if (own_selection (XA_PRIMARY, event_time))
- {
- x_begin_selection_own = event_time;
- val = Vx_selection_value = string;
- }
- UNBLOCK_INPUT;
- }
- else if (EQ (selection, Qsecondary))
- {
- BLOCK_INPUT;
- if (own_selection (XA_SECONDARY, event_time))
- {
- x_begin_secondary_selection_own = event_time;
- val = Vx_secondary_selection_value = string;
- }
- UNBLOCK_INPUT;
- }
- else if (EQ (selection, Qclipboard))
- {
- BLOCK_INPUT;
- if (own_selection (Xatom_clipboard, event_time))
- {
- x_begin_clipboard_own = event_time;
- val = Vx_clipboard_value = string;
- }
- UNBLOCK_INPUT;
- }
- else
- error ("Invalid X selection type");
-
- return val;
-}
-
-/* Clear our selection ownership data, as some other client has
- become the owner. */
-
-void
-x_disown_selection (old_owner, selection, changed_owner_time)
- Window *old_owner;
- Atom selection;
- Time changed_owner_time;
-{
- struct frame *s = x_window_to_frame (old_owner);
-
- if (s) /* We are the owner */
- {
- if (selection == XA_PRIMARY)
- {
- x_begin_selection_own = 0;
- Vx_selection_value = Qnil;
- }
- else if (selection == XA_SECONDARY)
- {
- x_begin_secondary_selection_own = 0;
- Vx_secondary_selection_value = Qnil;
- }
- else if (selection == Xatom_clipboard)
- {
- x_begin_clipboard_own = 0;
- Vx_clipboard_value = Qnil;
- }
- else
- abort ();
- }
- else
- abort (); /* Inconsistent state. */
-}
-
-\f
-/* Answering selection requests. */
-
-int x_selection_alloc_error;
-int x_converting_selection;
-
-/* Reply to some client's request for our selection data.
- Data is placed in a property supplied by the requesting window.
-
- If the data exceeds the maximum amount the server can send,
- then prepare to send it incrementally, and reply to the client with
- the total size of the data.
-
- But first, check for all the other crufty stuff we could get. */
-
-void
-x_answer_selection_request (event)
- XSelectionRequestEvent event;
-{
- Time emacs_own_time;
- Lisp_Object selection_value;
- XSelectionEvent evt;
- int format = 8; /* We have only byte sized (text) data. */
-
- evt.type = SelectionNotify; /* Construct reply event */
- evt.display = event.display;
- evt.requestor = event.requestor;
- evt.selection = event.selection;
- evt.time = event.time;
- evt.target = event.target;
-
- if (event.selection == XA_PRIMARY)
- {
- emacs_own_time = x_begin_selection_own;
- selection_value = Vx_selection_value;
- }
- else if (event.selection == XA_SECONDARY)
- {
- emacs_own_time = x_begin_secondary_selection_own;
- selection_value = Vx_secondary_selection_value;
- }
- else if (event.selection == Xatom_clipboard)
- {
- emacs_own_time = x_begin_clipboard_own;
- selection_value = Vx_clipboard_value;
- }
- else
- abort ();
-
- if (event.time != CurrentTime
- && event.time < emacs_own_time)
- evt.property = None;
- else
- {
- if (event.property == None) /* obsolete client */
- evt.property = event.target;
- else
- evt.property = event.property;
- }
-
- if (event.target == Xatom_targets) /* Send List of target atoms */
- {
- }
- else if (event.target == Xatom_multiple) /* Recvd list: <target, prop> */
- {
- Atom type;
- int return_format;
- unsigned long items, bytes_left;
- unsigned char *data;
- int result, i;
-
- if (event.property == 0 /* 0 == NILP */
- || event.property == None)
- return;
-
- result = XGetWindowProperty (event.display, event.requestor,
- event.property, 0L, 10000000L,
- True, Xatom_pair, &type, &return_format,
- &items, &bytes_left, &data);
-
- if (result == Success && type == Xatom_pair)
- for (i = items; i > 0; i--)
- {
- /* Convert each element of the list. */
- }
-
- (void) XSendEvent (x_current_display, evt.requestor, False,
- 0L, (XEvent *) &evt);
- return;
- }
- else if (event.target == Xatom_timestamp) /* Send ownership timestamp */
- {
- if (! emacs_own_time)
- abort ();
-
- format = 32;
- XChangeProperty (evt.display, evt.requestor, evt.property,
- evt.target, format, PropModeReplace,
- (unsigned char *) &emacs_own_time, 1);
- return;
- }
- else if (event.target == Xatom_delete) /* Delete our selection. */
- {
- if (EQ (Qnil, selection_value))
- abort ();
-
- x_disown_selection (event.owner, event.selection, event.time);
-
- /* Now return property of type NILP, length 0. */
- XChangeProperty (event.display, event.requestor, event.property,
- 0, format, PropModeReplace, (unsigned char *) 0, 0);
- return;
- }
- else if (event.target == Xatom_insert_selection)
- {
- Atom type;
- int return_format;
- unsigned long items, bytes_left;
- unsigned char *data;
- int result = XGetWindowProperty (event.display, event.requestor,
- event.property, 0L, 10000000L,
- True, Xatom_pair, &type, &return_format,
- &items, &bytes_left, &data);
- if (result == Success && type == Xatom_pair)
- {
- /* Convert the first atom to (a selection) to the target
- indicated by the second atom. */
- }
- }
- else if (event.target == Xatom_insert_property)
- {
- Atom type;
- int return_format;
- unsigned long items, bytes_left;
- unsigned char *data;
- int result = XGetWindowProperty (event.display, event.requestor,
- event.property, 0L, 10000000L,
- True, XA_STRING, &type, &return_format,
- &items, &bytes_left, &data);
-
- if (result == Success && type == XA_STRING && return_format == 8)
- {
- if (event.selection == Xatom_emacs_selection)
- Vx_selection_value = make_string (data);
- else if (event.selection == Xatom_emacs_secondary_selection)
- Vx_secondary_selection_value = make_string (data);
- else if (event.selection == Xatom_clipboard_selection)
- Vx_clipboard_value = make_string (data);
- else
- abort ();
- }
-
- return;
- }
- else if ((event.target == Xatom_text
- || event.target == XA_STRING))
- {
- int size = XSTRING (selection_value)->size;
- unsigned char *data = XSTRING (selection_value)->data;
-
- if (EQ (Qnil, selection_value))
- abort ();
-
- /* Place data on requestor window's property. */
- if (SELECTION_LENGTH (size, format)
- <= MAX_SELECTION (x_current_display))
- {
- x_converting_selection = 1;
- XChangeProperty (evt.display, evt.requestor, evt.property,
- evt.target, format, PropModeReplace,
- data, size);
- if (x_selection_alloc_error)
- {
- x_selection_alloc_error = 0;
- abort ();
- }
- x_converting_selection = 0;
- }
- else /* Send incrementally */
- {
- evt.target = Xatom_incremental;
- incr_requestor = evt.requestor;
- incr_property = evt.property;
- x_converting_selection = 1;
-
- /* Need to handle Alloc errors on these requests. */
- XChangeProperty (evt.display, incr_requestor, incr_property,
- Xatom_incremental, 32,
- PropModeReplace,
- (unsigned char *) &size, 1);
- if (x_selection_alloc_error)
- {
- x_selection_alloc_error = 0;
- x_converting_selection = 0;
- abort ();
- /* Now abort the send. */
- }
-
- incr_nbytes = size;
- incr_value = data;
- incr_ptr = data;
-
- /* Ask for notification when requestor deletes property. */
- XSelectInput (x_current_display, incr_requestor, PropertyChangeMask);
-
- /* If we're sending incrementally, perhaps block here
- until all sent? */
- }
- }
- else
- evt.property = None;
-
- /* Don't do this if there was an Alloc error: abort the transfer
- by sending None. */
- (void) XSendEvent (x_current_display, evt.requestor, False,
- 0L, (XEvent *) &evt);
-}
-
-/* Send an increment of selection data in response to a PropertyNotify event.
- The increment is placed in a property on the requestor's window.
- When the requestor has processed the increment, it deletes the property,
- which sends us another PropertyNotify event.
-
- When there is no more data to send, we send a zero-length increment. */
-
-void
-x_send_incremental (event)
- XPropertyEvent event;
-{
- if (incr_requestor
- && incr_requestor == event.window
- && incr_property == event.atom
- && event.state == PropertyDelete)
- {
- int format = 8;
- int length = MAX_SELECTION (x_current_display);
- int bytes_left = (incr_nbytes - (incr_ptr - incr_value));
-
- if (length > bytes_left) /* Also sends 0 len when finished. */
- length = bytes_left;
- XChangeProperty (x_current_display, incr_requestor,
- incr_property, XA_STRING, format,
- PropModeAppend, incr_ptr, length);
- if (x_selection_alloc_error)
- {
- x_selection_alloc_error = 0;
- x_converting_selection = 0;
- /* Abandon the transmission. */
- abort ();
- }
- if (length > 0)
- incr_ptr += length;
- else
- { /* Everything's sent */
- XSelectInput (x_current_display, incr_requestor, 0L);
- incr_requestor = (Window) 0;
- incr_property = (Atom) 0;
- incr_nbytes = 0;
- incr_value = (unsigned char *) 0;
- incr_ptr = (unsigned char *) 0;
- x_converting_selection = 0;
- }
- }
-}
-
-\f
-/* Requesting the value of a selection. */
-
-static Lisp_Object x_selection_arrival ();
-
-/* Predicate function used to match a requested event. */
-
-Bool
-XCheckSelectionEvent (dpy, event, window)
- Display *dpy;
- XEvent *event;
- char *window;
-{
- if (event->type == SelectionNotify)
- if (event->xselection.requestor == (Window) window)
- return True;
-
- return False;
-}
-
-/* Request a selection value from its owner. This will block until
- all the data is arrived. */
-
-static Lisp_Object
-get_selection_value (type)
- Atom type;
-{
- XEvent event;
- Lisp_Object val;
- Time requestor_time; /* Timestamp of selection request. */
- Window requestor_window;
-
- BLOCK_INPUT;
- requestor_time = last_event_timestamp;
- requestor_window = FRAME_X_WINDOW (selected_frame);
- XConvertSelection (x_current_display, type, XA_STRING,
- Xatom_emacs_selection, requestor_window, requestor_time);
- XIfEvent (x_current_display,
- &event,
- XCheckSelectionEvent,
- (char *) requestor_window);
- val = x_selection_arrival (&event, requestor_window, requestor_time);
- UNBLOCK_INPUT;
-
- return val;
-}
-
-/* Request a selection value from the owner. If we are the owner,
- simply return our selection value. If we are not the owner, this
- will block until all of the data has arrived. */
-
-DEFUN ("x-selection", Fx_selection, Sx_selection,
- 1, 1, "",
- "Return the value of SELECTION.\n\
-SELECTION is one of `primary', `secondary', or `clipboard'.\n\
-\n\
-Selections are a mechanism for cutting and pasting information between\n\
-X Windows clients. When the user selects text in an X application,\n\
-the application should set the primary selection to that text; Emacs's\n\
-kill ring commands will then check the value of the `primary'\n\
-selection, and return it as the most recent kill.\n\
-The documentation for `x-set-selection' gives more information on how\n\
-the different selection types are intended to be used.\n\
-Also see the `interprogram-paste-function' variable.")
- (selection)
- register Lisp_Object selection;
-{
- Atom selection_type;
-
- if (NILP (selection) || EQ (selection, Qprimary))
- {
- if (!NILP (Vx_selection_value))
- return Vx_selection_value;
-
- return get_selection_value (XA_PRIMARY);
- }
- else if (EQ (selection, Qsecondary))
- {
- if (!NILP (Vx_secondary_selection_value))
- return Vx_secondary_selection_value;
-
- return get_selection_value (XA_SECONDARY);
- }
- else if (EQ (selection, Qclipboard))
- {
- if (!NILP (Vx_clipboard_value))
- return Vx_clipboard_value;
-
- return get_selection_value (Xatom_clipboard);
- }
- else
- error ("Invalid X selection type");
-}
-
-static Lisp_Object
-x_selection_arrival (event, requestor_window, requestor_time)
- register XSelectionEvent *event;
- Window requestor_window;
- Time requestor_time;
-{
- int result;
- Atom type, selection;
- int format;
- unsigned long items;
- unsigned long bytes_left;
- unsigned char *data = 0;
- int offset = 0;
-
- if (event->selection == XA_PRIMARY)
- selection = Xatom_emacs_selection;
- else if (event->selection == XA_SECONDARY)
- selection = Xatom_emacs_secondary_selection;
- else if (event->selection == Xatom_clipboard)
- selection = Xatom_clipboard_selection;
- else
- abort ();
-
- if (event->requestor == requestor_window
- && event->time == requestor_time
- && event->property != None)
- if (event->target != Xatom_incremental)
- {
- unsigned char *return_string =
- (unsigned char *) alloca (MAX_SELECTION (x_current_display));
-
- do
- {
- result = XGetWindowProperty (x_current_display, requestor_window,
- event->property, 0L,
- 10000000L, True, XA_STRING,
- &type, &format, &items,
- &bytes_left, &data);
- if (result == Success && type == XA_STRING && format == 8
- && offset < MAX_SELECTION (x_current_display))
- {
- bcopy (data, return_string + offset, items);
- offset += items;
- }
- XFree ((char *) data);
- }
- while (bytes_left);
-
- return make_string (return_string, offset);
- }
- else /* Prepare incremental transfer. */
- {
- unsigned char *increment_value;
- unsigned char *increment_ptr;
- int total_size;
- int *increment_nbytes = 0;
-
- result = XGetWindowProperty (x_current_display, requestor_window,
- selection, 0L, 10000000L, False,
- event->property, &type, &format,
- &items, &bytes_left,
- (unsigned char **) &increment_nbytes);
- if (result == Success)
- {
- XPropertyEvent property_event;
-
- total_size = *increment_nbytes;
- increment_value = (unsigned char *) alloca (total_size);
- increment_ptr = increment_value;
-
- XDeleteProperty (x_current_display, event->requestor,
- event->property);
- XFlush (x_current_display);
- XFree ((char *) increment_nbytes);
-
- do
- { /* NOTE: this blocks. */
- XWindowEvent (x_current_display, requestor_window,
- PropertyChangeMask,
- (XEvent *) &property_event);
-
- if (property_event.atom == selection
- && property_event.state == PropertyNewValue)
- do
- {
- result = XGetWindowProperty (x_current_display,
- requestor_window,
- selection, 0L,
- 10000000L, True,
- AnyPropertyType,
- &type, &format,
- &items, &bytes_left,
- &data);
- if (result == Success && type == XA_STRING
- && format == 8)
- {
- bcopy (data, increment_ptr, items);
- increment_ptr += items;
- }
- }
- while (bytes_left);
-
- }
- while (increment_ptr < (increment_value + total_size));
-
- return make_string (increment_value,
- (increment_ptr - increment_value));
- }
- }
-
- return Qnil;
-}
-
-\f
-/* Cut buffer management. */
-
-DEFUN ("x-get-cut-buffer", Fx_get_cut_buffer, Sx_get_cut_buffer, 0, 1, "",
- "Return the value of cut buffer N, or nil if it is unset.\n\
-If N is omitted, it defaults to zero.\n\
-Note that cut buffers have some problems that selections don't; try to\n\
-write your code to use cut buffers only for backward compatibility,\n\
-and use selections for the serious work.")
- (n)
- Lisp_Object n;
-{
- int buf_num;
-
- if (NILP (n))
- buf_num = 0;
- else
- {
- CHECK_NUMBER (n, 0);
- buf_num = XINT (n);
- }
-
- if (buf_num < 0 || buf_num >= NUM_CUT_BUFFERS)
- error ("cut buffer numbers must be from zero to seven");
-
- {
- Lisp_Object value;
-
- /* Note that no PropertyNotify events will be processed while
- input is blocked. */
- BLOCK_INPUT;
-
- if (cut_buffer_cached & (1 << buf_num))
- value = XVECTOR (cut_buffer_value)->contents[buf_num];
- else
- {
- /* Our cache is invalid; retrieve the property's value from
- the server. */
- int buf_len;
- char *buf = XFetchBuffer (x_current_display, &buf_len, buf_num);
-
- if (buf_len == 0)
- value = Qnil;
- else
- value = make_string (buf, buf_len);
-
- XVECTOR (cut_buffer_value)->contents[buf_num] = value;
- cut_buffer_cached |= (1 << buf_num);
-
- XFree (buf);
- }
-
- UNBLOCK_INPUT;
-
- return value;
- }
-}
-
-DEFUN ("x-set-cut-buffer", Fx_set_cut_buffer, Sx_set_cut_buffer, 2, 2, "",
- "Set the value of cut buffer N to STRING.\n\
-Note that cut buffers have some problems that selections don't; try to\n\
-write your code to use cut buffers only for backward compatibility,\n\
-and use selections for the serious work.")
- (n, string)
- Lisp_Object n, string;
-{
- int buf_num;
-
- CHECK_NUMBER (n, 0);
- CHECK_STRING (string, 1);
-
- buf_num = XINT (n);
-
- if (buf_num < 0 || buf_num >= NUM_CUT_BUFFERS)
- error ("cut buffer numbers must be from zero to seven");
-
- BLOCK_INPUT;
-
- /* DECwindows and some other servers don't seem to like setting
- properties to values larger than about 20k. For very large
- values, they signal an error, but for intermediate values they
- just seem to hang.
-
- We could just truncate the request, but it's better to let the
- user know that the strategy he/she's using isn't going to work
- than to have it work partially, but incorrectly. */
-
- if (XSTRING (string)->size == 0
- || XSTRING (string)->size > MAX_SELECTION (x_current_display))
- {
- XStoreBuffer (x_current_display, (char *) 0, 0, buf_num);
- string = Qnil;
- }
- else
- {
- XStoreBuffer (x_current_display,
- (char *) XSTRING (string)->data, XSTRING (string)->size,
- buf_num);
- }
-
- XVECTOR (cut_buffer_value)->contents[buf_num] = string;
- cut_buffer_cached |= (1 << buf_num);
- cut_buffer_just_set |= (1 << buf_num);
-
- UNBLOCK_INPUT;
-
- return string;
-}
-
-/* Ask the server to send us an event if any cut buffer is modified. */
-
-void
-x_watch_cut_buffer_cache ()
-{
- XSelectInput (x_current_display, ROOT_WINDOW, PropertyChangeMask);
-}
-
-/* The server has told us that a cut buffer has been modified; deal with that.
- Note that this function is called at interrupt level. */
-void
-x_invalidate_cut_buffer_cache (XPropertyEvent *event)
-{
- int i;
-
- /* See which cut buffer this is about, if any. */
- for (i = 0; i < NUM_CUT_BUFFERS; i++)
- if (event->atom == cut_buffer_atom[i])
- {
- int mask = (1 << i);
-
- if (cut_buffer_just_set & mask)
- cut_buffer_just_set &= ~mask;
- else
- cut_buffer_cached &= ~mask;
-
- break;
- }
-}
-
-\f
-/* Bureaucracy. */
-
-void
-syms_of_xselect ()
-{
- DEFVAR_LISP ("x-selection-value", &Vx_selection_value,
- "The value of emacs' last cut-string.");
- Vx_selection_value = Qnil;
-
- DEFVAR_LISP ("x-secondary-selection-value", &Vx_secondary_selection_value,
- "The value of emacs' last secondary cut-string.");
- Vx_secondary_selection_value = Qnil;
-
- DEFVAR_LISP ("x-clipboard-value", &Vx_clipboard_value,
- "The string emacs last sent to the clipboard.");
- Vx_clipboard_value = Qnil;
-
- Qprimary = intern ("primary");
- staticpro (&Qprimary);
- Qsecondary = intern ("secondary");
- staticpro (&Qsecondary);
- Qclipboard = intern ("clipboard");
- staticpro (&Qclipboard);
-
- defsubr (&Sx_set_selection);
- defsubr (&Sx_selection);
-
- cut_buffer_value = Fmake_vector (make_number (NUM_CUT_BUFFERS), Qnil);
- staticpro (&cut_buffer_value);
-
- defsubr (&Sx_get_cut_buffer);
- defsubr (&Sx_set_cut_buffer);
-}
-#endif /* X11 */
+++ /dev/null
-/* Merge parameters into a termcap entry string.
- Copyright (C) 1985, 87, 93, 95 Free Software Foundation, Inc.
-
-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 2, 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; see the file COPYING. If not, write to
-the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-Boston, MA 02111-1307, USA. */
-
-/* Emacs config.h may rename various library functions such as malloc. */
-#ifdef HAVE_CONFIG_H
-#include <config.h>
-#endif
-
-#ifndef emacs
-#if defined(HAVE_STRING_H) || defined(STDC_HEADERS)
-#define bcopy(s, d, n) memcpy ((d), (s), (n))
-#endif
-
-#ifdef STDC_HEADERS
-#include <stdlib.h>
-#include <string.h>
-#else
-char *malloc ();
-char *realloc ();
-#endif
-
-#endif /* not emacs */
-
-#ifndef NULL
-#define NULL (char *) 0
-#endif
-\f
-#ifndef emacs
-static void
-memory_out ()
-{
- write (2, "virtual memory exhausted\n", 25);
- exit (1);
-}
-
-static char *
-xmalloc (size)
- unsigned size;
-{
- register char *tem = malloc (size);
-
- if (!tem)
- memory_out ();
- return tem;
-}
-
-static char *
-xrealloc (ptr, size)
- char *ptr;
- unsigned size;
-{
- register char *tem = realloc (ptr, size);
-
- if (!tem)
- memory_out ();
- return tem;
-}
-#endif /* not emacs */
-\f
-/* Assuming STRING is the value of a termcap string entry
- containing `%' constructs to expand parameters,
- merge in parameter values and store result in block OUTSTRING points to.
- LEN is the length of OUTSTRING. If more space is needed,
- a block is allocated with `malloc'.
-
- The value returned is the address of the resulting string.
- This may be OUTSTRING or may be the address of a block got with `malloc'.
- In the latter case, the caller must free the block.
-
- The fourth and following args to tparam serve as the parameter values. */
-
-static char *tparam1 ();
-
-/* VARARGS 2 */
-char *
-tparam (string, outstring, len, arg0, arg1, arg2, arg3)
- char *string;
- char *outstring;
- int len;
- int arg0, arg1, arg2, arg3;
-{
- int arg[4];
-
- arg[0] = arg0;
- arg[1] = arg1;
- arg[2] = arg2;
- arg[3] = arg3;
- return tparam1 (string, outstring, len, NULL, NULL, arg);
-}
-
-char *BC;
-char *UP;
-
-static char tgoto_buf[50];
-
-char *
-tgoto (cm, hpos, vpos)
- char *cm;
- int hpos, vpos;
-{
- int args[2];
- if (!cm)
- return NULL;
- args[0] = vpos;
- args[1] = hpos;
- return tparam1 (cm, tgoto_buf, 50, UP, BC, args);
-}
-
-static char *
-tparam1 (string, outstring, len, up, left, argp)
- char *string;
- char *outstring;
- int len;
- char *up, *left;
- register int *argp;
-{
- register int c;
- register char *p = string;
- register char *op = outstring;
- char *outend;
- int outlen = 0;
-
- register int tem;
- int *old_argp = argp;
- int doleft = 0;
- int doup = 0;
-
- outend = outstring + len;
-
- while (1)
- {
- /* If the buffer might be too short, make it bigger. */
- if (op + 5 >= outend)
- {
- register char *new;
- if (outlen == 0)
- {
- outlen = len + 40;
- new = (char *) xmalloc (outlen);
- outend += 40;
- bcopy (outstring, new, op - outstring);
- }
- else
- {
- outend += outlen;
- outlen *= 2;
- new = (char *) xrealloc (outstring, outlen);
- }
- op += new - outstring;
- outend += new - outstring;
- outstring = new;
- }
- c = *p++;
- if (!c)
- break;
- if (c == '%')
- {
- c = *p++;
- tem = *argp;
- switch (c)
- {
- case 'd': /* %d means output in decimal. */
- if (tem < 10)
- goto onedigit;
- if (tem < 100)
- goto twodigit;
- case '3': /* %3 means output in decimal, 3 digits. */
- if (tem > 999)
- {
- *op++ = tem / 1000 + '0';
- tem %= 1000;
- }
- *op++ = tem / 100 + '0';
- case '2': /* %2 means output in decimal, 2 digits. */
- twodigit:
- tem %= 100;
- *op++ = tem / 10 + '0';
- onedigit:
- *op++ = tem % 10 + '0';
- argp++;
- break;
-
- case 'C':
- /* For c-100: print quotient of value by 96, if nonzero,
- then do like %+. */
- if (tem >= 96)
- {
- *op++ = tem / 96;
- tem %= 96;
- }
- case '+': /* %+x means add character code of char x. */
- tem += *p++;
- case '.': /* %. means output as character. */
- if (left)
- {
- /* If want to forbid output of 0 and \n and \t,
- and this is one of them, increment it. */
- while (tem == 0 || tem == '\n' || tem == '\t')
- {
- tem++;
- if (argp == old_argp)
- doup++, outend -= strlen (up);
- else
- doleft++, outend -= strlen (left);
- }
- }
- *op++ = tem ? tem : 0200;
- case 'f': /* %f means discard next arg. */
- argp++;
- break;
-
- case 'b': /* %b means back up one arg (and re-use it). */
- argp--;
- break;
-
- case 'r': /* %r means interchange following two args. */
- argp[0] = argp[1];
- argp[1] = tem;
- old_argp++;
- break;
-
- case '>': /* %>xy means if arg is > char code of x, */
- if (argp[0] > *p++) /* then add char code of y to the arg, */
- argp[0] += *p; /* and in any case don't output. */
- p++; /* Leave the arg to be output later. */
- break;
-
- case 'a': /* %a means arithmetic. */
- /* Next character says what operation.
- Add or subtract either a constant or some other arg. */
- /* First following character is + to add or - to subtract
- or = to assign. */
- /* Next following char is 'p' and an arg spec
- (0100 plus position of that arg relative to this one)
- or 'c' and a constant stored in a character. */
- tem = p[2] & 0177;
- if (p[1] == 'p')
- tem = argp[tem - 0100];
- if (p[0] == '-')
- argp[0] -= tem;
- else if (p[0] == '+')
- argp[0] += tem;
- else if (p[0] == '*')
- argp[0] *= tem;
- else if (p[0] == '/')
- argp[0] /= tem;
- else
- argp[0] = tem;
-
- p += 3;
- break;
-
- case 'i': /* %i means add one to arg, */
- argp[0] ++; /* and leave it to be output later. */
- argp[1] ++; /* Increment the following arg, too! */
- break;
-
- case '%': /* %% means output %; no arg. */
- goto ordinary;
-
- case 'n': /* %n means xor each of next two args with 140. */
- argp[0] ^= 0140;
- argp[1] ^= 0140;
- break;
-
- case 'm': /* %m means xor each of next two args with 177. */
- argp[0] ^= 0177;
- argp[1] ^= 0177;
- break;
-
- case 'B': /* %B means express arg as BCD char code. */
- argp[0] += 6 * (tem / 10);
- break;
-
- case 'D': /* %D means weird Delta Data transformation. */
- argp[0] -= 2 * (tem % 16);
- break;
- }
- }
- else
- /* Ordinary character in the argument string. */
- ordinary:
- *op++ = c;
- }
- *op = 0;
- while (doup-- > 0)
- strcat (op, up);
- while (doleft-- > 0)
- strcat (op, left);
- return outstring;
-}
-\f
-#ifdef DEBUG
-
-main (argc, argv)
- int argc;
- char **argv;
-{
- char buf[50];
- int args[3];
- args[0] = atoi (argv[2]);
- args[1] = atoi (argv[3]);
- args[2] = atoi (argv[4]);
- tparam1 (argv[1], buf, "LEFT", "UP", args);
- printf ("%s\n", buf);
- return 0;
-}
-
-#endif /* DEBUG */
projects / emacs.git / commitdiff