From: Ken Raeburn Date: Fri, 6 Jul 2001 08:41:36 +0000 (+0000) Subject: properly mark Attic files as deleted X-Git-Tag: emacs-pretest-21.0.104~64 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=ad782551325b7c694ee234b5ff4c5688d90e561c;p=emacs.git properly mark Attic files as deleted --- diff --git a/PROBLEMS b/PROBLEMS deleted file mode 100644 index 7172c0b99dc..00000000000 --- a/PROBLEMS +++ /dev/null @@ -1,744 +0,0 @@ -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 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. - diff --git a/etc/MACHINES b/etc/MACHINES deleted file mode 100644 index bedf33a120f..00000000000 --- a/etc/MACHINES +++ /dev/null @@ -1,1429 +0,0 @@ -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. - - -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 - 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 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 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 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. - -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 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. - -Local variables: -mode: indented-text -fill-prefix: " " -End: diff --git a/etc/TO-DO b/etc/TO-DO deleted file mode 100644 index e5b9a49599b..00000000000 --- a/etc/TO-DO +++ /dev/null @@ -1,83 +0,0 @@ -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. - diff --git a/etc/news.texi b/etc/news.texi deleted file mode 100644 index cad097889c0..00000000000 --- a/etc/news.texi +++ /dev/null @@ -1,3380 +0,0 @@ -@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 (# 2613 (0 . 38) -864320)) -(mouse-1 (# 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 (# 3440 (0 . 27) -731219)) -(C-drag-mouse-2 (# 3440 (0 . 27) -731219) - (# 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 (# mode-line (33 . 31) -457844)) -(M-S-drag-mouse-2 (# mode-line (33 . 31) -457844) - (# 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 (# 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 diff --git a/etc/termcap.dat b/etc/termcap.dat deleted file mode 100644 index b86869c1fa7..00000000000 --- a/etc/termcap.dat +++ /dev/null @@ -1,1246 +0,0 @@ - -# 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 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. diff --git a/lib-src/env.c b/lib-src/env.c deleted file mode 100644 index 2ae81a630b8..00000000000 --- a/lib-src/env.c +++ /dev/null @@ -1,353 +0,0 @@ -/* 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 - -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); -} - - -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; -} - -#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 */ diff --git a/lib-src/etags-vmslib.c b/lib-src/etags-vmslib.c deleted file mode 100644 index cddb68085f8..00000000000 --- a/lib-src/etags-vmslib.c +++ /dev/null @@ -1,155 +0,0 @@ -/* 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 -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 -#include -#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); -} diff --git a/lib-src/make-path.c b/lib-src/make-path.c deleted file mode 100644 index c4e5bf93144..00000000000 --- a/lib-src/make-path.c +++ /dev/null @@ -1,105 +0,0 @@ -/* 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 -#include -#include -#include - -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; -} diff --git a/lib-src/rcs2log b/lib-src/rcs2log deleted file mode 100755 index dd49a04f3c2..00000000000 --- a/lib-src/rcs2log +++ /dev/null @@ -1,679 +0,0 @@ -#! /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 "LOGINFULLNAMEMAILADDR" 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 .' - -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 ' - -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= # loginfullnamemailaddr 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 &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 <$llogout </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="" # <-- 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 ". - # 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: diff --git a/lib-src/timer.c b/lib-src/timer.c deleted file mode 100644 index 9bd547ce8f2..00000000000 --- a/lib-src/timer.c +++ /dev/null @@ -1,368 +0,0 @@ -/* 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 -#include -#include -#include /* 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; - -/* 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++; -} - -/* 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; -} - -/* 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 (); -} - -#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 */ diff --git a/lib-src/wakeup.c b/lib-src/wakeup.c deleted file mode 100644 index 389519ba1f7..00000000000 --- a/lib-src/wakeup.c +++ /dev/null @@ -1,53 +0,0 @@ -/* Program to produce output at regular intervals. */ - -#ifdef HAVE_CONFIG_H -#include -#endif - -#include -#include - -#ifdef TIME_WITH_SYS_TIME -#include -#include -#else -#ifdef HAVE_SYS_TIME_H -#include -#else -#include -#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); - } -} diff --git a/lisp/ada.el b/lisp/ada.el deleted file mode 100644 index bf7633bf82d..00000000000 --- a/lisp/ada.el +++ /dev/null @@ -1,734 +0,0 @@ -;;; ada.el --- Ada editing support package in GNUlisp. v1.0 - -;; Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc. - -;; Author: Vincent Broman -;; 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-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 diff --git a/lisp/batmode.el b/lisp/batmode.el deleted file mode 100644 index 72a0735c6a6..00000000000 --- a/lisp/batmode.el +++ /dev/null @@ -1,165 +0,0 @@ -;;; batmode.el --- Simple mode for Windows BAT files - -;; Copyright (C) 1996 Free Software Foundation, Inc. - -;; Author: Peter Breton -;; 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 -;; 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 diff --git a/lisp/bytecpat.el b/lisp/bytecpat.el deleted file mode 100644 index 1698b2659ba..00000000000 --- a/lisp/bytecpat.el +++ /dev/null @@ -1,15 +0,0 @@ -;;; 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))) diff --git a/lisp/cl.el b/lisp/cl.el deleted file mode 100644 index 1a6a385e3ee..00000000000 --- a/lisp/cl.el +++ /dev/null @@ -1,3162 +0,0 @@ -;;; cl.el --- Common-Lisp extensions for GNU Emacs Lisp. - -;; Copyright (C) 1987, 1988, 1989, 1992 Free Software Foundation, Inc. - -;; Author: Cesar Quiroz -;; 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 - - -;;;; 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)))))))))) - -;;; 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)))) - -(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))))) - - -;;; 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 - -;;;; 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))))) - -;;; 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)) - -(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 - -;;;; 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)) - -;;; 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))))) - - -(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 - -;;;; 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) - - -(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)))))) - - -(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)))))) - - -;;; 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))) - -;;; 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))))) - -(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)) - -(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 - -;;;; 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)) - -(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 - -(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)))) - -;;; 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))))) - -;;; 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) - -;;; 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 - -;;;; 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") - -(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))))) - -(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))))) - -;;; More sequence functions that don't need keyword arguments - -(defun concatenate (type &rest sequences) - "(concatenate TYPE &rest SEQUENCES) => a sequence -The sequence returned is of type TYPE (must be 'list, 'string, or 'vector) and -contains the concatenation of the elements of all the arguments, in the order -given." - (let ((sequences (append sequences '(())))) - (case type - (list - (apply (function append) sequences)) - (string - (apply (function concat) sequences)) - (vector - (apply (function vector) (apply (function append) sequences))) - (t - (error "type for concatenate `%s' not 'list, 'string or 'vector" - (prin1-to-string type)))))) - -(defun map (type function &rest sequences) - "(map TYPE FUNCTION &rest SEQUENCES) => a sequence -The FUNCTION is called on each set of elements from the SEQUENCES \(stopping -when the shortest sequence is terminated\) and the results are possibly -returned in a sequence of type TYPE \(one of 'list, 'vector, 'string, or nil\) -giving NIL for TYPE gets rid of the values." - (if (not (memq type (list 'list 'string 'vector nil))) - (error "type for map `%s' not 'list, 'string, 'vector or nil" - (prin1-to-string type))) - (let ((argslists (reassemble-argslists sequences)) - results) - (if (null type) - (while argslists ;don't bother accumulating - (apply function (car argslists)) - (setq argslists (cdr argslists))) - (setq results (mapcar (function (lambda (args) (apply function args))) - argslists)) - (case type - (list - results) - (string - (funcall (function concat) results)) - (vector - (apply (function vector) results)))))) - -;;; an inverse of elt is needed for setf purposes - -(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))))))) - -;;; 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)))))) - -;;; 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) - - -;;; 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 - -;;;; 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))))) - -;;;; 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") - -;;; 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 ) 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*)) - -;;; 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))) - -(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 - -;;;; 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))) - -(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)))))))) - -(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 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))))) - -(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))))))))) - -(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)))))) - -;;; 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*)) - -;;; 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 - -;;;; 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.") - -(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))))))))) - -(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))) - -;;; 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'") - - -(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'") - -(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'") - -(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'") - -(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? - -;;; 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)))))) - -;;; 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)))))) - -;;; 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)))) - -;;; 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)) - - -;;;; 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") - - -(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)))))) - -(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)))) - -(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)))) - -(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)))))) - - (: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))) - -(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))))) - -(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)))) - -(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 - -;;; For lisp-interaction mode, so that multiple values can be seen when passed -;;; back. Lies every now and then... - -(defvar - nil "form currently under evaluation") -(defvar + nil "previous -") -(defvar ++ nil "previous +") -(defvar +++ nil "previous ++") -(defvar / nil "list of values returned by +") -(defvar // nil "list of values returned by ++") -(defvar /// nil "list of values returned by +++") -(defvar * nil "(first) value of +") -(defvar ** nil "(first) value of ++") -(defvar *** nil "(first) value of +++") - -(defun cl-eval-print-last-sexp () - "Evaluate sexp before point; print value\(s\) into current buffer. -If the evaled form returns multiple values, they are shown one to a line. -The variables -, +, ++, +++, *, **, ***, /, //, /// have their usual meaning. - -It clears the multiple-value passing mechanism, and does not pass back -multiple values. Use this only if you are debugging cl.el and understand well -how the multiple-value stuff works, because it can be fooled into believing -that multiple values have been returned when they actually haven't, for -instance - \(identity \(values nil 1\)\) -However, even when this fails, you can trust the first printed value to be -\(one of\) the returned value\(s\)." - (interactive) - ;; top level call, can reset mvalues - (setq *mvalues-count* nil - *mvalues-values* nil) - (setq - (car (read-from-string - (buffer-substring - (let ((stab (syntax-table))) - (unwind-protect - (save-excursion - (set-syntax-table emacs-lisp-mode-syntax-table) - (forward-sexp -1) - (point)) - (set-syntax-table stab))) - (point))))) - (setq *** ** - ** * - * (eval -)) - (setq /// // - // / - / *mvalues-values*) - (setq +++ ++ - ++ + - + -) - (cond ((or (null *mvalues-count*) ;mvalues mechanism not used - (not (eq * (car *mvalues-values*)))) - (print * (current-buffer))) - ((null /) ;no values returned - (terpri (current-buffer))) - (t ;more than zero mvalues - (terpri (current-buffer)) - (mapcar (function (lambda (value) - (prin1 value (current-buffer)) - (terpri (current-buffer)))) - /))) - (setq *mvalues-count* nil ;make sure - *mvalues-values* nil)) - -;;;; More LISTS functions -;;;; - -;;; Some mapping functions on lists, commonly useful. -;;; They take no extra sequences, to go along with Emacs Lisp's MAPCAR. - -(defun mapc (function list) - "(MAPC FUNCTION LIST) => LIST -Apply FUNCTION to each element of LIST, return LIST. -Like mapcar, but called only for effect." - (let ((args list)) - (while args - (funcall function (car args)) - (setq args (cdr args)))) - list) - -(defun maplist (function list) - "(MAPLIST FUNCTION LIST) => list'ed results of FUNCTION on cdrs of LIST -Apply FUNCTION to successive sublists of LIST, return the list of the results" - (let ((args list) - results '()) - (while args - (setq results (cons (funcall function args) results) - args (cdr args))) - (nreverse results))) - -(defun mapl (function list) - "(MAPL FUNCTION LIST) => LIST -Apply FUNCTION to successive cdrs of LIST, return LIST. -Like maplist, but called only for effect." - (let ((args list)) - (while args - (funcall function args) - (setq args (cdr args))) - list)) - -(defun mapcan (function list) - "(MAPCAN FUNCTION LIST) => nconc'd results of FUNCTION on LIST -Apply FUNCTION to each element of LIST, nconc the results. -Beware: nconc destroys its first argument! See copy-list." - (let ((args list) - (results '())) - (while args - (setq results (nconc (funcall function (car args)) results) - args (cdr args))) - (nreverse results))) - -(defun mapcon (function list) - "(MAPCON FUNCTION LIST) => nconc'd results of FUNCTION on cdrs of LIST -Apply FUNCTION to successive sublists of LIST, nconc the results. -Beware: nconc destroys its first argument! See copy-list." - (let ((args list) - (results '())) - (while args - (setq results (nconc (funcall function args) results) - args (cdr args))) - (nreverse results))) - -;;; Copiers - -(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)))) - -;;; Substitutions - -(defun subst (new old tree) - "NEW replaces OLD in a copy of TREE -Uses eql for the test." - (subst-if new (function (lambda (x) (eql x old))) tree)) - -(defun subst-if-not (new test tree) - "NEW replaces any subtree or leaf that fails TEST in a copy of TREE" - ;; (subst-if new (function (lambda (x) (not (funcall test x)))) tree) - (cond ((not (funcall test tree)) - new) - ((atom tree) - tree) - (t ;no match so far - (let ((head (subst-if-not new test (car tree))) - (tail (subst-if-not new test (cdr tree)))) - ;; If nothing changed, return originals. Else use the new - ;; components to assemble a new tree. - (if (and (eql head (car tree)) - (eql tail (cdr tree))) - tree - (cons head tail)))))) - -(defun subst-if (new test tree) - "NEW replaces any subtree or leaf that satisfies TEST in a copy of TREE" - (cond ((funcall test tree) - new) - ((atom tree) - tree) - (t ;no match so far - (let ((head (subst-if new test (car tree))) - (tail (subst-if new test (cdr tree)))) - ;; If nothing changed, return originals. Else use the new - ;; components to assemble a new tree. - (if (and (eql head (car tree)) - (eql tail (cdr tree))) - tree - (cons head tail)))))) - -(defun sublis (alist tree) - "Use association list ALIST to modify a copy of TREE -If a subtree or leaf of TREE is a key in ALIST, it is replaced by the -associated value. Not exactly Common Lisp, but close in spirit and -compatible with the native Emacs Lisp ASSOC, which uses EQUAL." - (let ((toplevel (assoc tree alist))) - (cond (toplevel ;Bingo at top - (cdr toplevel)) - ((atom tree) ;Give up on this - tree) - (t - (let ((head (sublis alist (car tree))) - (tail (sublis alist (cdr tree)))) - (if (and (eql head (car tree)) - (eql tail (cdr tree))) - tree - (cons head tail))))))) - -(defun member-if (predicate list) - "PREDICATE is applied to the members of LIST. As soon as one of them -returns true, that tail of the list if returned. Else NIL." - (catch 'found-member-if - (while (not (endp list)) - (if (funcall predicate (car list)) - (throw 'found-member-if list) - (setq list (cdr list)))) - nil)) - -(defun member-if-not (predicate list) - "PREDICATE is applied to the members of LIST. As soon as one of them -returns false, that tail of the list if returned. Else NIL." - (catch 'found-member-if-not - (while (not (endp list)) - (if (funcall predicate (car list)) - (setq list (cdr list)) - (throw 'found-member-if-not list))) - nil)) - -(defun tailp (sublist list) - "(tailp SUBLIST LIST) => True if SUBLIST is a sublist of LIST." - (catch 'tailp-found - (while (not (endp list)) - (if (eq sublist list) - (throw 'tailp-found t) - (setq list (cdr list)))) - nil)) - -;;; Suggestion of phr%widow.Berkeley.EDU@lilac.berkeley.edu - -(defmacro declare (&rest decls) - "Ignore a Common-Lisp declaration." - "declarations are ignored in this implementation") - -(defun proclaim (&rest decls) - "Ignore a Common-Lisp proclamation." - "declarations are ignored in this implementation") - -(defmacro the (type form) - "(the TYPE FORM) macroexpands to FORM -No checking is even attempted. This is just for compatibility with -Common-Lisp codes." - form) - -;;; 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 diff --git a/lisp/cmulisp.el b/lisp/cmulisp.el deleted file mode 100644 index 1e49da84165..00000000000 --- a/lisp/cmulisp.el +++ /dev/null @@ -1,694 +0,0 @@ -;;; 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. - - -;;; 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 -;;; bindings, which is not allowed by the gnumacs standard. - -(defun cmulisp-install-letter-bindings () - "This function binds many cmulisp commands to C-c bindings, -where they are more accessible. C-c 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)) - - - -;;; 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))) - - -(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 . 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-. -;;; - If M-x cmulisp is invoked with a prefix arg, it allows you to -;;; edit the command line. - -(provide 'cmulisp) - -;;; cmulisp.el ends here diff --git a/lisp/custom.el b/lisp/custom.el deleted file mode 100644 index f8ffaeac1a1..00000000000 --- a/lisp/custom.el +++ /dev/null @@ -1,501 +0,0 @@ -;;; custom.el -- Tools for declaring and initializing options. -;; -;; Copyright (C) 1996, 1997, 1999, 2001 Free Software Foundation, Inc. -;; -;; Author: Per Abrahamsen -;; 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 diff --git a/lisp/diary-ins.el b/lisp/diary-ins.el deleted file mode 100644 index d84bb260670..00000000000 --- a/lisp/diary-ins.el +++ /dev/null @@ -1,251 +0,0 @@ -;;; diary-ins.el --- calendar functions for adding diary entries. - -;; Copyright (C) 1990, 1994 Free Software Foundation, Inc. - -;; Author: Edward M. Reingold -;; 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 diff --git a/lisp/diary-lib.el b/lisp/diary-lib.el deleted file mode 100644 index a78475bc916..00000000000 --- a/lisp/diary-lib.el +++ /dev/null @@ -1,1919 +0,0 @@ -;;; diary-lib.el --- diary functions. - -;; Copyright (C) 1989, 1990, 1992, 1993, 1994 Free Software Foundation, Inc. - -;; Author: Edward M. Reingold -;; 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 diff --git a/lisp/ftp.el b/lisp/ftp.el deleted file mode 100644 index 01186dda27a..00000000000 --- a/lisp/ftp.el +++ /dev/null @@ -1,392 +0,0 @@ -;;; ftp.el --- file input and output over Internet using FTP - -;; Copyright (C) 1987 Free Software Foundation, Inc. - -;; Author: Richard Mlynarik - -;; 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 "<<>>")) - (delete-process process) - (error "Ftp %s:%s lost" host file))))) - - -;;;###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 "<<>>")) - (delete-process process) - (error "Ftp write %s:%s lost" host file)))))) - - -(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 diff --git a/lisp/gnus/md5.el b/lisp/gnus/md5.el deleted file mode 100644 index c27fc4afdda..00000000000 --- a/lisp/gnus/md5.el +++ /dev/null @@ -1,409 +0,0 @@ -;;; md5.el -- MD5 Message Digest Algorithm -;;; Gareth Rees - -;; 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 ---------------------------------------------------------- diff --git a/lisp/gnus/nnheaderxm.el b/lisp/gnus/nnheaderxm.el deleted file mode 100644 index 4ac2462f4d8..00000000000 --- a/lisp/gnus/nnheaderxm.el +++ /dev/null @@ -1,156 +0,0 @@ -;;; nnheaderxm.el --- making Gnus backends work under XEmacs -;; Copyright (C) 1996,97 Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen -;; 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. diff --git a/lisp/gnusmail.el b/lisp/gnusmail.el deleted file mode 100644 index 293bde54f4a..00000000000 --- a/lisp/gnusmail.el +++ /dev/null @@ -1,220 +0,0 @@ -;;; gnusmail.el --- mail reply commands for GNUS newsreader - -;; Copyright (C) 1990, 1993 Free Software Foundation, Inc. - -;; Author: Masanobu UMEDA -;; 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)) - - -;;; 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)) - - -;;; 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 -;; - -(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 diff --git a/lisp/gnusmisc.el b/lisp/gnusmisc.el deleted file mode 100644 index df7b16f48d2..00000000000 --- a/lisp/gnusmisc.el +++ /dev/null @@ -1,294 +0,0 @@ -;;; gnusmisc.el --- miscellaneous commands for GNUS newsreader - -;; Copyright (C) 1989, 1990, 1993 Free Software Foundation, Inc. - -;; Author: Masanobu UMEDA -;; 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) - - -;;; -;;; 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)) - - -;;; -;;; 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) - )) - - -;;; 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 diff --git a/lisp/gnuspost.el b/lisp/gnuspost.el deleted file mode 100644 index 441feb245d2..00000000000 --- a/lisp/gnuspost.el +++ /dev/null @@ -1,842 +0,0 @@ -;;; gnuspost.el --- post news commands for GNUS newsreader - -;; Copyright (C) 1989, 1990, 1993, 1994 Free Software Foundation, Inc. - -;; Author: Masanobu UMEDA -;; 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))) - - -;;; 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)) - ))) - )) - - -;;; 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"))) - ))) - - -;; 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 . - (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 diff --git a/lisp/gosmacs.el b/lisp/gosmacs.el deleted file mode 100644 index 93bbbaa5b80..00000000000 --- a/lisp/gosmacs.el +++ /dev/null @@ -1,117 +0,0 @@ -;;; 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 diff --git a/lisp/grow-vers.el b/lisp/grow-vers.el deleted file mode 100644 index a7d03dd00bf..00000000000 --- a/lisp/grow-vers.el +++ /dev/null @@ -1,41 +0,0 @@ -;;; 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 diff --git a/lisp/inc-vers.el b/lisp/inc-vers.el deleted file mode 100644 index 0a4a43f0ea8..00000000000 --- a/lisp/inc-vers.el +++ /dev/null @@ -1,54 +0,0 @@ -;;; 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 diff --git a/lisp/isearch-old.el b/lisp/isearch-old.el deleted file mode 100644 index ee7a1b04476..00000000000 --- a/lisp/isearch-old.el +++ /dev/null @@ -1,608 +0,0 @@ -;;; 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 diff --git a/lisp/iso8859-1.el b/lisp/iso8859-1.el deleted file mode 100644 index 34d0ac0d368..00000000000 --- a/lisp/iso8859-1.el +++ /dev/null @@ -1,104 +0,0 @@ -;;; 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 diff --git a/lisp/libc.el b/lisp/libc.el deleted file mode 100644 index 0ecb6db9030..00000000000 --- a/lisp/libc.el +++ /dev/null @@ -1,254 +0,0 @@ -;;; libc.el -- lookup C symbols in the GNU C Library Reference Manual. - -;; Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc. - -;;; Author: Ralph Schleicher -;;; 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) - - -(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))) - - -(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))) - - -(provide 'libc) - -;;; libc.el ends here diff --git a/lisp/man.el b/lisp/man.el deleted file mode 100644 index 2454b48ded9..00000000000 --- a/lisp/man.el +++ /dev/null @@ -1,1186 +0,0 @@ -;;; man.el --- browse UNIX manual pages - -;; Copyright (C) 1993, 1994, 1996, 1997 Free Software Foundation, Inc. - -;; Author: Barry A. Warsaw -;; 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 , 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 , 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` 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
", 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. - - -;;; 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 - -;; 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) - ) - - -;; ====================================================================== -;; 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)))) - - -;; ====================================================================== -;; 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)) - ""))))) - - -;; ====================================================================== -;; 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)) - )))) - - -;; ====================================================================== -;; 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] 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] 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)) - )))) - - -;; ====================================================================== -;; 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")))) - -;; 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 diff --git a/lisp/medit.el b/lisp/medit.el deleted file mode 100644 index 985c9b27344..00000000000 --- a/lisp/medit.el +++ /dev/null @@ -1,123 +0,0 @@ -;;; 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 diff --git a/lisp/mh-e.el b/lisp/mh-e.el deleted file mode 100644 index 619556d260f..00000000000 --- a/lisp/mh-e.el +++ /dev/null @@ -1,2933 +0,0 @@ -;;; 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 -;; 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: - - - -;;; 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-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)))) - - - -;;; Entry points: - -;;;###autoload -(defun mh-rmail (&optional arg) - "Inc(orporate) new mail (no arg) or scan a MH mail box (arg given). -This front end uses the MH mail system, which uses different conventions -from the usual mail system." - (interactive "P") - (mh-find-path) - (if arg - (call-interactively 'mh-visit-folder) - (mh-inc-folder))) - - -;;;###autoload -(defun mh-smail () - "Compose and send mail with the MH mail system." - (interactive) - (mh-find-path) - (call-interactively 'mh-send)) - - -(defun mh-smail-other-window () - "Compose and send mail in other window with the MH mail system." - (interactive) - (mh-find-path) - (call-interactively 'mh-send-other-window)) - - - -;;; User executable mh-e commands: - -(defun mh-burst-digest () - "Burst apart the current message, which should be a digest. -The message is replaced by its table of contents and the letters from the -digest are inserted into the folder after that message." - (interactive) - (let ((digest (mh-get-msg-num t))) - (mh-process-or-undo-commands mh-current-folder) - (mh-set-folder-modified-p t) ; lock folder while bursting - (message "Bursting digest...") - (mh-exec-cmd "burst" mh-current-folder digest "-inplace") - (mh-scan-folder mh-current-folder (format "%d-last" mh-first-msg-num)) - (message "Bursting digest...done"))) - - -(defun mh-copy-msg (prefix-provided msg-or-seq dest) - "Copy specified MESSAGE(s) to another FOLDER without deleting them. -Default is the displayed message. If optional prefix argument is -provided, then prompt for the message sequence." - (interactive (list current-prefix-arg - (if current-prefix-arg - (mh-read-seq-default "Copy" t) - (mh-get-msg-num t)) - (mh-prompt-for-folder "Copy to" "" t))) - (mh-exec-cmd "refile" msg-or-seq "-link" "-src" mh-current-folder dest) - (if prefix-provided - (mh-notate-seq msg-or-seq ?C mh-cmd-note) - (mh-notate msg-or-seq ?C mh-cmd-note))) - - -(defun mh-delete-msg (msg-or-seq) - "Mark the specified MESSAGE(s) for subsequent deletion and move to the next. -Default is the displayed message. If optional prefix argument is -given then prompt for the message sequence." - (interactive (list (if current-prefix-arg - (mh-read-seq-default "Delete" t) - (mh-get-msg-num t)))) - (if (numberp msg-or-seq) - (mh-delete-a-msg msg-or-seq) - (mh-map-to-seq-msgs 'mh-delete-a-msg msg-or-seq)) - (mh-next-msg)) - - -(defun mh-delete-msg-no-motion (msg-or-seq) - "Mark the specified MESSAGE(s) for subsequent deletion. -Default is the displayed message. If optional prefix argument is -provided, then prompt for the message sequence." - (interactive (list (if current-prefix-arg - (mh-read-seq-default "Delete" t) - (mh-get-msg-num t)))) - (if (numberp msg-or-seq) - (mh-delete-a-msg msg-or-seq) - (mh-map-to-seq-msgs 'mh-delete-a-msg msg-or-seq))) - - -(defun mh-delete-msg-from-seq (prefix-provided msg-or-seq &optional from-seq) - "Delete MESSAGE (default: displayed message) from SEQUENCE. -If optional prefix argument provided, then delete all messages -from a sequence." - (interactive (let ((argp current-prefix-arg)) - (list argp - (if argp - (mh-read-seq-default "Delete" t) - (mh-get-msg-num t)) - (if (not argp) - (mh-read-seq-default "Delete from" t))))) - (if prefix-provided - (mh-remove-seq msg-or-seq) - (mh-remove-msg-from-seq msg-or-seq from-seq))) - - -(defun mh-edit-again (msg) - "Clean-up a draft or a message previously sent and make it resendable." - (interactive (list (mh-get-msg-num t))) - (let* ((from-folder mh-current-folder) - (config (current-window-configuration)) - (draft - (cond ((and mh-draft-folder (equal from-folder mh-draft-folder)) - (pop-to-buffer (find-file-noselect (mh-msg-filename msg)) t) - (rename-buffer (format "draft-%d" msg)) - (buffer-name)) - (t - (mh-read-draft "clean-up" (mh-msg-filename msg) nil))))) - (mh-clean-msg-header (point-min) - "^Date:\\|^Received:\\|^Message-Id:\\|^From:\\|^Delivery-Date:" - nil) - (goto-char (point-min)) - (set-buffer-modified-p nil) - (mh-compose-and-send-mail draft "" from-folder nil nil nil nil nil nil - config))) - - -(defun mh-execute-commands () - "Process outstanding delete and refile requests." - (interactive) - (if mh-narrowed-to-seq (mh-widen)) - (mh-process-commands mh-current-folder) - (mh-set-scan-mode) - (mh-goto-cur-msg) ; after mh-set-scan-mode for efficiency - (mh-make-folder-mode-line) - t) ; return t for write-file-hooks - - -(defun mh-extract-rejected-mail (msg) - "Extract a letter returned by the mail system and make it resendable. -Default is the displayed message." - (interactive (list (mh-get-msg-num t))) - (let ((from-folder mh-current-folder) - (config (current-window-configuration)) - (draft (mh-read-draft "extraction" (mh-msg-filename msg) nil))) - (goto-char (point-min)) - (cond ((re-search-forward mh-rejected-letter-start nil t) - (forward-char 1) - (delete-region (point-min) (point)) - (mh-clean-msg-header (point-min) - "^Date:\\|^Received:\\|^Message-Id:\\|^From:\\|^Sender:\\|^Return-Path:" - nil)) - (t - (message "Does not appear to be a rejected letter."))) - (goto-char (point-min)) - (set-buffer-modified-p nil) - (mh-compose-and-send-mail draft "" from-folder msg (mh-get-field "To") - (mh-get-field "From") (mh-get-field "cc") - nil nil config))) - - -(defun mh-first-msg () - "Move to the first message." - (interactive) - (goto-char (point-min))) - - -(defun mh-forward (prefix-provided msg-or-seq to cc) - "Forward MESSAGE(s) (default: displayed message). -If optional prefix argument provided, then prompt for the message sequence." - (interactive (list current-prefix-arg - (if current-prefix-arg - (mh-read-seq-default "Forward" t) - (mh-get-msg-num t)) - (read-string "To: ") - (read-string "Cc: "))) - (let* ((folder mh-current-folder) - (config (current-window-configuration)) - ;; forw always leaves file in "draft" since it doesn't have -draft - (draft-name (expand-file-name "draft" mh-user-path)) - (draft (cond ((or (not (file-exists-p draft-name)) - (y-or-n-p "The file 'draft' exists. Discard it? ")) - (mh-exec-cmd "forw" - "-build" mh-current-folder msg-or-seq) - (prog1 - (mh-read-draft "" draft-name t) - (mh-insert-fields "To:" to "Cc:" cc) - (set-buffer-modified-p nil))) - (t - (mh-read-draft "" draft-name nil))))) - (goto-char (point-min)) - (re-search-forward "^------- Forwarded Message") - (forward-line -1) - (narrow-to-region (point) (point-max)) - (let* ((subject (save-excursion (mh-get-field "From:"))) - (trim (string-match "<" subject)) - (forw-subject (save-excursion (mh-get-field "Subject:")))) - (if trim - (setq subject (substring subject 0 (1- trim)))) - (widen) - (save-excursion - (mh-insert-fields "Subject:" (format "[%s: %s]" subject forw-subject))) - (delete-other-windows) - (if prefix-provided - (mh-add-msgs-to-seq (mh-seq-to-msgs msg-or-seq) 'forwarded t) - (mh-add-msgs-to-seq msg-or-seq 'forwarded t)) - (mh-compose-and-send-mail draft "" folder msg-or-seq - to subject cc - mh-note-forw "Forwarded:" - config)))) - - -(defun mh-goto-msg (number &optional no-error-if-no-message dont-show) - "Position the cursor at message NUMBER. -Non-nil second argument means do not signal an error if message does not exist. -Non-nil third argument means not to show the message. -Return non-nil if cursor is at message." - (interactive "NGoto message: ") - (let ((cur-msg (mh-get-msg-num nil)) - (starting-place (point)) - (msg-pattern (mh-msg-search-pat number))) - (cond ((cond ((and cur-msg (= cur-msg number)) t) - ((and cur-msg - (< cur-msg number) - (re-search-forward msg-pattern nil t)) t) - ((and cur-msg - (> cur-msg number) - (re-search-backward msg-pattern nil t)) t) - (t ; Do thorough search of buffer - (goto-char (point-max)) - (re-search-backward msg-pattern nil t))) - (beginning-of-line) - (if (not dont-show) (mh-maybe-show number)) - t) - (t - (goto-char starting-place) - (if (not no-error-if-no-message) - (error "No message %d" number)) - nil)))) - - -(defun mh-inc-folder (&optional maildrop-name) - "Inc(orporate) new mail into +inbox. -Optional prefix argument specifies an alternate maildrop from the default. -If this is given, incorporate mail into the current folder, rather -than +inbox. Run `mh-inc-folder-hook' after incorporating new mail." - (interactive (list (if current-prefix-arg - (expand-file-name - (read-file-name "inc mail from file: " - mh-user-path))))) - (let ((config (current-window-configuration))) - (if (not maildrop-name) - (cond ((not (get-buffer "+inbox")) - (mh-make-folder "+inbox") - (setq mh-previous-window-config config)) - ((not (eq (current-buffer) (get-buffer "+inbox"))) - (switch-to-buffer "+inbox") - (setq mh-previous-window-config config))))) - (mh-get-new-mail maildrop-name) - (run-hooks 'mh-inc-folder-hook)) - - -(defun mh-kill-folder () - "Remove the current folder." - (interactive) - (if (or mh-do-not-confirm - (yes-or-no-p (format "Remove folder %s? " mh-current-folder))) - (let ((folder mh-current-folder)) - (mh-set-folder-modified-p t) ; lock folder to kill it - (mh-exec-cmd-daemon "rmf" folder) - (mh-remove-folder-from-folder-list folder) - (message "Folder %s removed" folder) - (mh-set-folder-modified-p nil) ; so kill-buffer doesn't complain - (if (get-buffer mh-show-buffer) - (kill-buffer mh-show-buffer)) - (kill-buffer folder)) - (message "Folder not removed"))) - - -(defun mh-last-msg () - "Move to the last message." - (interactive) - (goto-char (point-max)) - (while (and (not (bobp)) (looking-at "^$")) - (forward-line -1))) - - -(defun mh-list-folders () - "List mail folders." - (interactive) - (with-output-to-temp-buffer " *mh-temp*" - (save-excursion - (switch-to-buffer " *mh-temp*") - (erase-buffer) - (message "Listing folders...") - (mh-exec-cmd-output "folders" t (if mh-recursive-folders - "-recurse" - "-norecurse")) - (goto-char (point-min)) - (message "Listing folders...done")))) - - -(defun mh-msg-is-in-seq (msg) - "Display the sequences that contain MESSAGE (default: displayed message)." - (interactive (list (mh-get-msg-num t))) - (message "Message %d is in sequences: %s" - msg - (mapconcat 'concat - (mh-list-to-string (mh-seq-containing-msg msg)) - " "))) - - -(defun mh-narrow-to-seq (seq) - "Restrict display of this folder to just messages in a sequence. -Reads which sequence. Use \\[mh-widen] to undo this command." - (interactive (list (mh-read-seq "Narrow to" t))) - (let ((eob (point-max))) - (with-mh-folder-updating (t) - (cond ((mh-seq-to-msgs seq) - (mh-copy-seq-to-point seq eob) - (narrow-to-region eob (point-max)) - (mh-make-folder-mode-line (symbol-name seq)) - (mh-recenter nil) - (setq mh-narrowed-to-seq seq)) - (t - (error "No messages in sequence `%s'" (symbol-name seq))))))) - - -(defun mh-next-undeleted-msg (&optional arg) - "Move to next undeleted message in window." - (interactive "P") - (forward-line (prefix-numeric-value arg)) - (setq mh-next-direction 'forward) - (cond ((re-search-forward mh-good-msg-regexp nil 0 arg) - (beginning-of-line) - (mh-maybe-show)) - (t - (forward-line -1) - (if (get-buffer mh-show-buffer) - (delete-windows-on mh-show-buffer))))) - - -(defun mh-pack-folder (range) - "Renumber the messages of a folder to be 1..n. -First, offer to execute any outstanding commands for the current folder. -If optional prefix argument provided, prompt for the range of messages -to display after packing. Otherwise, show the entire folder." - (interactive (list (if current-prefix-arg - (mh-read-msg-range - "Range to scan after packing [all]? ") - "all"))) - (mh-pack-folder-1 range) - (mh-goto-cur-msg) - (message "Packing folder...done")) - - -(defun mh-pipe-msg (prefix-provided command) - "Pipe the current message through the given shell COMMAND. -If optional prefix argument is provided, send the entire message. -Otherwise just send the message's body." - (interactive - (list current-prefix-arg (read-string "Shell command on message: "))) - (save-excursion - (mh-display-msg (mh-get-msg-num t) mh-current-folder) ;update show buffer - (goto-char (point-min)) - (if (not prefix-provided) (search-forward "\n\n")) - (shell-command-on-region (point) (point-max) command nil))) - - -(defun mh-refile-msg (prefix-provided msg-or-seq dest) - "Refile MESSAGE(s) (default: displayed message) in FOLDER. -If optional prefix argument provided, then prompt for message sequence." - (interactive - (list current-prefix-arg - (if current-prefix-arg - (mh-read-seq-default "Refile" t) - (mh-get-msg-num t)) - (intern - (mh-prompt-for-folder "Destination" - (if (eq 'refile (car mh-last-destination)) - (symbol-name (cdr mh-last-destination)) - "") - t)))) - (setq mh-last-destination (cons 'refile dest)) - (if prefix-provided - (mh-map-to-seq-msgs 'mh-refile-a-msg msg-or-seq dest) - (mh-refile-a-msg msg-or-seq dest)) - (mh-next-msg)) - - -(defun mh-refile-or-write-again (msg) - "Re-execute the last refile or write command on the given MESSAGE. -Default is the displayed message. Use the same folder or file as the -previous refile or write command." - (interactive (list (mh-get-msg-num t))) - (if (null mh-last-destination) - (error "No previous refile or write")) - (cond ((eq (car mh-last-destination) 'refile) - (mh-refile-a-msg msg (cdr mh-last-destination)) - (message "Destination folder: %s" (cdr mh-last-destination))) - (t - (mh-write-msg-to-file msg (cdr mh-last-destination)) - (message "Destination: %s" (cdr mh-last-destination)))) - (mh-next-msg)) - - -(defun mh-reply (prefix-provided msg) - "Reply to a MESSAGE (default: displayed message). -If optional prefix argument provided, then include the message in the reply -using filter mhl.reply in your MH directory." - (interactive (list current-prefix-arg (mh-get-msg-num t))) - (let ((minibuffer-help-form - "from => Sender only\nto => Sender and primary recipients\ncc or all => Sender and all recipients")) - (let ((reply-to (or mh-reply-default-reply-to - (completing-read "Reply to whom: " - '(("from") ("to") ("cc") ("all")) - nil - t))) - (folder mh-current-folder) - (show-buffer mh-show-buffer) - (config (current-window-configuration))) - (message "Composing a reply...") - (cond ((or (equal reply-to "from") (equal reply-to "")) - (apply 'mh-exec-cmd - "repl" "-build" "-noquery" - "-nodraftfolder" mh-current-folder - msg - "-nocc" "all" - (if prefix-provided - (list "-filter" "mhl.reply")))) - ((equal reply-to "to") - (apply 'mh-exec-cmd - "repl" "-build" "-noquery" - "-nodraftfolder" mh-current-folder - msg - "-cc" "to" - (if prefix-provided - (list "-filter" "mhl.reply")))) - ((or (equal reply-to "cc") (equal reply-to "all")) - (apply 'mh-exec-cmd - "repl" "-build" "-noquery" - "-nodraftfolder" mh-current-folder - msg - "-cc" "all" "-nocc" "me" - (if prefix-provided - (list "-filter" "mhl.reply"))))) - - (let ((draft (mh-read-draft "reply" - (expand-file-name "reply" mh-user-path) - t))) - (delete-other-windows) - (set-buffer-modified-p nil) - - (let ((to (mh-get-field "To:")) - (subject (mh-get-field "Subject:")) - (cc (mh-get-field "Cc:"))) - (goto-char (point-min)) - (mh-goto-header-end 1) - (if (not prefix-provided) - (mh-display-msg msg folder)) - (mh-add-msgs-to-seq msg 'answered t) - (message "Composing a reply...done") - (mh-compose-and-send-mail draft "" folder msg to subject cc - mh-note-repl "Replied:" config)))))) - - -(defun mh-quit () - "Quit mh-e. -Start by running mh-before-quit-hook. Restore the previous window -configuration, if one exists. Finish by running mh-quit-hook." - (interactive) - (run-hooks 'mh-before-quit-hook) - (if mh-previous-window-config - (set-window-configuration mh-previous-window-config)) - (run-hooks 'mh-quit-hook)) - - -(defun mh-page-digest () - "Advance displayed message to next digested message." - (interactive) - (save-excursion - (mh-show-message-in-other-window) - ;; Go to top of screen (in case user moved point). - (move-to-window-line 0) - (let ((case-fold-search nil)) - ;; Search for blank line and then for From: - (mh-when (not (and (search-forward "\n\n" nil t) - (search-forward "From:" nil t))) - (other-window -1) - (error "No more messages"))) - ;; Go back to previous blank line, then forward to the first non-blank. - (search-backward "\n\n" nil t) - (forward-line 2) - (mh-recenter 0) - (other-window -1))) - - -(defun mh-page-digest-backwards () - "Back up displayed message to previous digested message." - (interactive) - (save-excursion - (mh-show-message-in-other-window) - ;; Go to top of screen (in case user moved point). - (move-to-window-line 0) - (let ((case-fold-search nil)) - (beginning-of-line) - (mh-when (not (and (search-backward "\n\n" nil t) - (search-backward "From:" nil t))) - (other-window -1) - (error "No more messages"))) - ;; Go back to previous blank line, then forward to the first non-blank. - (search-backward "\n\n" nil t) - (forward-line 2) - (mh-recenter 0) - (other-window -1))) - - -(defun mh-page-msg (&optional arg) - "Page the displayed message forwards. -Scrolls ARG lines or a full screen if no argument is supplied." - (interactive "P") - (scroll-other-window arg)) - - -(defun mh-previous-page (&optional arg) - "Page the displayed message backwards. -Scrolls ARG lines or a full screen if no argument is supplied." - (interactive "P") - (save-excursion - (mh-show-message-in-other-window) - (unwind-protect - (scroll-down arg) - (other-window -1)))) - - -(defun mh-previous-undeleted-msg (&optional arg) - "Move to previous undeleted message in window." - (interactive "p") - (setq mh-next-direction 'backward) - (beginning-of-line) - (cond ((re-search-backward mh-good-msg-regexp nil 0 arg) - (mh-maybe-show)) - (t - (if (get-buffer mh-show-buffer) - (delete-windows-on mh-show-buffer))))) - - -(defun mh-print-msg (prefix-provided msg-or-seq) - "Print MESSAGE(s) (default: displayed message) on a line printer. -If optional prefix argument provided, then prompt for the message sequence." - (interactive (list current-prefix-arg - (if current-prefix-arg - (reverse (mh-seq-to-msgs - (mh-read-seq-default "Print" t))) - (mh-get-msg-num t)))) - (if prefix-provided - (message "Printing sequence...") - (message "Printing message...")) - (let ((print-command - (if prefix-provided - (format "(scan -clear %s ; %s -nobell -clear %s %s) | %s" - (mapconcat (function (lambda (msg) msg)) msg-or-seq " ") - (expand-file-name "mhl" mh-lib) - (if (stringp mhl-formfile) - (format "-form %s" mhl-formfile) - "") - (mh-msg-filenames msg-or-seq) - (format mh-lpr-command-format - (if prefix-provided - (format "Sequence from %s" mh-current-folder) - (format "%s/%d" mh-current-folder - msg-or-seq)))) - (format "%s -nobell -clear %s %s | %s" - (expand-file-name "mhl" mh-lib) - (mh-msg-filename msg-or-seq) - (if (stringp mhl-formfile) - (format "-form %s" mhl-formfile) - "") - (format mh-lpr-command-format - (if prefix-provided - (format "Sequence from %s" mh-current-folder) - (format "%s/%d" mh-current-folder - msg-or-seq))))))) - (if mh-print-background - (mh-exec-cmd-daemon shell-file-name "-c" print-command) - (call-process shell-file-name nil nil nil "-c" print-command)) - (if prefix-provided - (mh-notate-seq msg-or-seq ?P mh-cmd-note) - (mh-notate msg-or-seq ?P mh-cmd-note)) - (mh-add-msgs-to-seq msg-or-seq 'printed t) - (if prefix-provided - (message "Printing sequence...done") - (message "Printing message...done")))) - - -(defun mh-put-msg-in-seq (prefix-provided from to) - "Add MESSAGE(s) (default: displayed message) to SEQUENCE. -If optional prefix argument provided, then prompt for the message sequence." - (interactive (list current-prefix-arg - (if current-prefix-arg - (mh-seq-to-msgs - (mh-read-seq-default "Add messages from" t)) - (mh-get-msg-num t)) - (mh-read-seq-default "Add to" nil))) - (setq mh-previous-seq to) - (mh-add-msgs-to-seq from to)) - - -(defun mh-rescan-folder (&optional range) - "Rescan a folder after optionally processing the outstanding commands. -If optional prefix argument is provided, prompt for the range of -messages to display. Otherwise show the entire folder." - (interactive (list (if current-prefix-arg - (mh-read-msg-range "Range to scan [all]? ") - nil))) - (setq mh-next-direction 'forward) - (mh-scan-folder mh-current-folder (or range "all"))) - - -(defun mh-redistribute (to cc msg) - "Redistribute a letter. -Depending on how your copy of MH was compiled, you may need to change the -setting of the variable mh-redist-full-contents. See its documentation." - (interactive (list (read-string "Redist-To: ") - (read-string "Redist-Cc: ") - (mh-get-msg-num t))) - (save-window-excursion - (let ((folder mh-current-folder) - (draft (mh-read-draft "redistribution" - (if mh-redist-full-contents - (mh-msg-filename msg) - nil) - nil))) - (mh-goto-header-end 0) - (insert "Resent-To: " to "\n") - (if (not (equal cc "")) (insert "Resent-cc: " cc "\n")) - (mh-clean-msg-header (point-min) - "^Message-Id:\\|^Received:\\|^Return-Path:\\|^Sender:\\|^Date:\\|^From:" - nil) - (save-buffer) - (message "Redistributing...") - (if mh-redist-full-contents - (call-process "/bin/sh" nil 0 nil "-c" - (format "mhdist=1 mhaltmsg=%s %s -push %s" - (buffer-file-name) - (expand-file-name "send" mh-progs) - (buffer-file-name))) - (call-process "/bin/sh" nil 0 nil "-c" - (format "mhdist=1 mhaltmsg=%s mhannotate=1 %s -push %s" - (mh-msg-filename msg folder) - (expand-file-name "send" mh-progs) - (buffer-file-name)))) - (mh-annotate-msg msg folder mh-note-dist - "-component" "Resent:" - "-text" (format "\"%s %s\"" to cc)) - (kill-buffer draft) - (message "Redistributing...done")))) - - -(defun mh-write-msg-to-file (msg file) - "Append MESSAGE to the end of a FILE." - (interactive - (list (mh-get-msg-num t) - (let ((default-dir (if (eq 'write (car mh-last-destination)) - (file-name-directory (cdr mh-last-destination)) - default-directory))) - (read-file-name "Save message in file: " default-dir - (expand-file-name "mail.out" default-dir))))) - (let ((file-name (mh-msg-filename msg)) - (output-file (mh-expand-file-name file))) - (setq mh-last-destination (cons 'write file)) - (save-excursion - (set-buffer (get-buffer-create " *mh-temp*")) - (erase-buffer) - (insert-file-contents file-name) - (append-to-file (point-min) (point-max) output-file)))) - - -(defun mh-search-folder (folder) - "Search FOLDER for messages matching a pattern." - (interactive (list (mh-prompt-for-folder "Search" - mh-current-folder - t))) - (switch-to-buffer-other-window "pick-pattern") - (if (or (zerop (buffer-size)) - (not (y-or-n-p "Reuse pattern? "))) - (mh-make-pick-template) - (message "")) - (setq mh-searching-folder folder)) - - -(defun mh-send (to cc subject) - "Compose and send a letter. -The letter is composed in mh-letter-mode; see its documentation for more -details. If `mh-compose-letter-function' is defined, it is called on the -draft and passed three arguments: to, subject, and cc." - (interactive "sTo: \nsCc: \nsSubject: ") - (let ((config (current-window-configuration))) - (delete-other-windows) - (mh-send-sub to cc subject config))) - - -(defun mh-send-other-window (to cc subject) - "Compose and send a letter in another window.." - (interactive "sTo: \nsCc: \nsSubject: ") - (let ((pop-up-windows t)) - (mh-send-sub to cc subject (current-window-configuration)))) - - -(defun mh-send-sub (to cc subject config) - "Do the real work of composing and sending a letter. -Expects the TO, CC, and SUBJECT fields as arguments. -CONFIG is the window configuration before sending mail." - (let ((folder mh-current-folder) - (msg-num (mh-get-msg-num nil))) - (message "Composing a message...") - (let ((draft (mh-read-draft - "message" - (if (file-exists-p - (expand-file-name "components" mh-user-path)) - (expand-file-name "components" mh-user-path) - (if (file-exists-p - (expand-file-name "components" mh-lib)) - (expand-file-name "components" mh-lib) - (error "Can't find components file"))) - nil))) - (mh-insert-fields "To:" to "Subject:" subject "Cc:" cc) - (set-buffer-modified-p nil) - (goto-char (point-max)) - (message "Composing a message...done") - (mh-compose-and-send-mail draft "" folder msg-num - to subject cc - nil nil config)))) - - -(defun mh-show (&optional msg) - "Show MESSAGE (default: displayed message). -Forces a two-window display with the folder window on top (size -mh-summary-height) and the show buffer below it." - (interactive) - (if (not msg) - (setq msg (mh-get-msg-num t))) - (setq mh-showing t) - (mh-set-mode-name "mh-e show") - (if (not (eql (next-window (minibuffer-window)) (selected-window))) - (delete-other-windows)) ; force ourself to the top window - (let ((folder mh-current-folder)) - (mh-show-message-in-other-window) - (mh-display-msg msg folder)) - (other-window -1) - (if (not (= (1+ (window-height)) (screen-height))) ;not horizontally split - (shrink-window (- (window-height) mh-summary-height))) - (mh-recenter nil) - (if (not (memq msg mh-seen-list)) (mh-push msg mh-seen-list))) - - -(defun mh-sort-folder () - "Sort the messages in the current folder by date." - (interactive) - (mh-process-or-undo-commands mh-current-folder) - (setq mh-next-direction 'forward) - (mh-set-folder-modified-p t) ; lock folder while sorting - (message "Sorting folder...") - (mh-exec-cmd "sortm" mh-current-folder) - (message "Sorting folder...done") - (mh-scan-folder mh-current-folder "all")) - - -(defun mh-toggle-showing () - "Toggle the scanning mode/showing mode of displaying messages." - (interactive) - (if mh-showing - (mh-set-scan-mode) - (mh-show))) - - -(defun mh-undo (prefix-provided msg-or-seq) - "Undo the deletion or refile of the specified MESSAGE(s). -Default is the displayed message. If optional prefix argument is -provided, then prompt for the message sequence." - (interactive (list current-prefix-arg - (if current-prefix-arg - (mh-read-seq-default "Undo" t) - (mh-get-msg-num t)))) - (cond (prefix-provided - (mh-mapc (function mh-undo-msg) (mh-seq-to-msgs msg-or-seq))) - (t - (let ((original-position (point))) - (beginning-of-line) - (while (not (or (looking-at mh-deleted-msg-regexp) - (looking-at mh-refiled-msg-regexp) - (and (eq mh-next-direction 'forward) (bobp)) - (and (eq mh-next-direction 'backward) - (save-excursion (forward-line) (eobp))))) - (forward-line (if (eq mh-next-direction 'forward) -1 1))) - (if (or (looking-at mh-deleted-msg-regexp) - (looking-at mh-refiled-msg-regexp)) - (progn - (mh-undo-msg (mh-get-msg-num t)) - (mh-maybe-show)) - (goto-char original-position) - (error "Nothing to undo"))))) - ;; update the mh-refile-list so mh-outstanding-commands-p will work - (mh-mapc (function - (lambda (elt) - (if (not (mh-seq-to-msgs elt)) - (setq mh-refile-list (delq elt mh-refile-list))))) - mh-refile-list) - (if (not (mh-outstanding-commands-p)) - (mh-set-folder-modified-p nil))) - - -(defun mh-undo-msg (msg) - ;; Undo the deletion or refile of one MESSAGE. - (cond ((memq msg mh-delete-list) - (setq mh-delete-list (delq msg mh-delete-list)) - (mh-remove-msg-from-seq msg 'deleted t)) - (t - (mh-mapc (function (lambda (dest) - (mh-remove-msg-from-seq msg dest t))) - mh-refile-list))) - (mh-notate msg ? mh-cmd-note)) - - -(defun mh-undo-folder (&rest ignore) - "Undo all commands in current folder." - (interactive) - (cond ((or mh-do-not-confirm - (yes-or-no-p "Undo all commands in folder? ")) - (setq mh-delete-list nil - mh-refile-list nil - mh-seq-list nil - mh-next-direction 'forward) - (with-mh-folder-updating (nil) - (mh-unmark-all-headers t))) - (t - (message "Commands not undone.") - (sit-for 2)))) - - -(defun mh-unshar-msg (dir) - "Unpack the shar file contained in the current message into directory DIR." - (interactive (list (read-file-name "Unshar message in directory: " - mh-unshar-default-directory - mh-unshar-default-directory nil))) - (mh-display-msg (mh-get-msg-num t) mh-current-folder) ;update show buffer - (mh-unshar-buffer dir)) - -(defun mh-unshar-buffer (dir) - ;; Unpack the shar file contained in the current buffer into directory DIR. - (goto-char (point-min)) - (if (or (re-search-forward "^#![ \t]*/bin/sh" nil t) - (and (re-search-forward "^[^a-z0-9\"]*cut here\b" nil t) - (forward-line 1)) - (re-search-forward "^#" nil t) - (re-search-forward "^: " nil t)) - (let ((default-directory (expand-file-name dir)) - (start (progn (beginning-of-line) (point))) - (log-buffer (get-buffer-create "*Unshar Output*"))) - (save-excursion - (set-buffer log-buffer) - (setq default-directory (expand-file-name dir)) - (erase-buffer) - (if (file-directory-p default-directory) - (insert "cd " dir "\n") - (insert "mkdir " dir "\n") - (call-process "mkdir" nil log-buffer t default-directory))) - (set-window-start (display-buffer log-buffer) 0) ;so can watch progress - (call-process-region start (point-max) "sh" nil log-buffer t)) - (error "Cannot find start of shar."))) - - -(defun mh-visit-folder (folder &optional range) - "Visit FOLDER and display RANGE of messages. -Assumes mh-e has already been initialized." - (interactive (list (mh-prompt-for-folder "Visit" "+inbox" t) - (mh-read-msg-range "Range [all]? "))) - (let ((config (current-window-configuration))) - (mh-scan-folder folder (or range "all")) - (setq mh-previous-window-config config)) - nil) - - -(defun mh-widen () - "Remove restrictions from the current folder, thereby showing all messages." - (interactive) - (if mh-narrowed-to-seq - (with-mh-folder-updating (t) - (delete-region (point-min) (point-max)) - (widen) - (mh-make-folder-mode-line))) - (setq mh-narrowed-to-seq nil)) - - - -;;; Support routines. - -(defun mh-delete-a-msg (msg) - ;; Delete the MESSAGE. - (save-excursion - (mh-goto-msg msg nil t) - (if (looking-at mh-refiled-msg-regexp) - (error "Message %d is refiled. Undo refile before deleting." msg)) - (if (looking-at mh-deleted-msg-regexp) - nil - (mh-set-folder-modified-p t) - (mh-push msg mh-delete-list) - (mh-add-msgs-to-seq msg 'deleted t) - (mh-notate msg ?D mh-cmd-note)))) - - -(defun mh-refile-a-msg (msg destination) - ;; Refile MESSAGE in FOLDER. FOLDER is a symbol, not a string. - (save-excursion - (mh-goto-msg msg nil t) - (cond ((looking-at mh-deleted-msg-regexp) - (error "Message %d is deleted. Undo delete before moving." msg)) - ((looking-at mh-refiled-msg-regexp) - (if (y-or-n-p - (format "Message %d already refiled. Copy to %s as well? " - msg destination)) - (mh-exec-cmd "refile" (mh-get-msg-num t) "-link" - "-src" mh-current-folder - (symbol-name destination)) - (message "Message not copied."))) - (t - (mh-set-folder-modified-p t) - (if (not (memq destination mh-refile-list)) - (mh-push destination mh-refile-list)) - (if (not (memq msg (mh-seq-to-msgs destination))) - (mh-add-msgs-to-seq msg destination t)) - (mh-notate msg ?^ mh-cmd-note))))) - - -(defun mh-display-msg (msg-num folder) - ;; Display message NUMBER of FOLDER. - ;; Sets the current buffer to the show buffer. - (set-buffer folder) - ;; Bind variables in folder buffer in case they are local - (let ((formfile mhl-formfile) - (clean-message-header mh-clean-message-header) - (invisible-headers mh-invisible-headers) - (visible-headers mh-visible-headers) - (msg-filename (mh-msg-filename msg-num)) - (show-buffer mh-show-buffer) - (folder mh-current-folder)) - (if (not (file-exists-p msg-filename)) - (error "Message %d does not exist" msg-num)) - (switch-to-buffer show-buffer) - (if mh-bury-show-buffer (bury-buffer (current-buffer))) - (mh-when (not (equal msg-filename buffer-file-name)) - ;; Buffer does not yet contain message. - (clear-visited-file-modtime) - (unlock-buffer) - (setq buffer-file-name nil) ; no locking during setup - (erase-buffer) - (if formfile - (if (stringp formfile) - (mh-exec-lib-cmd-output "mhl" "-nobell" "-noclear" - "-form" formfile msg-filename) - (mh-exec-lib-cmd-output "mhl" "-nobell" "-noclear" - msg-filename)) - (insert-file-contents msg-filename)) - (goto-char (point-min)) - (cond (clean-message-header - (mh-clean-msg-header (point-min) - invisible-headers - visible-headers) - (goto-char (point-min))) - (t - (let ((case-fold-search t)) - (re-search-forward - "^To:\\|^From:\\|^Subject:\\|^Date:" nil t) - (beginning-of-line) - (mh-recenter 0)))) - (set-buffer-modified-p nil) - (setq buffer-file-name msg-filename) - (set-mark nil) - (setq mode-line-buffer-identification - (list (format mh-show-buffer-mode-line-buffer-id - folder msg-num)))))) - - -(defun mh-invalidate-show-buffer () - ;; Invalidate the show buffer so we must update it to use it. - (if (get-buffer mh-show-buffer) - (save-excursion - (set-buffer mh-show-buffer) - (setq buffer-file-name nil)))) - - -(defun mh-show-message-in-other-window () - (switch-to-buffer-other-window mh-show-buffer) - (if mh-bury-show-buffer (bury-buffer (current-buffer)))) - - -(defun mh-clean-msg-header (start invisible-headers visible-headers) - ;; Flush extraneous lines in a message header, from the given POINT to the - ;; end of the message header. If VISIBLE-HEADERS is non-nil, it contains a - ;; regular expression specifying the lines to display, otherwise - ;; INVISIBLE-HEADERS contains a regular expression specifying lines to - ;; delete from the header. - (let ((case-fold-search t)) - (save-restriction - (goto-char start) - (if (search-forward "\n\n" nil t) - (backward-char 1)) - (narrow-to-region start (point)) - (goto-char (point-min)) - (if visible-headers - (while (< (point) (point-max)) - (beginning-of-line) - (cond ((looking-at visible-headers) - (forward-line 1) - (while (looking-at "^[ \t]+") (forward-line 1))) - (t - (mh-delete-line 1) - (while (looking-at "^[ \t]+") - (beginning-of-line) - (mh-delete-line 1))))) - (while (re-search-forward invisible-headers nil t) - (beginning-of-line) - (mh-delete-line 1) - (while (looking-at "^[ \t]+") - (beginning-of-line) - (mh-delete-line 1)))) - (unlock-buffer)))) - - -(defun mh-delete-line (lines) - ;; Delete version of kill-line. - (delete-region (point) (save-excursion (forward-line lines) (point)))) - - -(defun mh-read-draft (use initial-contents delete-contents-file) - ;; Read draft file into a draft buffer and make that buffer the current one. - ;; USE is a message used for prompting about the intended use of the message. - ;; INITIAL-CONTENTS is filename that is read into an empty buffer, or NIL - ;; if buffer should not be modified. Delete the initial-contents file if - ;; DELETE-CONTENTS-FILE flag is set. - ;; Returns the draft folder's name. - ;; If the draft folder facility is enabled in ~/.mh_profile, a new buffer is - ;; used each time and saved in the draft folder. The draft file can then be - ;; reused. - (cond (mh-draft-folder - (let ((orig-default-dir default-directory)) - (pop-to-buffer (find-file-noselect (mh-new-draft-name)) t) - (rename-buffer (format "draft-%s" (buffer-name))) - (setq default-directory orig-default-dir))) - (t - (let ((draft-name (expand-file-name "draft" mh-user-path))) - (pop-to-buffer "draft") ; Create if necessary - (if (buffer-modified-p) - (if (y-or-n-p "Draft has been modified; kill anyway? ") - (set-buffer-modified-p nil) - (error "Draft preserved"))) - (setq buffer-file-name draft-name) - (clear-visited-file-modtime) - (unlock-buffer) - (mh-when (and (file-exists-p draft-name) - (not (equal draft-name initial-contents))) - (insert-file-contents draft-name) - (delete-file draft-name))))) - (mh-when (and initial-contents - (or (zerop (buffer-size)) - (not (y-or-n-p - (format "A draft exists. Use for %s? " use))))) - (erase-buffer) - (insert-file-contents initial-contents) - (if delete-contents-file (delete-file initial-contents))) - (auto-save-mode 1) - (if mh-draft-folder - (save-buffer)) ; Do not reuse draft name - (buffer-name)) - - -(defun mh-new-draft-name () - ;; Returns the pathname of folder for draft messages. - (save-excursion - (set-buffer (get-buffer-create " *mh-temp*")) - (erase-buffer) - (mh-exec-cmd-output "mhpath" nil mh-draft-folder "new") - (buffer-substring (point) (1- (mark 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))) - - - -;;; 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)) - - - -;;; 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"))) - - - -;;; 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)))) - - - -;;; 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))))) - - - -;;; Commands to manipulate sequences. Sequences are stored in an alist -;;; of the form: -;;; ((seq-name msgs ...) (seq-name msgs ...) ...) - -(defun mh-make-seq (name msgs) (cons name msgs)) - -(defmacro mh-seq-name (pair) (list 'car pair)) - -(defmacro mh-seq-msgs (pair) (list 'cdr pair)) - -(defun mh-find-seq (name) (assoc name mh-seq-list)) - - -(defun mh-seq-to-msgs (seq) - "Return a list of the messages in SEQUENCE." - (mh-seq-msgs (mh-find-seq seq))) - - -(defun mh-seq-containing-msg (msg) - ;; Return a list of the sequences containing MESSAGE. - (let ((l mh-seq-list) - (seqs ())) - (while l - (if (memq msg (mh-seq-msgs (car l))) - (mh-push (mh-seq-name (car l)) seqs)) - (setq l (cdr l))) - seqs)) - - -(defun mh-msg-to-seq (msg) - ;; Given a MESSAGE number, return the first sequence in which it occurs. - (car (mh-seq-containing-msg msg))) - - -(defun mh-read-seq-default (prompt not-empty) - ;; Read and return sequence name with default narrowed or previous sequence. - (mh-read-seq prompt not-empty (or mh-narrowed-to-seq mh-previous-seq))) - - -(defun mh-read-seq (prompt not-empty &optional default) - ;; Read and return a sequence name. Prompt with PROMPT, raise an error - ;; if the sequence is empty and the NOT-EMPTY flag is non-nil, and supply - ;; an optional DEFAULT sequence. - ;; A reply of '%' defaults to the first sequence containing the current - ;; message. - (let* ((input (completing-read (format "%s %s %s" prompt "sequence:" - (if default - (format "[%s] " default) - "")) - (mh-seq-names mh-seq-list))) - (seq (cond ((equal input "%") (mh-msg-to-seq (mh-get-msg-num t))) - ((equal input "") default) - (t (intern input)))) - (msgs (mh-seq-to-msgs seq))) - (if (and (null msgs) not-empty) - (error (format "No messages in sequence `%s'" seq))) - seq)) - - -(defun mh-read-folder-sequences (folder define-sequences) - ;; Read and return the predefined sequences for a FOLDER. If - ;; DEFINE-SEQUENCES is non-nil, then define mh-e's sequences before - ;; reading MH's sequences. - (let ((seqs ())) - (mh-when define-sequences - (mh-define-sequences mh-seq-list) - (mh-mapc (function (lambda (seq) ; Save the internal sequences - (if (mh-folder-name-p (mh-seq-name seq)) - (mh-push seq seqs)))) - mh-seq-list)) - (save-excursion - (mh-exec-cmd-quiet " *mh-temp*" "mark" folder "-list") - (goto-char (point-min)) - ;; look for name in line of form "cur: 4" or "myseq (private): 23" - (while (re-search-forward "^[^: ]+" nil t) - (mh-push (mh-make-seq (intern (buffer-substring (match-beginning 0) - (match-end 0))) - (mh-read-msg-list)) - seqs)) - (delete-region (point-min) (point))) ; avoid race with mh-process-daemon - seqs)) - - -(defun mh-seq-names (seq-list) - ;; Return an alist containing the names of the SEQUENCES. - (mapcar (function (lambda (entry) (list (symbol-name (mh-seq-name entry))))) - seq-list)) - - -(defun mh-seq-from-command (folder seq seq-command) - ;; In FOLDER, make a sequence named SEQ by executing COMMAND. - ;; COMMAND is a list. The first element is a program name - ;; and the subsequent elements are its arguments, all strings. - (let ((msg) - (msgs ()) - (case-fold-search t)) - (save-excursion - (save-window-excursion - (apply 'mh-exec-cmd-quiet " *mh-temp*" seq-command) - (goto-char (point-min)) - (while (setq msg (car (mh-read-msg-list))) - (mh-push msg msgs) - (forward-line 1))) - (set-buffer folder) - (setq msgs (nreverse msgs)) ; Put in ascending order - (mh-push (mh-make-seq seq msgs) mh-seq-list) - msgs))) - - -(defun mh-read-msg-list () - ;; Return a list of message numbers from the current point to the end of - ;; the line. - (let ((msgs ()) - (end-of-line (save-excursion (end-of-line) (point))) - num) - (while (re-search-forward "[0-9]+" end-of-line t) - (setq num (string-to-int (buffer-substring (match-beginning 0) - (match-end 0)))) - (cond ((looking-at "-") ; Message range - (forward-char 1) - (re-search-forward "[0-9]+" end-of-line t) - (let ((num2 (string-to-int (buffer-substring (match-beginning 0) - (match-end 0))))) - (if (< num2 num) - (error "Bad message range: %d-%d" num num2)) - (while (<= num num2) - (mh-push num msgs) - (setq num (1+ num))))) - ((not (zerop num)) (mh-push num msgs)))) - msgs)) - - -(defun mh-remove-seq (seq) - ;; Delete the SEQUENCE. - (mh-map-to-seq-msgs 'mh-notate-if-in-one-seq seq ? (1+ mh-cmd-note) seq) - (mh-undefine-sequence seq (list "all")) - (mh-delete-seq-locally seq)) - - -(defun mh-delete-seq-locally (seq) - ;; Remove mh-e's record of SEQUENCE. - (let ((entry (mh-find-seq seq))) - (setq mh-seq-list (delq entry mh-seq-list)))) - - -(defun mh-remove-msg-from-seq (msg seq &optional internal-flag) - ;; Remove MESSAGE from the SEQUENCE. If optional FLAG is non-nil, do not - ;; inform MH of the change. - (let ((entry (mh-find-seq seq))) - (mh-when entry - (mh-notate-if-in-one-seq msg ? (1+ mh-cmd-note) (mh-seq-name entry)) - (if (not internal-flag) - (mh-undefine-sequence seq (list msg))) - (setcdr entry (delq msg (mh-seq-msgs entry)))))) - - -(defun mh-add-msgs-to-seq (msgs seq &optional internal-flag) - ;; Add MESSAGE(s) to the SEQUENCE. If optional FLAG is non-nil, do not mark - ;; the message in the scan listing or inform MH of the addition. - (let ((entry (mh-find-seq seq))) - (if (and msgs (atom msgs)) (setq msgs (list msgs))) - (if (null entry) - (mh-push (mh-make-seq seq msgs) mh-seq-list) - (if msgs (setcdr entry (append msgs (cdr entry))))) - (mh-when (not internal-flag) - (mh-add-to-sequence seq msgs) - (mh-notate-seq seq ?% (1+ mh-cmd-note))))) - - -(defun mh-rename-seq (seq new-name) - "Rename a SEQUENCE to have a new NAME." - (interactive "SOld sequence name: \nSNew name: ") - (let ((old-seq (mh-find-seq seq))) - (if old-seq - (rplaca old-seq new-name) - (error "Sequence %s does not exists" seq)) - (mh-undefine-sequence seq (mh-seq-msgs old-seq)) - (mh-define-sequence new-name (mh-seq-msgs old-seq)))) - - -(defun mh-notate-user-sequences () - ;; Mark the scan listing of all messages in user-defined sequences. - (let ((seqs mh-seq-list) - name) - (while seqs - (setq name (mh-seq-name (car seqs))) - (if (not (mh-internal-seq name)) - (mh-notate-seq name ?% (1+ mh-cmd-note))) - (setq seqs (cdr seqs))))) - - -(defun mh-internal-seq (name) - ;; Return non-NIL if NAME is the name of an internal mh-e sequence. - (or (memq name '(answered cur deleted forwarded printed)) - (eq name mh-unseen-seq) - (mh-folder-name-p name))) - - -(defun mh-folder-name-p (name) - ;; Return non-NIL if NAME is possibly the name of a folder. - ;; A name (a string or symbol) can be a folder name if it begins with "+". - (if (symbolp name) - (eql (aref (symbol-name name) 0) ?+) - (eql (aref name 0) ?+))) - - -(defun mh-notate-seq (seq notation offset) - ;; Mark the scan listing of all messages in the SEQUENCE with the CHARACTER - ;; at the given OFFSET from the beginning of the listing line. - (mh-map-to-seq-msgs 'mh-notate seq notation offset)) - - -(defun mh-notate-if-in-one-seq (msg notation offset seq) - ;; If the MESSAGE is in only the SEQUENCE, then mark the scan listing of the - ;; message with the CHARACTER at the given OFFSET from the beginning of the - ;; listing line. - (let ((in-seqs (mh-seq-containing-msg msg))) - (if (and (eq seq (car in-seqs)) (null (cdr in-seqs))) - (mh-notate msg notation offset)))) - - -(defun mh-map-to-seq-msgs (func seq &rest args) - ;; Invoke the FUNCTION at each message in the SEQUENCE, passing the - ;; remaining ARGS as arguments. - (save-excursion - (let ((msgs (mh-seq-to-msgs seq))) - (while msgs - (if (mh-goto-msg (car msgs) t t) - (apply func (car msgs) args)) - (setq msgs (cdr msgs)))))) - - -(defun mh-map-over-seqs (func seq-list) - ;; Apply the FUNCTION to each element in the list of SEQUENCES, - ;; passing the sequence name and the list of messages as arguments. - (while seq-list - (funcall func (mh-seq-name (car seq-list)) (mh-seq-msgs (car seq-list))) - (setq seq-list (cdr seq-list)))) - - -(defun mh-define-sequences (seq-list) - ;; Define the sequences in SEQ-LIST. - (mh-map-over-seqs 'mh-define-sequence seq-list)) - - -(defun mh-add-to-sequence (seq msgs) - ;; Add to a SEQUENCE each message the list of MSGS. - (if (not (mh-folder-name-p seq)) - (if msgs - (apply 'mh-exec-cmd "mark" mh-current-folder - "-sequence" (symbol-name seq) - "-add" msgs)))) - - -(defun mh-define-sequence (seq msgs) - ;; Define the SEQUENCE to contain the list of MSGS. Do not mark - ;; pseudo-sequences or empty sequences. - (if (and msgs - (not (mh-folder-name-p seq))) - (save-excursion - (apply 'mh-exec-cmd "mark" mh-current-folder - "-sequence" (symbol-name seq) - "-add" "-zero" (mh-list-to-string msgs))))) - - -(defun mh-undefine-sequence (seq msgs) - ;; Remove from the SEQUENCE the list of MSGS. - (apply 'mh-exec-cmd "mark" mh-current-folder - "-sequence" (symbol-name seq) - "-delete" msgs)) - - -(defun mh-copy-seq-to-point (seq location) - ;; Copy the scan listing of the messages in SEQUENCE to after the point - ;; LOCATION in the current buffer. - (mh-map-to-seq-msgs 'mh-copy-line-to-point seq location)) - - -(defun mh-copy-line-to-point (msg location) - ;; Copy the current line to the LOCATION in the current buffer. - (beginning-of-line) - (let ((beginning-of-line (point))) - (forward-line 1) - (copy-region-as-kill beginning-of-line (point)) - (goto-char location) - (yank) - (goto-char beginning-of-line))) - - - -;;; Issue commands to MH. - -(defun mh-exec-cmd (command &rest args) - ;; Execute MH command COMMAND with ARGS. - ;; Any output is assumed to be an error and is shown to the user. - (save-excursion - (set-buffer " *mh-temp*") - (erase-buffer) - (apply 'call-process - (expand-file-name command mh-progs) nil t nil - (mh-list-to-string args)) - (if (> (buffer-size) 0) - (save-window-excursion - (switch-to-buffer-other-window " *mh-temp*") - (sit-for 5))))) - - -(defun mh-exec-cmd-quiet (buffer command &rest args) - ;; In BUFFER, execute MH command COMMAND with ARGS. - ;; ARGS is a list of strings. Return in BUFFER, if one exists. - (mh-when (stringp buffer) - (set-buffer buffer) - (erase-buffer)) - (apply 'call-process - (expand-file-name command mh-progs) nil buffer nil - args)) - - -(defun mh-exec-cmd-output (command display &rest args) - ;; Execute MH command COMMAND with DISPLAY flag and ARGS putting the output - ;; into buffer after point. Set mark after inserted text. - (push-mark (point) t) - (apply 'call-process - (expand-file-name command mh-progs) nil t display - (mh-list-to-string args)) - (exchange-point-and-mark)) - - -(defun mh-exec-cmd-daemon (command &rest args) - ;; Execute MH command COMMAND with ARGS. Any output from command is - ;; displayed in an asynchronous pop-up window. - (save-excursion - (set-buffer (get-buffer-create " *mh-temp*")) - (erase-buffer)) - (let* ((process-connection-type nil) - (process (apply 'start-process - command nil - (expand-file-name command mh-progs) - (mh-list-to-string args)))) - (set-process-filter process 'mh-process-daemon))) - - -(defun mh-process-daemon (process output) - ;; Process daemon that puts output into a temporary buffer. - (set-buffer (get-buffer-create " *mh-temp*")) - (insert-before-markers output) - (display-buffer " *mh-temp*")) - - -(defun mh-exec-lib-cmd-output (command &rest args) - ;; Execute MH library command COMMAND with ARGS. - ;; Put the output into buffer after point. Set mark after inserted text. - (push-mark (point) t) - (apply 'call-process - (expand-file-name command mh-lib) nil t nil - (mh-list-to-string args)) - (exchange-point-and-mark)) - - -(defun mh-list-to-string (l) - ;; Flattens the list L and makes every element of the new list into a string. - (let ((new-list nil)) - (while l - (cond ((null (car l))) - ((symbolp (car l)) (mh-push (symbol-name (car l)) new-list)) - ((numberp (car l)) (mh-push (int-to-string (car l)) new-list)) - ((equal (car l) "")) - ((stringp (car l)) (mh-push (car l) new-list)) - ((listp (car l)) - (setq new-list (nconc (nreverse (mh-list-to-string (car l))) - new-list))) - (t (error "Bad element in mh-list-to-string: %s" (car l)))) - (setq l (cdr l))) - (nreverse new-list))) - - - -;;; Commands to annotate a message. - -(defun mh-annotate-msg (msg buffer note &rest args) - ;; Mark the MESSAGE in BUFFER listing with the character NOTE and annotate - ;; the saved message with ARGS. - (apply 'mh-exec-cmd "anno" buffer msg args) - (save-excursion - (cond ((get-buffer buffer) ; Buffer may be deleted - (set-buffer buffer) - (if (symbolp msg) - (mh-notate-seq msg note (1+ mh-cmd-note)) - (mh-notate msg note (1+ mh-cmd-note))))))) - - -(defun mh-notate (msg notation offset) - ;; Marks MESSAGE with the character NOTATION at position OFFSET. - ;; Null MESSAGE means the message that the cursor points to. - (save-excursion - (if (or (null msg) - (mh-goto-msg msg t t)) - (with-mh-folder-updating (t) - (beginning-of-line) - (forward-char offset) - (delete-char 1) - (insert notation))))) - - - -;;; User prompting commands. - -(defun mh-prompt-for-folder (prompt default can-create) - ;; Prompt for a folder name with PROMPT. Returns the folder's name as a - ;; string. DEFAULT is used if the folder exists and the user types return. - ;; If the CAN-CREATE flag is t, then a non-existent folder is made. - (let* ((prompt (format "%s folder%s" prompt - (if (equal "" default) - "? " - (format " [%s]? " default)))) - name) - (if (null mh-folder-list) - (mh-set-folder-list)) - (while (and (setq name (completing-read prompt mh-folder-list - nil nil "+")) - (equal name "") - (equal default ""))) - (cond ((or (equal name "") (equal name "+")) - (setq name default)) - ((not (mh-folder-name-p name)) - (setq name (format "+%s" name)))) - (let ((new-file-p (not (file-exists-p (mh-expand-file-name name))))) - (cond ((and new-file-p - (y-or-n-p - (format "Folder %s does not exist. Create it? " name))) - (message "Creating %s" name) - (call-process "mkdir" nil nil nil (mh-expand-file-name name)) - (message "Creating %s...done" name) - (mh-push (list name) mh-folder-list)) - (new-file-p - (error "Folder %s is not created" name)) - (t - (mh-when (null (assoc name mh-folder-list)) - (mh-push (list name) mh-folder-list))))) - name)) - - -(defun mh-set-folder-list () - "Sets mh-folder-list correctly. -A useful function for the command line or for when you need to sync by hand." - (setq mh-folder-list (mh-make-folder-list))) - - -(defun mh-make-folder-list () - "Return a list of the user's folders. -Result is in a form suitable for completing read." - (interactive) - (message "Collecting folder names...") - (save-window-excursion - (mh-exec-cmd-quiet " *mh-temp*" "folders" "-fast" - (if mh-recursive-folders - "-recurse" - "-norecurse")) - (goto-char (point-min)) - (let ((list nil) - start) - (while (not (eobp)) - (setq start (point)) - (forward-line 1) - (mh-push (list (format "+%s" (buffer-substring start (1- (point))))) - list)) - (message "Collecting folder names...done") - list))) - - -(defun mh-remove-folder-from-folder-list (folder) - ;; Remove FOLDER from the list of folders. - (setq mh-folder-list - (delq (assoc folder mh-folder-list) mh-folder-list))) - - -(defun mh-read-msg-range (prompt) - ;; Read a list of blank-separated items. - (let* ((buf (read-string prompt)) - (buf-size (length buf)) - (start 0) - (input ())) - (while (< start buf-size) - (let ((next (read-from-string buf start buf-size))) - (mh-push (car next) input) - (setq start (cdr next)))) - (nreverse input))) - - - -;;; Misc. functions. - -(defun mh-get-msg-num (error-if-no-message) - ;; Return the message number of the displayed message. If the argument - ;; ERROR-IF-NO-MESSAGE is non-nil, then complain if the cursor is not - ;; pointing to a message. - (save-excursion - (beginning-of-line) - (cond ((looking-at mh-msg-number-regexp) - (string-to-int (buffer-substring (match-beginning 1) - (match-end 1)))) - (error-if-no-message - (error "Cursor not pointing to message")) - (t nil)))) - - -(defun mh-msg-search-pat (n) - ;; Return a search pattern for message N in the scan listing. - (format mh-msg-search-regexp n)) - - -(defun mh-msg-filename (msg &optional folder) - ;; Return the file name of MESSAGE in FOLDER (default current folder). - (expand-file-name (int-to-string msg) - (if folder - (mh-expand-file-name folder) - mh-folder-filename))) - - -(defun mh-msg-filenames (msgs &optional folder) - ;; Return a list of file names for MSGS in FOLDER (default current folder). - (mapconcat (function (lambda (msg) (mh-msg-filename msg folder))) msgs " ")) - - -(defun mh-expand-file-name (filename &optional default) - "Just like `expand-file-name', but also handles MH folder names. -Assumes that any filename that starts with '+' is a folder name." - (if (mh-folder-name-p filename) - (expand-file-name (substring filename 1) mh-user-path) - (expand-file-name filename default))) - - -(defun mh-find-path () - ;; Set mh-user-path, mh-draft-folder, and mh-unseen-seq from profile file. - (save-excursion - ;; Be sure profile is fully expanded before switching buffers - (let ((profile (expand-file-name (or (getenv "MH") "~/.mh_profile")))) - (if (not (file-exists-p profile)) - (error "Cannot find MH profile %s" profile)) - (set-buffer (get-buffer-create " *mh-temp*")) - (erase-buffer) - (insert-file-contents profile) - (setq mh-draft-folder (mh-get-field "Draft-Folder:")) - (cond ((equal mh-draft-folder "") - (setq mh-draft-folder nil)) - ((not (mh-folder-name-p mh-draft-folder)) - (setq mh-draft-folder (format "+%s" mh-draft-folder)))) - (setq mh-user-path (mh-get-field "Path:")) - (if (equal mh-user-path "") - (setq mh-user-path "Mail")) - (setq mh-user-path - (file-name-as-directory - (expand-file-name mh-user-path (expand-file-name "~")))) - (if (and mh-draft-folder - (not (file-exists-p (mh-expand-file-name mh-draft-folder)))) - (error "Draft folder %s does not exist. Create it and try again." - mh-draft-folder)) - (setq mh-unseen-seq (mh-get-field "Unseen-Sequence:")) - (if (equal mh-unseen-seq "") - (setq mh-unseen-seq 'unseen) - (setq mh-unseen-seq (intern mh-unseen-seq)))))) - - -(defun mh-get-field (field) - ;; Find and return the value of field FIELD in the current buffer. - ;; Returns the empty string if the field is not in the message. - (let ((case-fold-search t)) - (goto-char (point-min)) - (cond ((not (re-search-forward (format "^%s" field) nil t)) "") - ((looking-at "[\t ]*$") "") - (t - (re-search-forward "[\t ]*\\([^\t \n].*\\)$" nil t) - (let ((start (match-beginning 1))) - (forward-line 1) - (while (looking-at "[ \t]") - (forward-line 1)) - (buffer-substring start (1- (point)))))))) - - -(defun mh-insert-fields (&rest name-values) - ;; Insert the NAME-VALUE pairs in the current buffer. - ;; Do not insert any pairs whose value is the empty string. - (let ((case-fold-search t)) - (while name-values - (let ((field-name (car name-values)) - (value (car (cdr name-values)))) - (mh-when (not (equal value "")) - (goto-char (point-min)) - (cond ((not (re-search-forward (format "^%s" field-name) nil t)) - (mh-goto-header-end 0) - (insert field-name " " value "\n")) - (t - (end-of-line) - (insert " " value)))) - (setq name-values (cdr (cdr name-values))))))) - - -(defun mh-position-on-field (field set-mark) - ;; Set point to the end of the line beginning with FIELD. - ;; Set the mark to the old value of point, if SET-MARK is non-nil. - ;; Returns non-nil iff the field was found. - (let ((case-fold-search t)) - (if set-mark (push-mark)) - (goto-char (point-min)) - (mh-goto-header-end 0) - (if (re-search-backward (format "^%s" field) nil t) - (progn (end-of-line) t) - nil))) - - -(defun mh-goto-header-end (arg) - ;; Find the end of the message header in the current buffer and position - ;; the cursor at the ARG'th newline after the header. - (if (re-search-forward "^$\\|^-+$" nil nil) - (forward-line arg))) - - - -;;; Build the folder-mode keymap: - -(suppress-keymap mh-folder-mode-map) -(define-key mh-folder-mode-map "q" 'mh-quit) -(define-key mh-folder-mode-map "b" 'mh-quit) -(define-key mh-folder-mode-map "?" 'mh-msg-is-in-seq) -(define-key mh-folder-mode-map "%" 'mh-put-msg-in-seq) -(define-key mh-folder-mode-map "|" 'mh-pipe-msg) -(define-key mh-folder-mode-map "\ea" 'mh-edit-again) -(define-key mh-folder-mode-map "\e%" 'mh-delete-msg-from-seq) -(define-key mh-folder-mode-map "\C-xn" 'mh-narrow-to-seq) -(define-key mh-folder-mode-map "\C-xw" 'mh-widen) -(define-key mh-folder-mode-map "\eb" 'mh-burst-digest) -(define-key mh-folder-mode-map "\eu" 'mh-undo-folder) -(define-key mh-folder-mode-map "\e " 'mh-page-digest) -(define-key mh-folder-mode-map "\e\177" 'mh-page-digest-backwards) -(define-key mh-folder-mode-map "\ee" 'mh-extract-rejected-mail) -(define-key mh-folder-mode-map "\ef" 'mh-visit-folder) -(define-key mh-folder-mode-map "\ek" 'mh-kill-folder) -(define-key mh-folder-mode-map "\el" 'mh-list-folders) -(define-key mh-folder-mode-map "\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) - - - -;;; 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 diff --git a/lisp/mhspool.el b/lisp/mhspool.el deleted file mode 100644 index b81823938f0..00000000000 --- a/lisp/mhspool.el +++ /dev/null @@ -1,490 +0,0 @@ -;;; mhspool.el --- MH folder access using NNTP for GNU Emacs - -;; Copyright (C) 1988, 1989, 1990, 1993 Free Software Foundation, Inc. - -;; Author: Masanobu UMEDA -;; 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.") - - - -(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) - ))) - - -;;; -;;; 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 - ) - - -;;; -;;; 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 - )) - - -;; 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 diff --git a/lisp/mim-mode.el b/lisp/mim-mode.el deleted file mode 100644 index 94e63cb9f48..00000000000 --- a/lisp/mim-mode.el +++ /dev/null @@ -1,848 +0,0 @@ -;;; 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 - 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 \) where is a list or pointed list -of integers, means indent each form in by the amount specified -in . When is exhausted, indent remaining forms by -`mim-body-indent' unless 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\)\) - - - - - ...> -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 diff --git a/lisp/mim-syntax.el b/lisp/mim-syntax.el deleted file mode 100644 index beb8d330a35..00000000000 --- a/lisp/mim-syntax.el +++ /dev/null @@ -1,95 +0,0 @@ -;;; 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 diff --git a/lisp/netunam.el b/lisp/netunam.el deleted file mode 100644 index 492ac9b2c12..00000000000 --- a/lisp/netunam.el +++ /dev/null @@ -1,160 +0,0 @@ -;;; netunam.el --- HP-UX RFA Commands - -;; Copyright (C) 1988 Free Software Foundation, Inc. - -;; Author: Chris Hanson -;; 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)))))))) - -(defun rfa-open (node &optional user password) - "Open a network connection to a server using remote file access. -First argument NODE is the network node for the remote machine. -Second optional argument USER is the user name to use on that machine. - If called interactively, the user name is prompted for. -Third optional argument PASSWORD is the password string for that user. - If not given, this is filled in from the value of -`rfa-password-alist', or prompted for. A prefix argument of - will -cause the password to be prompted for even if previously memoized." - (interactive - (list (read-file-name "rfa-open: " rfa-node-directory rfa-default-node t) - (read-string "user-name: " (user-login-name)))) - (let ((node - (and (or rfa-password-per-node-p - (not (equal user (user-login-name)))) - node))) - (if (not password) - (setq password - (let ((password - (cdr (assoc user (cdr (assoc node rfa-password-alist)))))) - (or (and (not current-prefix-arg) password) - (rfa-password-read - (format "password for user %s%s: " - user - (if node (format " on node \"%s\"" node) "")) - password)))))) - (let ((result - (sysnetunam (expand-file-name node rfa-node-directory) - (concat user ":" password)))) - (if (interactive-p) - (if result - (message "Opened network connection to %s as %s" node user) - (error "Unable to open network connection"))) - (if (and rfa-password-memoize-p result) - (rfa-set-password password node user)) - result)) - -(defun rfa-close (node) - "Close a network connection to a server using remote file access. -NODE is the network node for the remote machine." - (interactive - (list (read-file-name "rfa-close: " rfa-node-directory rfa-default-node t))) - (let ((result (sysnetunam (expand-file-name node rfa-node-directory) ""))) - (cond ((not (interactive-p)) result) - ((not result) (error "Unable to close network connection")) - (t (message "Closed network connection to %s" node))))) - -(defun rfa-password-read (prompt default) - (let ((rfa-password-accumulator (or default ""))) - (read-from-minibuffer prompt - (and default - (let ((copy (concat default)) - (index 0) - (length (length default))) - (while (< index length) - (aset copy index ?.) - (setq index (1+ index))) - copy)) - rfa-password-map) - rfa-password-accumulator)) - -(defvar rfa-password-map nil) -(if (not rfa-password-map) - (let ((char ? )) - (setq rfa-password-map (make-keymap)) - (while (< char 127) - (define-key rfa-password-map (char-to-string char) - 'rfa-password-self-insert) - (setq char (1+ char))) - (define-key rfa-password-map "\C-g" - 'abort-recursive-edit) - (define-key rfa-password-map "\177" - 'rfa-password-rubout) - (define-key rfa-password-map "\n" - 'exit-minibuffer) - (define-key rfa-password-map "\r" - 'exit-minibuffer))) - -(defvar rfa-password-accumulator nil) - -(defun rfa-password-self-insert () - (interactive) - (setq rfa-password-accumulator - (concat rfa-password-accumulator - (char-to-string last-command-char))) - (insert ?.)) - -(defun rfa-password-rubout () - (interactive) - (delete-char -1) - (setq rfa-password-accumulator - (substring rfa-password-accumulator 0 -1))) - -;;; netunam.el ends here diff --git a/lisp/old-shell.el b/lisp/old-shell.el deleted file mode 100644 index 4c3944a65f4..00000000000 --- a/lisp/old-shell.el +++ /dev/null @@ -1,399 +0,0 @@ -;;; 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") - - -;;; 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)) - - -(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*")) - - -;;; 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 | | -;;; where 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 - (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 diff --git a/lisp/sc-alist.el b/lisp/sc-alist.el deleted file mode 100644 index 31cb0a180ba..00000000000 --- a/lisp/sc-alist.el +++ /dev/null @@ -1,134 +0,0 @@ -;; -*- 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)) diff --git a/lisp/sc.el b/lisp/sc.el deleted file mode 100644 index 03eade6cba2..00000000000 --- a/lisp/sc.el +++ /dev/null @@ -1,1547 +0,0 @@ -;; -*- 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) - - -;; 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.") - - - -;; ====================================================================== -;; 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 -;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - - -;; ====================================================================== -;; 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) - - - -;; ====================================================================== -;; 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)) - - -;; ====================================================================== -;; 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)) - - -;; ====================================================================== -;; 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 , 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 , 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 ; 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 () - "\"\" ==
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") "") - )))) - - -;; ====================================================================== -;; 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))))) - - -;; ====================================================================== -;; 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)))) - - -;; ====================================================================== -;; 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))))) - - -;; ====================================================================== -;; 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) - - -;; ====================================================================== -;; 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))))) - - -;; ====================================================================== -;; 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))))))) - - -;; ====================================================================== -;; 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))) - - -;; ====================================================================== -;; 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))))) - ))))))) - - -;; ====================================================================== -;; 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))) - - -;; ====================================================================== -;; 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 \"." - (interactive) - (describe-function 'sc-describe)) - -;; ====================================================================== -;; load hook -(run-hooks 'sc-load-hook) -(provide 'sc) diff --git a/lisp/sc.elec.el b/lisp/sc.elec.el deleted file mode 100644 index 67f18c66a5e..00000000000 --- a/lisp/sc.elec.el +++ /dev/null @@ -1,198 +0,0 @@ -;; -*- 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.") - - - -;; ====================================================================== -;; 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) - )) - - - -;; ====================================================================== -;; 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) - )) - )))) - - - -;; ====================================================================== -;; 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)) diff --git a/lisp/setaddr.el b/lisp/setaddr.el deleted file mode 100644 index 1ae72ef6cb5..00000000000 --- a/lisp/setaddr.el +++ /dev/null @@ -1,71 +0,0 @@ -;;; 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 diff --git a/lisp/sun-keys.el b/lisp/sun-keys.el deleted file mode 100644 index f91abc2063f..00000000000 --- a/lisp/sun-keys.el +++ /dev/null @@ -1,77 +0,0 @@ -;;; sun-keys.el --- support for Sun function keys - -;;; Copyright (C) 1986 Free Software Foundation, Inc. - -;; Author: Ian G. Batten -;; 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 * F1 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 diff --git a/lisp/superyank.el b/lisp/superyank.el deleted file mode 100644 index f76e6c7c3bf..00000000000 --- a/lisp/superyank.el +++ /dev/null @@ -1,1243 +0,0 @@ -;;; superyank.el --- smart message-yanking code for GNUS - -;; Copyright (C) 1992 Free Software Foundation, Inc. - -;; Author: Barry A. Warsaw -;; 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 -From: \"John Xavier Doe\" -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 - ;; - (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 diff --git a/lisp/timer.el b/lisp/timer.el deleted file mode 100644 index e860f843095..00000000000 --- a/lisp/timer.el +++ /dev/null @@ -1,473 +0,0 @@ -;;; 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) - -(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))))) - -;; 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))) - -;;;###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)) - -(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))) - -(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))))) - -(provide 'timer) - -;;; timer.el ends here diff --git a/lisp/tpu-doc.el b/lisp/tpu-doc.el deleted file mode 100644 index ef724ecb6d9..00000000000 --- a/lisp/tpu-doc.el +++ /dev/null @@ -1,469 +0,0 @@ -;;; tpu-doc.el --- Documentation for TPU-edt - -;; Copyright (C) 1993, 1994 Free Software Foundation, Inc. - -;; Author: Rob Riepel -;; Maintainer: Rob Riepel -;; 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 -;; ";; %% ", where is what is discussed in that section. - - -;; %% Contents - -;; % Introduction -;; % Terminal Support -;; % X-windows Support -;; % Differences Between TPU-edt and the Real Thing -;; % Starting TPU-edt -;; % TPU-edt Default Editing Keypad, Control and Gold Key Bindings -;; % Optional TPU-edt Extensions -;; % Customizing TPU-edt using the Emacs Initialization File -;; % Compiling TPU-edt -;; % Regular expressions in TPU-edt -;; % Etcetera - - -;; %% Introduction - -;; TPU-edt is based on tpu.el by Jeff Kowalski 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- 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 -;; m regex - -;; Type "q" to quit out of info mode. - -;; There is a problem in regular expression mode when searching for -;; empty strings, like beginning-of-line (^) and end-of-line ($). -;; When searching for these strings, find-next may find the current -;; string, instead of the next one. This can cause global replace and -;; substitute commands to loop forever in the same location. For this -;; reason, commands like - -;; replace "^" "> " " to beginning of line> -;; replace "$" "00711" - -;; may not work properly. - -;; Commands like those above are very useful for adding text to the -;; beginning or end of lines. They might work on a line-by-line basis, -;; but go into an infinite loop if the "all" response is specified. If -;; the goal is to add a string to the beginning or end of a particular -;; set of lines TPU-edt provides functions to do this. - -;; Gold-^ Add a string at BOL in region or buffer -;; Gold-$ Add a string at EOL in region or buffer - -;; There is also a TPU-edt interface to the native emacs string -;; replacement commands. Gold-/ invokes this command. It accepts -;; regular expressions if TPU-edt is in regular expression mode. Given -;; a repeat count, it will perform the replacement without prompting -;; for confirmation. - -;; This command replaces empty strings correctly, however, it has its -;; drawbacks. As a native emacs command, it has a different interface -;; than the emulated TPU commands. Also, it works only in the forward -;; direction, regardless of the current TPU-edt direction. - - -;; %% Etcetera - -;; That's TPU-edt in a nutshell... - -;; Please send any bug reports, feature requests, or cookies to the -;; author, Rob Riepel, at the address shown by the tpu-version command -;; (Gold-V). - -;; Share and enjoy... Rob Riepel 7/93 - -;;; tpu-doc.el ends here diff --git a/lisp/vmsx.el b/lisp/vmsx.el deleted file mode 100644 index b3ab41e51f7..00000000000 --- a/lisp/vmsx.el +++ /dev/null @@ -1,144 +0,0 @@ -;;; 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 diff --git a/lisp/word-help.el b/lisp/word-help.el deleted file mode 100644 index 3a7644d7be9..00000000000 --- a/lisp/word-help.el +++ /dev/null @@ -1,970 +0,0 @@ -;;; word-help.el --- keyword help for any language doc'd in TeXinfo. - -;; Copyright (c) 1996 Free Software Foundation, Inc. - -;; Author: Jens T. Berger Thielemann -;; 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: - -;; 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 diff --git a/lispref/buffer-local.texi b/lispref/buffer-local.texi deleted file mode 100644 index 4c4e0ca4362..00000000000 --- a/lispref/buffer-local.texi +++ /dev/null @@ -1,94 +0,0 @@ -@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 diff --git a/nt/config.w95 b/nt/config.w95 deleted file mode 100644 index bcba3475925..00000000000 --- a/nt/config.w95 +++ /dev/null @@ -1,349 +0,0 @@ -/* 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 . */ -#undef SYS_SIGLIST_DECLARED - -/* Define if `struct utimbuf' is declared by . */ -#undef HAVE_STRUCT_UTIMBUF - -/* Define if `struct timeval' is declared by . */ -#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 diff --git a/nt/debug.bat b/nt/debug.bat deleted file mode 100644 index 1cb3a85cfc2..00000000000 --- a/nt/debug.bat +++ /dev/null @@ -1,40 +0,0 @@ -@echo off -set emacs_dir=c:\emacs - -REM Here begins emacs.bat.in - -REM Set OS specific values. -set ARCH_SAVE=%PROCESSOR_ARCHITECTURE% -set PROCESSOR_ARCHITECTURE= -if "%ARCH_SAVE%" == "%PROCESSOR_ARCHITECTURE%" goto win95 -set PROCESSOR_ARCHITECTURE=%ARCH_SAVE% -set SHELL=cmd -goto next - -:win95 -set SHELL=command - -:next - -set EMACSLOADPATH=%emacs_dir%\lisp -set EMACSDATA=%emacs_dir%\etc -set EMACSPATH=%emacs_dir%\bin -set EMACSLOCKDIR=%emacs_dir%\lock -set INFOPATH=%emacs_dir%\info -set EMACSDOC=%emacs_dir%\etc -set TERM=CMD - -REM The variable HOME is used to find the startup file, ~\_emacs. Ideally, -REM this will not be set in this file but should already be set before -REM this file is invoked. If HOME is not set, use some generic default. - -set HOME_SAVE=%HOME% -set HOME_EXISTS=yes -set HOME_DEFAULT=C:\ -set HOME= -if "%HOME%" == "%HOME_SAVE%" set HOME_EXISTS=no -if "%HOME_EXISTS%" == "yes" set HOME=%HOME_SAVE% -if "%HOME_EXISTS%" == "no" set HOME=%HOME_DEFAULT% -if "%HOME_EXISTS%" == "no" echo HOME is not set! Using %HOME% as a default... - -start c:\msdev\bin\msdev -nologo %emacs_dir%\bin\emacs.exe %1 %2 %3 %4 %5 %6 %7 %8 %9 diff --git a/nt/emacs.bat b/nt/emacs.bat deleted file mode 100755 index 14e4893d6df..00000000000 --- a/nt/emacs.bat +++ /dev/null @@ -1,44 +0,0 @@ -@echo off - -REM Change this to the directory into which you installed Emacs: -set emacs_path=C:\emacs - -REM -REM You shouldn't have to change any of the below. -REM - -REM Set OS specific values. -set ARCH_SAVE=%PROCESSOR_ARCHITECTURE% -set PROCESSOR_ARCHITECTURE= -if "%ARCH_SAVE%" == "%PROCESSOR_ARCHITECTURE%" goto win95 -set PROCESSOR_ARCHITECTURE=%ARCH_SAVE% -set SHELL=cmd -goto next - -:win95 -set SHELL=command - -:next - -set EMACSLOADPATH=%emacs_path%\lisp -set EMACSDATA=%emacs_path%\etc -set EMACSPATH=%emacs_path%\bin -set EMACSLOCKDIR=%emacs_path%\lock -set INFOPATH=%emacs_path%\info -set EMACSDOC=%emacs_path%\etc -set TERM=CMD - -REM The variable HOME is used to find the startup file, ~\_emacs. Ideally, -REM this will not be set in this file but should already be set before -REM this file is invoked. If HOME is not set, use some generic default. - -set HOME_SAVE=%HOME% -set HOME_EXISTS=yes -set HOME_DEFAULT=C:\ -set HOME= -if "%HOME%" == "%HOME_SAVE%" set HOME_EXISTS=no -if "%HOME_EXISTS%" == "yes" set HOME=%HOME_SAVE% -if "%HOME_EXISTS%" == "no" set HOME=%HOME_DEFAULT% -if "%HOME_EXISTS%" == "no" echo HOME is not set! Using %HOME% as a default... - -%emacs_path%\bin\emacs.exe %1 %2 %3 %4 %5 %6 %7 %8 %9 diff --git a/nt/install b/nt/install deleted file mode 100644 index d9fbfa343c1..00000000000 --- a/nt/install +++ /dev/null @@ -1,88 +0,0 @@ - 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/. - -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. diff --git a/src/Makefile.in b/src/Makefile.in deleted file mode 100644 index 03faaae332b..00000000000 --- a/src/Makefile.in +++ /dev/null @@ -1,1226 +0,0 @@ -# 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/ //' -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 - diff --git a/src/XTests.c b/src/XTests.c deleted file mode 100644 index 4147ecd35d6..00000000000 --- a/src/XTests.c +++ /dev/null @@ -1,179 +0,0 @@ -#include -#include -#include -#include -#include "XTests.h" -#include - -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); - } -} diff --git a/src/XTests.h b/src/XTests.h deleted file mode 100644 index e91445af7ef..00000000000 --- a/src/XTests.h +++ /dev/null @@ -1,7 +0,0 @@ -#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}; diff --git a/src/convexos.h b/src/convexos.h deleted file mode 100644 index 94cdbf68346..00000000000 --- a/src/convexos.h +++ /dev/null @@ -1,10 +0,0 @@ -/* 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 diff --git a/src/environ.c b/src/environ.c deleted file mode 100644 index 863f40ccd2a..00000000000 --- a/src/environ.c +++ /dev/null @@ -1,316 +0,0 @@ -/* 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)); - } -} - - -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)); -} - - -#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 */ - - -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; -} - - -syms_of_environ () -{ - staticpro (&Venvironment_alist); - defsubr (&Ssetenv); - defsubr (&Sgetenv); -} - -init_environ () -{ - Venvironment_alist = Qnil; - initialize_environment_alist (); -} - -#endif /* MAINTAIN_ENVIRONMENT */ diff --git a/src/m/dos386.h b/src/m/dos386.h deleted file mode 100644 index 1fb38da656f..00000000000 --- a/src/m/dos386.h +++ /dev/null @@ -1,115 +0,0 @@ -/* 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 diff --git a/src/mach2.h b/src/mach2.h deleted file mode 100644 index c941c5ff2cf..00000000000 --- a/src/mach2.h +++ /dev/null @@ -1,48 +0,0 @@ -/* 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 diff --git a/src/old-ralloc.c b/src/old-ralloc.c deleted file mode 100644 index 28562994e9a..00000000000 --- a/src/old-ralloc.c +++ /dev/null @@ -1,1069 +0,0 @@ -/* 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. - */ - -#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) (); - -/* 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; -} - -/* 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--; -} - -/* 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; -} - - -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; -} - -/* 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; -} - - -/* 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); -} - -/* 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. */ -} - -/* 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. */ -} - -/* 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 (); -} - -/* 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 - -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"); -} diff --git a/src/sol2-2.h b/src/sol2-2.h deleted file mode 100644 index 016f75e488a..00000000000 --- a/src/sol2-2.h +++ /dev/null @@ -1,18 +0,0 @@ -/* 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 diff --git a/src/unexelf1.c b/src/unexelf1.c deleted file mode 100644 index a832755167e..00000000000 --- a/src/unexelf1.c +++ /dev/null @@ -1,952 +0,0 @@ -/* 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 - - - */ - -/* 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 - - */ - -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include - -#ifdef __alpha__ -# include /* get COFF debugging symbol table declaration */ -#endif - -#if __GNU_LIBRARY__ - 0 >= 6 -# include /* 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 -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); -} diff --git a/src/unexsgi.c b/src/unexsgi.c deleted file mode 100644 index cd0067f08d9..00000000000 --- a/src/unexsgi.c +++ /dev/null @@ -1,900 +0,0 @@ -/* 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 - - - */ - -/* 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 - - */ - -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include /* for HDRR declaration */ -#include - -#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? - 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); -} diff --git a/src/x11term.h b/src/x11term.h deleted file mode 100644 index 367eeaacc95..00000000000 --- a/src/x11term.h +++ /dev/null @@ -1,24 +0,0 @@ -#include -#include -#include -#include -#include -#include - -#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. */ diff --git a/src/xscrollbar.h b/src/xscrollbar.h deleted file mode 100644 index e1a3f45d247..00000000000 --- a/src/xscrollbar.h +++ /dev/null @@ -1,123 +0,0 @@ -/* 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 */ diff --git a/src/xselect.c.old b/src/xselect.c.old deleted file mode 100644 index 8a3e0443270..00000000000 --- a/src/xselect.c.old +++ /dev/null @@ -1,950 +0,0 @@ -/* 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; - - -/* 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. */ -} - - -/* 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: */ - { - 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; - } - } -} - - -/* 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; -} - - -/* 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; - } -} - - -/* 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 */ diff --git a/tparam.c b/tparam.c deleted file mode 100644 index ae12e72ac7b..00000000000 --- a/tparam.c +++ /dev/null @@ -1,324 +0,0 @@ -/* 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 -#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 -#include -#else -char *malloc (); -char *realloc (); -#endif - -#endif /* not emacs */ - -#ifndef NULL -#define NULL (char *) 0 -#endif - -#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 */ - -/* 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; -} - -#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 */