procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

properly mark Attic files as deleted

Browse source
This commit is contained in:
Ken Raeburn 2001-07-06 08:41:36 +00:00
parent f25cfe5395
commit ad78255132
69 changed files with 0 additions and 37963 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

744
PROBLEMS
View file

@ -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 <Key>BackSpace: string(0x7f)
aixterm*ttyModes: erase ^?
This makes your Backspace key send DEL (ASCII 127).
* You type Control-H (Backspace) expecting to delete characters.
Put `stty dec' in your .login file and your problems will disappear
after a day or two.
The choice of Backspace for erasure was based on confusion, caused by
the fact that backspacing causes erasure (later, when you type another
character) on most display terminals. But it is a mistake. Deletion
of text is not the same thing as backspacing followed by failure to
overprint. I do not wish to propagate this confusion by conforming
to it.
For this reason, I believe `stty dec' is the right mode to use,
and I have designed Emacs to go with that. If there were a thousand
other control characters, I would define Control-h to delete as well;
but there are not very many other control characters, and I think
that providing the most mnemonic possible Help character is more
important than adapting to people who don't use `stty dec'.
If you are obstinate about confusing buggy overprinting with deletion,
you can redefine Backspace in your .emacs file:
(global-set-key "\b" 'delete-backward-char)
You may then wish to put the function help-command on some
other key. I leave to you the task of deciding which key.
* Editing files through RFS gives spurious "file has changed" warnings.
It is possible that a change in Emacs 18.37 gets around this problem,
but in case not, here is a description of how to fix the RFS bug that
causes it.
There was a serious pair of bugs in the handling of the fsync() system
call in the RFS server.
The first is that the fsync() call is handled as another name for the
close() system call (!!). It appears that fsync() is not used by very
many programs; Emacs version 18 does an fsync() before closing files
to make sure that the bits are on the disk.
This is fixed by the enclosed patch to the RFS server.
The second, more serious problem, is that fsync() is treated as a
non-blocking system call (i.e., it's implemented as a message that
gets sent to the remote system without waiting for a reply). Fsync is
a useful tool for building atomic file transactions. Implementing it
as a non-blocking RPC call (when the local call blocks until the sync
is done) is a bad idea; unfortunately, changing it will break the RFS
protocol. No fix was supplied for this problem.
(as always, your line numbers may vary)
% rcsdiff -c -r1.2 serversyscall.c
RCS file: RCS/serversyscall.c,v
retrieving revision 1.2
diff -c -r1.2 serversyscall.c
*** /tmp/,RCSt1003677 Wed Jan 28 15:15:02 1987
--- serversyscall.c Wed Jan 28 15:14:48 1987
***************
*** 163,169 ****
/*
* No return sent for close or fsync!
*/
! if (syscall == RSYS_close || syscall == RSYS_fsync)
proc->p_returnval = deallocate_fd(proc, msg->m_args[0]);
else
{
--- 166,172 ----
/*
* No return sent for close or fsync!
*/
! if (syscall == RSYS_close)
proc->p_returnval = deallocate_fd(proc, msg->m_args[0]);
else
{
* Vax C compiler bugs affecting Emacs.
You may get one of these problems compiling Emacs:
foo.c line nnn: compiler error: no table entry for op STASG
foo.c: fatal error in /lib/ccom
These are due to bugs in the C compiler; the code is valid C.
Unfortunately, the bugs are unpredictable: the same construct
may compile properly or trigger one of these bugs, depending
on what else is in the source file being compiled. Even changes
in header files that should not affect the file being compiled
can affect whether the bug happens. In addition, sometimes files
that compile correctly on one machine get this bug on another machine.
As a result, it is hard for me to make sure this bug will not affect
you. I have attempted to find and alter these constructs, but more
can always appear. However, I can tell you how to deal with it if it
should happen. The bug comes from having an indexed reference to an
array of Lisp_Objects, as an argument in a function call:
Lisp_Object *args;
...
... foo (5, args[i], ...)...
putting the argument into a temporary variable first, as in
Lisp_Object *args;
Lisp_Object tem;
...
tem = args[i];
... foo (r, tem, ...)...
causes the problem to go away.
The `contents' field of a Lisp vector is an array of Lisp_Objects,
so you may see the problem happening with indexed references to that.
* 68000 C compiler problems
Various 68000 compilers have different problems.
These are some that have been observed.
** Using value of assignment expression on union type loses.
This means that x = y = z; or foo (x = z); does not work
if x is of type Lisp_Object.
** "cannot reclaim" error.
This means that an expression is too complicated. You get the correct
line number in the error message. The code must be rewritten with
simpler expressions.
** XCONS, XSTRING, etc macros produce incorrect code.
If temacs fails to run at all, this may be the cause.
Compile this test program and look at the assembler code:
struct foo { char x; unsigned int y : 24; };
lose (arg)
struct foo arg;
{
test ((int *) arg.y);
}
If the code is incorrect, your compiler has this problem.
In the XCONS, etc., macros in lisp.h you must replace (a).u.val with
((a).u.val + coercedummy) where coercedummy is declared as int.
This problem will not happen if the m-...h file for your type
of machine defines NO_UNION_TYPE. That is the recommended setting now.
* C compilers lose on returning unions
I hear that some C compilers cannot handle returning a union type.
Most of the functions in GNU Emacs return type Lisp_Object, which is
defined as a union on some rare architectures.
This problem will not happen if the m-...h file for your type
of machine defines NO_UNION_TYPE.

1429
etc/MACHINES
View file

File diff suppressed because it is too large Load diff

83
etc/TO-DO
View file

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

3380
etc/news.texi
View file

File diff suppressed because it is too large Load diff

1246
etc/termcap.dat
View file

File diff suppressed because it is too large Load diff

353
lib-src/env.c
View file

@ -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 <stdio.h>
extern int execvp ();
char *xmalloc (), *xrealloc ();
char *concat ();
extern char **environ;
char **nenv;
int nenv_size;
char *progname;
void setenv ();
void fatal ();
char *myindex ();
extern char *strerror ();
main (argc, argv, envp)
register int argc;
register char **argv;
char **envp;
{
register char *tem;
progname = argv[0];
argc--;
argv++;
nenv_size = 100;
nenv = (char **) xmalloc (nenv_size * sizeof (char *));
*nenv = (char *) 0;
/* "-" flag means to not inherit parent's environment */
if (argc && !strcmp (*argv, "-"))
{
argc--;
argv++;
}
else
/* Else pass on existing env vars. */
for (; *envp; envp++)
{
tem = myindex (*envp, '=');
if (tem)
{
*tem = '\000';
setenv (*envp, tem + 1);
}
}
while (argc > 0)
{
tem = myindex (*argv, '=');
if (tem)
/* If arg contains a "=" it specifies to set a variable */
{
*tem = '\000';
setenv (*argv, tem + 1);
argc--;
argv++;
continue;
}
if (**argv != '-')
/* Remaining args are program name and args to pass it */
break;
if (argc < 2)
fatal ("no argument for `%s' option", *argv);
if (!strcmp (*argv, "-u")
|| !strcmp (*argv, "-unset"))
/* Unset a variable */
{
argc--;
argv++;
setenv (*argv, (char *) 0);
argc--;
argv++;
}
else if (!strcmp (*argv, "-s") ||
!strcmp (*argv, "-set"))
/* Set a variable */
{
argc--;
argv++;
tem = *argv;
if (argc < 2)
fatal ("no value specified for variable \"%s\"", tem);
argc--;
argv++;
setenv (tem, *argv);
argc--;
argv++;
}
else if (!strcmp (*argv, "-") || !strcmp (*argv, "--"))
{
argc--;
argv++;
break;
}
else
{
fatal ("unrecognized option `%s'", *argv);
}
}
/* If no program specified print the environment and exit */
if (argc <= 0)
{
while (*nenv)
printf ("%s\n", *nenv++);
exit (0);
}
else
{
extern int errno;
extern char *strerror ();
environ = nenv;
(void) execvp (*argv, argv);
fprintf (stderr, "%s: cannot execute `%s': %s\n",
progname, *argv, strerror (errno));
exit (errno != 0 ? errno : 1);
}
}
void
setenv (var, val)
register char *var, *val;
{
register char **e;
int len = strlen (var);
{
register char *tem = myindex (var, '=');
if (tem)
fatal ("environment variable names can not contain `=': %s", var);
else if (*var == '\000')
fatal ("zero-length environment variable name specified");
}
for (e = nenv; *e; e++)
if (!strncmp (var, *e, len) && (*e)[len] == '=')
{
if (val)
goto set;
else
do
{
*e = *(e + 1);
} while (*e++);
return;
}
if (!val)
return; /* Nothing to unset */
len = e - nenv;
if (len + 1 >= nenv_size)
{
nenv_size += 100;
nenv = (char **) xrealloc (nenv, nenv_size * sizeof (char *));
e = nenv + len;
}
set:
val = concat (var, "=", val);
if (*e)
free (*e);
else
*(e + 1) = (char *) 0;
*e = val;
return;
}
void
fatal (msg, arg1, arg2)
char *msg, *arg1, *arg2;
{
fprintf (stderr, "%s: ", progname);
fprintf (stderr, msg, arg1, arg2);
putc ('\n', stderr);
exit (1);
}
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 */

155
lib-src/etags-vmslib.c
View file

@ -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 <stdio.h>
typedef char tbool;
/* This is a BUG! ANY arbitrary limit is a BUG!
Won't someone please fix this? */
#define MAX_FILE_SPEC_LEN 255
typedef struct {
short curlen;
char body[MAX_FILE_SPEC_LEN + 1];
} vspec;
#define EOS '\0'
#define NO 0
#define YES 1
#define NULL 0
/* gfnames - return in successive calls the
name of each file specified by all the remaining args in the command-line
expanding wild cards and
stepping over arguments when they have been processed completely
*/
char*
gfnames(pac, pav, p_error)
int *pac;
char **pav[];
tbool *p_error;
{
static vspec filename = {MAX_FILE_SPEC_LEN, "\0"};
short fn_exp();
while (1)
if (*pac == 0)
{
*p_error = NO;
return(NULL);
}
else switch(fn_exp(&filename, **pav))
{
case 1:
*p_error = NO;
return(filename.body);
break;
case 0:
--*pac;
++*pav;
break;
default:
*p_error = YES;
return(filename.body);
break;
}
}
/* fn_exp - expand specification of list of file names
returning in each successive call the next filename matching the input
spec. The function expects that each in_spec passed
to it will be processed to completion; in particular, up to and
including the call following that in which the last matching name
is returned, the function ignores the value of in_spec, and will
only start processing a new spec with the following call.
If an error occurs, on return out_spec contains the value
of in_spec when the error occurred.
With each successive filename returned in out_spec, the
function's return value is one. When there are no more matching
names the function returns zero. If on the first call no file
matches in_spec, or there is any other error, -1 is returned.
*/
#include <rmsdef.h>
#include <descrip.h>
#define OUTSIZE MAX_FILE_SPEC_LEN
short
fn_exp(out, in)
vspec *out;
char *in;
{
static long context = 0;
static struct dsc$descriptor_s o;
static struct dsc$descriptor_s i;
static tbool pass1 = YES;
long status;
short retval;
if (pass1)
{
pass1 = NO;
o.dsc$a_pointer = (char *) out;
o.dsc$w_length = (short)OUTSIZE;
i.dsc$a_pointer = in;
i.dsc$w_length = (short)strlen(in);
i.dsc$b_dtype = DSC$K_DTYPE_T;
i.dsc$b_class = DSC$K_CLASS_S;
o.dsc$b_dtype = DSC$K_DTYPE_VT;
o.dsc$b_class = DSC$K_CLASS_VS;
}
if ( (status = lib$find_file(&i, &o, &context, 0, 0)) == RMS$_NORMAL)
{
out->body[out->curlen] = EOS;
return(1);
}
else if (status == RMS$_NMF)
retval = 0;
else
{
strcpy(out->body, in);
retval = -1;
}
lib$find_file_end(&context);
pass1 = YES;
return(retval);
}
#ifndef OLD /* Newer versions of VMS do provide `system'. */
system(cmd)
char *cmd;
{
fprintf(stderr, "system() function not implemented under VMS\n");
}
#endif
#define VERSION_DELIM ';'
char *massage_name(s)
char *s;
{
char *start = s;
for ( ; *s; s++)
if (*s == VERSION_DELIM)
{
*s = EOS;
break;
}
else
*s = tolower(*s);
return(start);
}

105
lib-src/make-path.c
View file

@ -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 <sys/types.h>
#include <sys/stat.h>
#include <stdio.h>
#include <errno.h>
extern int errno;
char *prog_name;
/* Create directory DIRNAME if it does not exist already.
Then give permission for everyone to read and search it.
Return 0 if successful, 1 if not. */
int
touchy_mkdir (dirname)
char *dirname;
{
struct stat buf;
/* If DIRNAME already exists and is a directory, don't create. */
if (! (stat (dirname, &buf) >= 0
&& (buf.st_mode & S_IFMT) == S_IFDIR))
{
/* Otherwise, try to make it. If DIRNAME exists but isn't a directory,
this will signal an error. */
if (mkdir (dirname, 0777) < 0)
{
fprintf (stderr, "%s: ", prog_name);
perror (dirname);
return 1;
}
}
/* Make sure everyone can look at this directory. */
if (stat (dirname, &buf) < 0)
{
fprintf (stderr, "%s: ", prog_name);
perror (dirname);
return 1;
}
if (chmod (dirname, 0555 | (buf.st_mode & 0777)) < 0)
{
fprintf (stderr, "%s: ", prog_name);
perror (dirname);
}
return 0;
}
int
main (argc, argv)
int argc;
char **argv;
{
prog_name = *argv;
for (argc--, argv++; argc > 0; argc--, argv++)
{
char *dirname = *argv;
int i;
/* Stop at each slash in dirname and try to create the directory.
Skip any initial slash. */
for (i = (dirname[0] == '/') ? 1 : 0; dirname[i]; i++)
if (dirname[i] == '/')
{
dirname[i] = '\0';
if (touchy_mkdir (dirname) < 0)
goto next_dirname;
dirname[i] = '/';
}
touchy_mkdir (dirname);
next_dirname:
;
}
return 0;
}

679
lib-src/rcs2log
View file

@ -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 "LOGIN<tab>FULLNAME<tab>MAILADDR" Assume LOGIN has FULLNAME and MAILADDR.
-v Append RCS revision to file names in log lines.
--help Output help.
--version Output version number.
Report bugs to <bug-gnu-emacs@gnu.org>.'
Id='$Id: rcs2log,v 1.46 2001/01/02 18:50:14 eggert Exp $'
# Copyright 1992, 93, 94, 95, 96, 97, 1998 Free Software Foundation, Inc.
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2, or (at your option)
# any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; see the file COPYING. If not, write to the
# Free Software Foundation, Inc., 59 Temple Place - Suite 330,
# Boston, MA 02111-1307, USA.
Copyright='Copyright 1998 Free Software Foundation, Inc.
This program comes with NO WARRANTY, to the extent permitted by law.
You may redistribute copies of this program
under the terms of the GNU General Public License.
For more information about these matters, see the files named COPYING.
Author: Paul Eggert <eggert@twinsun.com>'
tab=' '
nl='
'
# Parse options.
# defaults
: ${AWK=awk}
: ${TMPDIR=/tmp}
changelog=ChangeLog # change log file name
datearg= # rlog date option
hostname= # name of local host (if empty, will deduce it later)
indent=8 # indent of log line
length=79 # suggested max width of log line
logins= # login names for people we know fullnames and mailaddrs of
loginFullnameMailaddrs= # login<tab>fullname<tab>mailaddr triplets
logTZ= # time zone for log dates (if empty, use local time)
recursive= # t if we want recursive rlog
revision= # t if we want revision numbers
rlog_options= # options to pass to rlog
tabwidth=8 # width of horizontal tab
while :
do
case $1 in
-c) changelog=${2?}; shift;;
-i) indent=${2?}; shift;;
-h) hostname=${2?}; shift;;
-l) length=${2?}; shift;;
-[nu]) # -n is obsolescent; it is replaced by -u.
case $1 in
-n) case ${2?}${3?}${4?} in
*"$tab"* | *"$nl"*)
echo >&2 "$0: -n '$2' '$3' '$4': tabs, newlines not allowed"
exit 1
esac
case $loginFullnameMailaddrs in
'') loginFullnameMailaddrs=$2$tab$3$tab$4;;
?*) loginFullnameMailaddrs=$loginFullnameMailaddrs$nl$2$tab$3$tab$4
esac
shift; shift; shift;;
-u)
# If $2 is not tab-separated, use colon for separator.
case ${2?} in
*"$nl"*)
echo >&2 "$0: -u '$2': newlines not allowed"
exit 1;;
*"$tab"*)
t=$tab;;
*)
t=:
esac
case $2 in
*"$t"*"$t"*"$t"*)
echo >&2 "$0: -u '$2': too many fields"
exit 1;;
*"$t"*"$t"*)
;;
*)
echo >&2 "$0: -u '$2': not enough fields"
exit 1
esac
case $loginFullnameMailaddrs in
'') loginFullnameMailaddrs=$2;;
?*) loginFullnameMailaddrs=$loginFullnameMailaddrs$nl$2
esac
shift
esac
case $logins in
'') logins=$login;;
?*) logins=$logins$nl$login
esac
;;
-r)
case $rlog_options in
'') rlog_options=${2?};;
?*) rlog_options=$rlog_options$nl${2?}
esac
shift;;
-R) recursive=t;;
-t) tabwidth=${2?}; shift;;
-v) revision=t;;
--version)
set $Id
rcs2logVersion=$3
echo >&2 "rcs2log (GNU Emacs) $rcs2logVersion$nl$Copyright"
exit 0;;
-*) echo >&2 "Usage: $0 [OPTION]... [FILE ...]$nl$Help"
case $1 in
--help) exit 0;;
*) exit 1
esac;;
*) break
esac
shift
done
month_data='
m[0]="Jan"; m[1]="Feb"; m[2]="Mar"
m[3]="Apr"; m[4]="May"; m[5]="Jun"
m[6]="Jul"; m[7]="Aug"; m[8]="Sep"
m[9]="Oct"; m[10]="Nov"; m[11]="Dec"
'
# Put rlog output into $rlogout.
# If no rlog options are given,
# log the revisions checked in since the first ChangeLog entry.
# Since ChangeLog is only by date, some of these revisions may be duplicates of
# what's already in ChangeLog; it's the user's responsibility to remove them.
case $rlog_options in
'')
if test -s "$changelog"
then
e='
/^[0-9]+-[0-9][0-9]-[0-9][0-9]/{
# ISO 8601 date
print $1
exit
}
/^... ... [ 0-9][0-9] [ 0-9][0-9]:[0-9][0-9]:[0-9][0-9] [0-9]+ /{
# old-fashioned date and time (Emacs 19.31 and earlier)
'"$month_data"'
year = $5
for (i=0; i<=11; i++) if (m[i] == $2) break
dd = $3
printf "%d-%02d-%02d\n", year, i+1, dd
exit
}
'
d=`$AWK "$e" <"$changelog"` || exit
case $d in
?*) datearg="-d>$d"
esac
fi
esac
# Use TZ specified by ChangeLog local variable, if any.
if test -s "$changelog"
then
extractTZ='
/^.*change-log-time-zone-rule['"$tab"' ]*:['"$tab"' ]*"\([^"]*\)".*/{
s//\1/; p; q
}
/^.*change-log-time-zone-rule['"$tab"' ]*:['"$tab"' ]*t.*/{
s//UTC0/; p; q
}
'
logTZ=`tail "$changelog" | sed -n "$extractTZ"`
case $logTZ in
?*) TZ=$logTZ; export TZ
esac
fi
# If CVS is in use, examine its repository, not the normal RCS files.
if test ! -f CVS/Repository
then
rlog=rlog
repository=
else
rlog='cvs -q log'
repository=`sed 1q <CVS/Repository` || exit
test ! -f CVS/Root || CVSROOT=`cat <CVS/Root` || exit
case $CVSROOT in
*:/*)
# remote repository
;;
*)
# local repository
case $repository in
/*) ;;
*) repository=${CVSROOT?}/$repository
esac
if test ! -d "$repository"
then
echo >&2 "$0: $repository: bad repository (see CVS/Repository)"
exit 1
fi
esac
fi
# Use $rlog's -zLT option, if $rlog supports it.
case `$rlog -zLT 2>&1` in
*' option'*) ;;
*)
case $rlog_options in
'') rlog_options=-zLT;;
?*) rlog_options=-zLT$nl$rlog_options
esac
esac
# With no arguments, examine all files under the RCS directory.
case $# in
0)
case $repository in
'')
oldIFS=$IFS
IFS=$nl
case $recursive in
t)
RCSdirs=`find . -name RCS -type d -print`
filesFromRCSfiles='s|,v$||; s|/RCS/|/|; s|^\./||'
files=`
{
case $RCSdirs in
?*) find $RCSdirs \
-type f \
! -name '*_' \
! -name ',*,' \
! -name '.*_' \
! -name .rcsfreeze.log \
! -name .rcsfreeze.ver \
-print
esac
find . -name '*,v' -print
} |
sort -u |
sed "$filesFromRCSfiles"
`;;
*)
files=
for file in RCS/.* RCS/* .*,v *,v
do
case $file in
RCS/. | RCS/.. | RCS/,*, | RCS/*_) continue;;
RCS/.rcsfreeze.log | RCS/.rcsfreeze.ver) continue;;
RCS/.\* | RCS/\* | .\*,v | \*,v) test -f "$file" || continue;;
RCS/*,v | RCS/.*,v) ;;
RCS/* | RCS/.*) test -f "$file" || continue
esac
case $files in
'') files=$file;;
?*) files=$files$nl$file
esac
done
case $files in
'') exit 0
esac
esac
set x $files
shift
IFS=$oldIFS
esac
esac
logdir=$TMPDIR/rcs2log$$
llogout=$logdir/l
rlogout=$logdir/r
trap exit 1 2 13 15
trap "rm -fr $logdir 2>/dev/null" 0
(umask 077 && exec mkdir $logdir) || exit
case $datearg in
?*) $rlog $rlog_options "$datearg" ${1+"$@"} >$rlogout;;
'') $rlog $rlog_options ${1+"$@"} >$rlogout
esac || exit
# Get the full name of each author the logs mention, and set initialize_fullname
# to awk code that initializes the `fullname' awk associative array.
# Warning: foreign authors (i.e. not known in the passwd file) are mishandled;
# you have to fix the resulting output by hand.
initialize_fullname=
initialize_mailaddr=
case $loginFullnameMailaddrs in
?*)
case $loginFullnameMailaddrs in
*\"* | *\\*)
sed 's/["\\]/\\&/g' >$llogout <<EOF || exit
$loginFullnameMailaddrs
EOF
loginFullnameMailaddrs=`cat $llogout`
esac
oldIFS=$IFS
IFS=$nl
for loginFullnameMailaddr in $loginFullnameMailaddrs
do
case $loginFullnameMailaddr in
*"$tab"*) IFS=$tab;;
*) IFS=:
esac
set x $loginFullnameMailaddr
login=$2
fullname=$3
mailaddr=$4
initialize_fullname="$initialize_fullname
fullname[\"$login\"] = \"$fullname\""
initialize_mailaddr="$initialize_mailaddr
mailaddr[\"$login\"] = \"$mailaddr\""
done
IFS=$oldIFS
esac
case $llogout in
?*) sort -u -o $llogout <<EOF || exit
$logins
EOF
esac
output_authors='/^date: / {
if ($2 ~ /^[0-9]*[-\/][0-9][0-9][-\/][0-9][0-9]$/ && $3 ~ /^[0-9][0-9]:[0-9][0-9]:[0-9][0-9][-+0-9:]*;$/ && $4 == "author:" && $5 ~ /^[^;]*;$/) {
print substr($5, 1, length($5)-1)
}
}'
authors=`
$AWK "$output_authors" <$rlogout |
case $llogout in
'') sort -u;;
?*) sort -u | comm -23 - $llogout
esac
`
case $authors in
?*)
cat >$llogout <<EOF || exit
$authors
EOF
initialize_author_script='s/["\\]/\\&/g; s/.*/author[\"&\"] = 1/'
initialize_author=`sed -e "$initialize_author_script" <$llogout`
awkscript='
BEGIN {
alphabet = "abcdefghijklmnopqrstuvwxyz"
ALPHABET = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
'"$initialize_author"'
}
{
if (author[$1]) {
fullname = $5
if (fullname ~ /[0-9]+-[^(]*\([0-9]+\)$/) {
# Remove the junk from fullnames like "0000-Admin(0000)".
fullname = substr(fullname, index(fullname, "-") + 1)
fullname = substr(fullname, 1, index(fullname, "(") - 1)
}
if (fullname ~ /,[^ ]/) {
# Some sites put comma-separated junk after the fullname.
# Remove it, but leave "Bill Gates, Jr" alone.
fullname = substr(fullname, 1, index(fullname, ",") - 1)
}
abbr = index(fullname, "&")
if (abbr) {
a = substr($1, 1, 1)
A = a
i = index(alphabet, a)
if (i) A = substr(ALPHABET, i, 1)
fullname = substr(fullname, 1, abbr-1) A substr($1, 2) substr(fullname, abbr+1)
}
# Quote quotes and backslashes properly in full names.
# Do not use gsub; traditional awk lacks it.
quoted = ""
rest = fullname
for (;;) {
p = index(rest, "\\")
q = index(rest, "\"")
if (p) {
if (q && q<p) p = q
} else {
if (!q) break
p = q
}
quoted = quoted substr(rest, 1, p-1) "\\" substr(rest, p, 1)
rest = substr(rest, p+1)
}
printf "fullname[\"%s\"] = \"%s%s\"\n", $1, quoted, rest
author[$1] = 0
}
}
'
initialize_fullname=`
{
(getent passwd $authors) ||
(
cat /etc/passwd
for author in $authors
do NIS_PATH= nismatch $author passwd.org_dir
done
ypmatch $authors passwd
)
} 2>/dev/null |
$AWK -F: "$awkscript"
`$initialize_fullname
esac
# Function to print a single log line.
# We don't use awk functions, to stay compatible with old awk versions.
# `Log' is the log message (with \n replaced by \001).
# `files' contains the affected files.
printlogline='{
# Following the GNU coding standards, rewrite
# * file: (function): comment
# to
# * file (function): comment
if (Log ~ /^\([^)]*\): /) {
i = index(Log, ")")
files = files " " substr(Log, 1, i)
Log = substr(Log, i+3)
}
# If "label: comment" is too long, break the line after the ":".
sep = " "
if ('"$length"' <= '"$indent"' + 1 + length(files) + index(Log, SOH)) sep = "\n" indent_string
# Print the label.
printf "%s*%s:", indent_string, files
# Print each line of the log, transliterating \001 to \n.
while ((i = index(Log, SOH)) != 0) {
logline = substr(Log, 1, i-1)
if (logline ~ /[^'"$tab"' ]/) {
printf "%s%s\n", sep, logline
} else {
print ""
}
sep = indent_string
Log = substr(Log, i+1)
}
}'
# Pattern to match the `revision' line of rlog output.
rlog_revision_pattern='^revision [0-9]+\.[0-9]+(\.[0-9]+\.[0-9]+)*(['"$tab"' ]+locked by: [^'"$tab"' $,.0-9:;@]*[^'"$tab"' $,:;@][^'"$tab"' $,.0-9:;@]*;)?['"$tab"' ]*$'
case $hostname in
'')
hostname=`(
hostname || uname -n || uuname -l || cat /etc/whoami
) 2>/dev/null` || {
echo >&2 "$0: cannot deduce hostname"
exit 1
}
case $hostname in
*.*) ;;
*)
domainname=`(domainname) 2>/dev/null` &&
case $domainname in
*.*) hostname=$hostname.$domainname
esac
esac
esac
# Process the rlog output, generating ChangeLog style entries.
# First, reformat the rlog output so that each line contains one log entry.
# Transliterate \n to \001 so that multiline entries fit on a single line.
# Discard irrelevant rlog output.
$AWK <$rlogout '
BEGIN { repository = "'"$repository"'" }
/^RCS file:/ {
if (repository != "") {
filename = $3
if (substr(filename, 1, length(repository) + 1) == repository "/") {
filename = substr(filename, length(repository) + 2)
}
if (filename ~ /,v$/) {
filename = substr(filename, 1, length(filename) - 2)
}
if (filename ~ /(^|\/)Attic\/[^\/]*$/) {
i = length(filename)
while (substr(filename, i, 1) != "/") i--
filename = substr(filename, 1, i - 6) substr(filename, i + 1)
}
}
rev = "?"
}
/^Working file:/ { if (repository == "") filename = $3 }
/'"$rlog_revision_pattern"'/, /^(-----------*|===========*)$/ {
line = $0
if (line ~ /'"$rlog_revision_pattern"'/) {
rev = $2
next
}
if (line ~ /^date: [0-9][- +\/0-9:]*;/) {
date = $2
if (date ~ /\//) {
# This is a traditional RCS format date YYYY/MM/DD.
# Replace "/"s with "-"s to get ISO format.
newdate = ""
while ((i = index(date, "/")) != 0) {
newdate = newdate substr(date, 1, i-1) "-"
date = substr(date, i+1)
}
date = newdate date
}
time = substr($3, 1, length($3) - 1)
author = substr($5, 1, length($5)-1)
printf "%s %s %s %s %s %c", filename, rev, date, time, author, 1
rev = "?"
next
}
if (line ~ /^branches: /) { next }
if (line ~ /^(-----------*|===========*)$/) { print ""; next }
if (line == "Initial revision" || line ~ /^file .+ was initially added on branch .+\.$/) {
line = "New file."
}
printf "%s%c", line, 1
}
' |
# Now each line is of the form
# FILENAME REVISION YYYY-MM-DD HH:MM:SS[+-TIMEZONE] AUTHOR \001LOG
# where \001 stands for a carriage return,
# and each line of the log is terminated by \001 instead of \n.
# Sort the log entries, first by date+time (in reverse order),
# then by author, then by log entry, and finally by file name and revision
# (just in case).
sort +2 -4r +4 +0 |
# Finally, reformat the sorted log entries.
$AWK '
BEGIN {
logTZ = "'"$logTZ"'"
revision = "'"$revision"'"
# Some awk variants do not understand "\001", so we have to
# put the char directly in the file.
SOH="" # <-- There is a single SOH (octal code 001) here.
# Initialize the fullname and mailaddr associative arrays.
'"$initialize_fullname"'
'"$initialize_mailaddr"'
# Initialize indent string.
indent_string = ""
i = '"$indent"'
if (0 < '"$tabwidth"')
for (; '"$tabwidth"' <= i; i -= '"$tabwidth"')
indent_string = indent_string "\t"
while (1 <= i--)
indent_string = indent_string " "
}
{
newlog = substr($0, 1 + index($0, SOH))
# Ignore log entries prefixed by "#".
if (newlog ~ /^#/) { next }
if (Log != newlog || date != $3 || author != $5) {
# The previous log and this log differ.
# Print the old log.
if (date != "") '"$printlogline"'
# Logs that begin with "{clumpname} " should be grouped together,
# and the clumpname should be removed.
# Extract the new clumpname from the log header,
# and use it to decide whether to output a blank line.
newclumpname = ""
sep = "\n"
if (date == "") sep = ""
if (newlog ~ /^\{[^'"$tab"' }]*}['"$tab"' ]/) {
i = index(newlog, "}")
newclumpname = substr(newlog, 1, i)
while (substr(newlog, i+1) ~ /^['"$tab"' ]/) i++
newlog = substr(newlog, i+1)
if (clumpname == newclumpname) sep = ""
}
printf sep
clumpname = newclumpname
# Get ready for the next log.
Log = newlog
if (files != "")
for (i in filesknown)
filesknown[i] = 0
files = ""
}
if (date != $3 || author != $5) {
# The previous date+author and this date+author differ.
# Print the new one.
date = $3
time = $4
author = $5
zone = ""
if (logTZ && ((i = index(time, "-")) || (i = index(time, "+"))))
zone = " " substr(time, i)
# Print "date[ timezone] fullname <email address>".
# Get fullname and email address from associative arrays;
# default to author and author@hostname if not in arrays.
if (fullname[author])
auth = fullname[author]
else
auth = author
printf "%s%s %s ", date, zone, auth
if (mailaddr[author])
printf "<%s>\n\n", mailaddr[author]
else
printf "<%s@%s>\n\n", author, "'"$hostname"'"
}
if (! filesknown[$1]) {
filesknown[$1] = 1
if (files == "") files = " " $1
else files = files ", " $1
if (revision && $2 != "?") files = files " " $2
}
}
END {
# Print the last log.
if (date != "") {
'"$printlogline"'
printf "\n"
}
}
' &&
# Exit successfully.
exec rm -fr $logdir
# Local Variables:
# tab-width:4
# End:

368
lib-src/timer.c
View file

@ -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 <stdio.h>
#include <signal.h>
#include <errno.h>
#include <sys/types.h> /* time_t */
#include <../src/config.h>
#undef read
#ifdef LINUX
/* Perhaps this is correct unconditionally. */
#undef signal
#endif
#ifdef _CX_UX
/* I agree with the comment above, this probably should be unconditional (it
* is already unconditional in a couple of other files in this directory),
* but in the spirit of minimizing the effects of my port, I am making it
* conditional on _CX_UX.
*/
#undef signal
#endif
extern int errno;
extern char *strerror ();
extern time_t time ();
/*
* The field separator for input. This character shouldn't occur in dates,
* and should be printable so event strings are readable by people.
*/
#define FS '@'
struct event
{
char *token;
time_t reply_at;
};
int events_size; /* How many slots have we allocated? */
int num_events; /* How many are actually scheduled? */
struct event *events; /* events[0 .. num_events-1] are the
valid events. */
char *pname; /* program name for error messages */
/* This buffer is used for reading commands.
We make it longer when necessary, but we never free it. */
char *buf;
/* This is the allocated size of buf. */
int buf_size;
/* Non-zero means don't handle an alarm now;
instead, just set alarm_deferred if an alarm happens.
We set this around parts of the program that call malloc and free. */
int defer_alarms;
/* Non-zero if an alarm came in during the reading of a command. */
int alarm_deferred;
/* 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 */

53
lib-src/wakeup.c
View file

@ -1,53 +0,0 @@
/* Program to produce output at regular intervals. */
#ifdef HAVE_CONFIG_H
#include <config.h>
#endif
#include <stdio.h>
#include <sys/types.h>
#ifdef TIME_WITH_SYS_TIME
#include <sys/time.h>
#include <time.h>
#else
#ifdef HAVE_SYS_TIME_H
#include <sys/time.h>
#else
#include <time.h>
#endif
#endif
struct tm *localtime ();
void
main (argc, argv)
int argc;
char **argv;
{
int period = 60;
time_t when;
struct tm *tp;
if (argc > 1)
period = atoi (argv[1]);
while (1)
{
/* Make sure wakeup stops when Emacs goes away. */
if (getppid () == 1)
exit (0);
printf ("Wake up!\n");
fflush (stdout);
/* If using a period of 60, produce the output when the minute
changes. */
if (period == 60)
{
time (&when);
tp = localtime (&when);
sleep (60 - tp->tm_sec);
}
else
sleep (period);
}
}

734
lisp/ada.el
View file

@ -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 <broman@bugs.nosc.mil>
;; Keywords: languages
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;;; Commentary:
;; Created May 1987.
;; (borrows heavily from Mick Jordan's Modula-2 package for GNU,
;; as modified by Peter Robinson, Michael Schmidt, and Tom Perrine.)
;;; Code:
(defvar ada-mode-syntax-table nil
"Syntax table in use in Ada-mode buffers.")
(let ((table (make-syntax-table)))
(modify-syntax-entry ?_ "_" table)
(modify-syntax-entry ?\# "_" table)
(modify-syntax-entry ?\( "()" table)
(modify-syntax-entry ?\) ")(" table)
(modify-syntax-entry ?$ "." table)
(modify-syntax-entry ?* "." table)
(modify-syntax-entry ?/ "." table)
(modify-syntax-entry ?+ "." table)
(modify-syntax-entry ?- ". 12" table)
(modify-syntax-entry ?= "." table)
(modify-syntax-entry ?\& "." table)
(modify-syntax-entry ?\| "." table)
(modify-syntax-entry ?< "." table)
(modify-syntax-entry ?> "." table)
(modify-syntax-entry ?\[ "." table)
(modify-syntax-entry ?\] "." table)
(modify-syntax-entry ?\{ "." table)
(modify-syntax-entry ?\} "." table)
(modify-syntax-entry ?. "." table)
(modify-syntax-entry ?\\ "." table)
(modify-syntax-entry ?: "." table)
(modify-syntax-entry ?\; "." table)
(modify-syntax-entry ?\' "." table)
(modify-syntax-entry ?\" "\"" table)
(modify-syntax-entry ?\n ">" table)
(setq ada-mode-syntax-table table))
;; Strings are a real pain in Ada because both ' and " can appear in a
;; non-string quote context (the former as an operator, the latter as a
;; character string). We follow the least losing solution, in which only " is
;; a string quote. Therefore a character string of the form '"' will throw
;; fontification off on the wrong track.
(defconst ada-font-lock-keywords-1
(list
;;
;; Function, package (body), pragma, procedure, task (body) plus name.
(list (concat "\\<\\("
"function\\|"
"p\\(ackage\\(\\|[ \t]+body\\)\\|r\\(agma\\|ocedure\\)\\)\\|"
"task\\(\\|[ \t]+body\\)"
"\\)\\>[ \t]*\\(\\sw+\\(\\.\\sw*\\)*\\)?")
'(1 font-lock-keyword-face) '(6 font-lock-function-name-face nil t)))
"For consideration as a value of `ada-font-lock-keywords'.
This does fairly subdued highlighting.")
(defconst ada-font-lock-keywords-2
(append ada-font-lock-keywords-1
(list
;;
;; Main keywords, except those treated specially below.
(concat "\\<\\("
; ("abort" "abs" "abstract" "accept" "access" "aliased" "all"
; "and" "array" "at" "begin" "case" "declare" "delay" "delta"
; "digits" "do" "else" "elsif" "entry" "exception" "exit" "for"
; "generic" "if" "in" "is" "limited" "loop" "mod" "not"
; "null" "or" "others" "private" "protected"
; "range" "record" "rem" "renames" "requeue" "return" "reverse"
; "select" "separate" "tagged" "task" "terminate" "then" "until"
; "while" "xor")
"a\\(b\\(ort\\|s\\(\\|tract\\)\\)\\|cce\\(pt\\|ss\\)\\|"
"l\\(iased\\|l\\)\\|nd\\|rray\\|t\\)\\|begin\\|case\\|"
"d\\(e\\(clare\\|l\\(ay\\|ta\\)\\)\\|igits\\|o\\)\\|"
"e\\(ls\\(e\\|if\\)\\|ntry\\|x\\(ception\\|it\\)\\)\\|for\\|"
"generic\\|i[fns]\\|l\\(imited\\|oop\\)\\|mod\\|n\\(ot\\|ull\\)\\|"
"o\\(r\\|thers\\)\\|pr\\(ivate\\|otected\\)\\|"
"r\\(ange\\|e\\(cord\\|m\\|names\\|queue\\|turn\\|verse\\)\\)\\|"
"se\\(lect\\|parate\\)\\|"
"t\\(a\\(gged\\|sk\\)\\|erminate\\|hen\\)\\|until\\|while\\|xor"
"\\)\\>")
;;
;; Anything following end and not already fontified is a body name.
'("\\<\\(end\\)\\>[ \t]*\\(\\sw+\\)?"
(1 font-lock-keyword-face) (2 font-lock-function-name-face nil t))
; ;;
; ;; Variable name plus optional keywords followed by a type name. Slow.
; (list (concat "\\<\\(\\sw+\\)\\>[ \t]*:"
; "[ \t]*\\(constant\\|in\\|in[ \t]+out\\|out\\)?[ \t]*"
; "\\(\\sw+\\(\\.\\sw*\\)*\\)?")
; '(1 font-lock-variable-name-face)
; '(2 font-lock-keyword-face nil t) '(3 font-lock-type-face nil t))
;;
;; Optional keywords followed by a type name.
(list (concat ":[ \t]*\\<\\(constant\\|in\\|in[ \t]+out\\|out\\)\\>?[ \t]*"
"\\(\\sw+\\(\\.\\sw*\\)*\\)?")
'(1 font-lock-keyword-face nil t) '(2 font-lock-type-face nil t))
;;
;; Keywords followed by a type or function name.
(list (concat "\\<\\("
"new\\|of\\|subtype\\|type"
"\\)\\>[ \t]*\\(\\sw+\\(\\.\\sw*\\)*\\)?[ \t]*\\((\\)?")
'(1 font-lock-keyword-face)
'(2 (if (match-beginning 4)
font-lock-function-name-face
font-lock-type-face) nil t))
;;
;; Keywords followed by a reference.
(list (concat "\\<\\(goto\\|raise\\|use\\|when\\|with\\)\\>"
"[ \t]*\\(\\sw+\\(\\.\\sw*\\)*\\)?")
'(1 font-lock-keyword-face) '(2 font-lock-reference-face nil t))
;;
;; Goto tags.
'("<<\\(\\sw+\\(\\.\\sw*\\)*\\)>>" 1 font-lock-reference-face)
))
"For consideration as a value of `ada-font-lock-keywords'.
This does a lot more highlighting.")
(defvar ada-font-lock-keywords (if font-lock-maximum-decoration
ada-font-lock-keywords-2
ada-font-lock-keywords-1)
"Additional expressions to highlight in Ada mode.")
(defvar ada-mode-map nil
"Keymap used in Ada mode.")
(let ((map (make-sparse-keymap)))
(define-key map "\C-m" 'ada-newline)
(define-key map "\C-?" 'backward-delete-char-untabify)
(define-key map "\C-i" 'ada-tab)
(define-key map "\C-c\C-i" 'ada-untab)
(define-key map "\C-c<" 'ada-backward-to-same-indent)
(define-key map "\C-c>" 'ada-forward-to-same-indent)
(define-key map "\C-ch" 'ada-header)
(define-key map "\C-c(" 'ada-paired-parens)
(define-key map "\C-c-" 'ada-inline-comment)
(define-key map "\C-c\C-a" 'ada-array)
(define-key map "\C-cb" 'ada-exception-block)
(define-key map "\C-cd" 'ada-declare-block)
(define-key map "\C-c\C-e" 'ada-exception)
(define-key map "\C-cc" 'ada-case)
(define-key map "\C-c\C-k" 'ada-package-spec)
(define-key map "\C-ck" 'ada-package-body)
(define-key map "\C-c\C-p" 'ada-procedure-spec)
(define-key map "\C-cp" 'ada-subprogram-body)
(define-key map "\C-c\C-f" 'ada-function-spec)
(define-key map "\C-cf" 'ada-for-loop)
(define-key map "\C-cl" 'ada-loop)
(define-key map "\C-ci" 'ada-if)
(define-key map "\C-cI" 'ada-elsif)
(define-key map "\C-ce" 'ada-else)
(define-key map "\C-c\C-v" 'ada-private)
(define-key map "\C-c\C-r" 'ada-record)
(define-key map "\C-c\C-s" 'ada-subtype)
(define-key map "\C-cs" 'ada-separate)
(define-key map "\C-c\C-t" 'ada-type)
(define-key map "\C-ct" 'ada-tabsize)
;; (define-key map "\C-c\C-u" 'ada-use)
;; (define-key map "\C-c\C-w" 'ada-with)
(define-key map "\C-cw" 'ada-while-loop)
(define-key map "\C-c\C-w" 'ada-when)
(define-key map "\C-cx" 'ada-exit)
(define-key map "\C-cC" 'ada-compile)
(define-key map "\C-cB" 'ada-bind)
(define-key map "\C-cE" 'ada-find-listing)
(define-key map "\C-cL" 'ada-library-name)
(define-key map "\C-cO" 'ada-options-for-bind)
(setq ada-mode-map map))
(defvar ada-indent 4 "*Value is the number of columns to indent in Ada-Mode.")
(defvar ada-comment-end-column)
(defun ada-mode ()
"This is a mode intended to support program development in Ada.
Most control constructs and declarations of Ada can be inserted in the buffer
by typing Control-C followed by a character mnemonic for the construct.
\\<ada-mode-map>\\[ada-array] array \\[ada-exception-block] exception block
\\[ada-exception] exception \\[ada-declare-block] declare block
\\[ada-package-spec] package spec \\[ada-package-body] package body
\\[ada-procedure-spec] procedure spec \\[ada-subprogram-body] proc/func body
\\[ada-function-spec] func spec \\[ada-for-loop] for loop
\\[ada-if] if
\\[ada-elsif] elsif
\\[ada-else] else
\\[ada-private] private \\[ada-loop] loop
\\[ada-record] record \\[ada-case] case
\\[ada-subtype] subtype \\[ada-separate] separate
\\[ada-type] type \\[ada-tabsize] tab spacing for indents
\\[ada-when] when \\[ada-while] while
\\[ada-exit] exit
\\[ada-paired-parens] paired parens \\[ada-inline-comment] inline comment
\\[ada-header] header spec
\\[ada-compile] compile \\[ada-bind] bind
\\[ada-find-listing] find error list
\\[ada-library-name] name library \\[ada-options-for-bind] options for bind
\\[ada-backward-to-same-indent] and \\[ada-forward-to-same-indent] move backward and forward respectively to the next line
having the same (or lesser) level of indentation.
Variable `ada-indent' controls the number of spaces for indent/undent."
(interactive)
(kill-all-local-variables)
(use-local-map ada-mode-map)
(setq major-mode 'ada-mode)
(setq mode-name "Ada")
(make-local-variable 'comment-column)
(setq comment-column 41)
(make-local-variable 'ada-comment-end-column)
(setq ada-comment-end-column 72)
(set-syntax-table ada-mode-syntax-table)
(make-local-variable 'paragraph-start)
(setq paragraph-start (concat "$\\|" page-delimiter))
(make-local-variable 'paragraph-separate)
(setq paragraph-separate paragraph-start)
(make-local-variable 'paragraph-ignore-fill-prefix)
(setq paragraph-ignore-fill-prefix t)
; (make-local-variable 'indent-line-function)
; (setq indent-line-function 'c-indent-line)
(make-local-variable 'require-final-newline)
(setq require-final-newline t)
(make-local-variable 'comment-start)
(setq comment-start "--")
(make-local-variable 'comment-end)
(setq comment-end "")
(make-local-variable 'comment-column)
(setq comment-column 41)
(make-local-variable 'comment-start-skip)
(setq comment-start-skip "--+ *")
(make-local-variable 'comment-indent-function)
(setq comment-indent-function 'c-comment-indent)
(make-local-variable 'parse-sexp-ignore-comments)
(setq parse-sexp-ignore-comments t)
(make-local-variable 'font-lock-defaults)
(setq font-lock-defaults '(ada-font-lock-keywords nil t ((?\_ . "w"))))
(run-hooks 'ada-mode-hook))
(defun ada-tabsize (s)
"Changes spacing used for indentation.
The prefix argument is used as the new spacing."
(interactive "p")
(setq ada-indent s))
(defun ada-newline ()
"Start new line and indent to current tab stop."
(interactive)
(let ((ada-cc (current-indentation)))
(newline)
(indent-to ada-cc)))
(defun ada-tab ()
"Indent to next tab stop."
(interactive)
(indent-to (* (1+ (/ (current-indentation) ada-indent)) ada-indent)))
(defun ada-untab ()
"Delete backwards to previous tab stop."
(interactive)
(backward-delete-char-untabify ada-indent nil))
(defun ada-go-to-this-indent (step indent-level)
"Move point repeatedly by STEP lines until the current line has
given INDENT-LEVEL or less, or the start or end of the buffer is reached.
Ignore blank lines, statement labels and block or loop names."
(while (and
(zerop (forward-line step))
(or (looking-at "^[ ]*$")
(looking-at "^[ ]*--")
(looking-at "^<<[A-Za-z0-9_]+>>")
(looking-at "^[A-Za-z0-9_]+:")
(> (current-indentation) indent-level)))
nil))
(defun ada-backward-to-same-indent ()
"Move point backwards to nearest line with same indentation or less.
If not found, point is left at the top of the buffer."
(interactive)
(ada-go-to-this-indent -1 (current-indentation))
(back-to-indentation))
(defun ada-forward-to-same-indent ()
"Move point forwards to nearest line with same indentation or less.
If not found, point is left at the start of the last line in the buffer."
(interactive)
(ada-go-to-this-indent 1 (current-indentation))
(back-to-indentation))
(defun ada-array ()
"Insert array type definition. Uses the minibuffer to prompt
for component type and index subtypes."
(interactive)
(insert "array ()")
(backward-char)
(insert (read-string "index subtype[s]: "))
(end-of-line)
(insert " of ;")
(backward-char)
(insert (read-string "component-type: "))
(end-of-line))
(defun ada-case ()
"Build skeleton case statement.
Uses the minibuffer to prompt for the selector expression.
Also builds the first when clause."
(interactive)
(insert "case ")
(insert (read-string "selector expression: ") " is")
(ada-newline)
(ada-newline)
(insert "end case;")
(end-of-line 0)
(ada-tab)
(ada-tab)
(ada-when))
(defun ada-declare-block ()
"Insert a block with a declare part.
Indent for the first declaration."
(interactive)
(let ((ada-block-name (read-string "[block name]: ")))
(insert "declare")
(cond
( (not (string-equal ada-block-name ""))
(beginning-of-line)
(open-line 1)
(insert ada-block-name ":")
(next-line 1)
(end-of-line)))
(ada-newline)
(ada-newline)
(insert "begin")
(ada-newline)
(ada-newline)
(if (string-equal ada-block-name "")
(insert "end;")
(insert "end " ada-block-name ";"))
)
(end-of-line -2)
(ada-tab))
(defun ada-exception-block ()
"Insert a block with an exception part.
Indent for the first line of code."
(interactive)
(let ((block-name (read-string "[block name]: ")))
(insert "begin")
(cond
( (not (string-equal block-name ""))
(beginning-of-line)
(open-line 1)
(insert block-name ":")
(next-line 1)
(end-of-line)))
(ada-newline)
(ada-newline)
(insert "exception")
(ada-newline)
(ada-newline)
(cond
( (string-equal block-name "")
(insert "end;"))
( t
(insert "end " block-name ";")))
)
(end-of-line -2)
(ada-tab))
(defun ada-exception ()
"Insert an indented exception part into a block."
(interactive)
(ada-untab)
(insert "exception")
(ada-newline)
(ada-tab))
(defun ada-else ()
"Add an else clause inside an if-then-end-if clause."
(interactive)
(ada-untab)
(insert "else")
(ada-newline)
(ada-tab))
(defun ada-exit ()
"Insert an exit statement, prompting for loop name and condition."
(interactive)
(insert "exit")
(let ((ada-loop-name (read-string "[name of loop to exit]: ")))
(if (not (string-equal ada-loop-name "")) (insert " " ada-loop-name)))
(let ((ada-exit-condition (read-string "[exit condition]: ")))
(if (not (string-equal ada-exit-condition ""))
(if (string-match "^ *[Ww][Hh][Ee][Nn] +" ada-exit-condition)
(insert " " ada-exit-condition)
(insert " when " ada-exit-condition))))
(insert ";"))
(defun ada-when ()
"Start a case statement alternative with a when clause."
(interactive)
(ada-untab) ; we were indented in code for the last alternative.
(insert "when ")
(insert (read-string "'|'-delimited choice list: ") " =>")
(ada-newline)
(ada-tab))
(defun ada-for-loop ()
"Build a skeleton for-loop statement, prompting for the loop parameters."
(interactive)
(insert "for ")
(let* ((ada-loop-name (read-string "[loop name]: "))
(ada-loop-is-named (not (string-equal ada-loop-name ""))))
(if ada-loop-is-named
(progn
(beginning-of-line)
(open-line 1)
(insert ada-loop-name ":")
(next-line 1)
(end-of-line 1)))
(insert (read-string "loop variable: ") " in ")
(insert (read-string "range: ") " loop")
(ada-newline)
(ada-newline)
(insert "end loop")
(if ada-loop-is-named (insert " " ada-loop-name))
(insert ";"))
(end-of-line 0)
(ada-tab))
(defun ada-header ()
"Insert a comment block containing the module title, author, etc."
(interactive)
(insert "--\n-- Title: \t")
(insert (read-string "Title: "))
(insert "\n-- Created:\t" (current-time-string))
(insert "\n-- Author: \t" (user-full-name))
(insert "\n--\t\t<" (user-login-name) "@" (system-name) ">\n--\n"))
(defun ada-if ()
"Insert skeleton if statment, prompting for a boolean-expression."
(interactive)
(insert "if ")
(insert (read-string "condition: ") " then")
(ada-newline)
(ada-newline)
(insert "end if;")
(end-of-line 0)
(ada-tab))
(defun ada-elsif ()
"Add an elsif clause to an if statement, prompting for the boolean-expression."
(interactive)
(ada-untab)
(insert "elsif ")
(insert (read-string "condition: ") " then")
(ada-newline)
(ada-tab))
(defun ada-loop ()
"Insert a skeleton loop statement. The exit statement is added by hand."
(interactive)
(insert "loop ")
(let* ((ada-loop-name (read-string "[loop name]: "))
(ada-loop-is-named (not (string-equal ada-loop-name ""))))
(if ada-loop-is-named
(progn
(beginning-of-line)
(open-line 1)
(insert ada-loop-name ":")
(forward-line 1)
(end-of-line 1)))
(ada-newline)
(ada-newline)
(insert "end loop")
(if ada-loop-is-named (insert " " ada-loop-name))
(insert ";"))
(end-of-line 0)
(ada-tab))
(defun ada-package-spec ()
"Insert a skeleton package specification."
(interactive)
(insert "package ")
(let ((ada-package-name (read-string "package name: " )))
(insert ada-package-name " is")
(ada-newline)
(ada-newline)
(insert "end " ada-package-name ";")
(end-of-line 0)
(ada-tab)))
(defun ada-package-body ()
"Insert a skeleton package body -- includes a begin statement."
(interactive)
(insert "package body ")
(let ((ada-package-name (read-string "package name: " )))
(insert ada-package-name " is")
(ada-newline)
(ada-newline)
(insert "begin")
(ada-newline)
(insert "end " ada-package-name ";")
(end-of-line -1)
(ada-tab)))
(defun ada-private ()
"Undent and start a private section of a package spec. Reindent."
(interactive)
(ada-untab)
(insert "private")
(ada-newline)
(ada-tab))
(defun ada-get-arg-list ()
"Read from the user a procedure or function argument list.
Add parens unless arguments absent, and insert into buffer.
Individual arguments are arranged vertically if entered one at a time.
Arguments ending with `;' are presumed single and stacked."
(insert " (")
(let ((ada-arg-indent (current-column))
(ada-args (read-string "[arguments]: ")))
(if (string-equal ada-args "")
(backward-delete-char 2)
(progn
(while (string-match ";$" ada-args)
(insert ada-args)
(newline)
(indent-to ada-arg-indent)
(setq ada-args (read-string "next argument: ")))
(insert ada-args ")")))))
(defun ada-function-spec ()
"Insert a function specification. Prompts for name and arguments."
(interactive)
(insert "function ")
(insert (read-string "function name: "))
(ada-get-arg-list)
(insert " return ")
(insert (read-string "result type: ")))
(defun ada-procedure-spec ()
"Insert a procedure specification, prompting for its name and arguments."
(interactive)
(insert "procedure ")
(insert (read-string "procedure name: " ))
(ada-get-arg-list))
(defun get-ada-subprogram-name ()
"Return (without moving point or mark) a pair whose CAR is the name of
the function or procedure whose spec immediately precedes point, and whose
CDR is the column number where the procedure/function keyword was found."
(save-excursion
(let ((ada-proc-indent 0))
(if (re-search-backward
;;;; Unfortunately, comments are not ignored in this string search.
"[PpFf][RrUu][OoNn][Cc][EeTt][DdIi][UuOo][RrNn]" nil t)
(if (or (looking-at "\\<[Pp][Rr][Oo][Cc][Ee][Dd][Uu][Rr][Ee]\\>")
(looking-at "\\<[Ff][Uu][Nn][Cc][Tt][Ii][Oo][Nn]\\>"))
(progn
(setq ada-proc-indent (current-column))
(forward-word 2)
(let ((p2 (point)))
(forward-word -1)
(cons (buffer-substring (point) p2) ada-proc-indent)))
(get-ada-subprogram-name))
(cons "NAME?" ada-proc-indent)))))
(defun ada-subprogram-body ()
"Insert frame for subprogram body.
Invoke right after `ada-function-spec' or `ada-procedure-spec'."
(interactive)
(insert " is")
(let ((ada-subprogram-name-col (get-ada-subprogram-name)))
(newline)
(indent-to (cdr ada-subprogram-name-col))
(ada-newline)
(insert "begin")
(ada-newline)
(ada-newline)
(insert "end " (car ada-subprogram-name-col) ";"))
(end-of-line -2)
(ada-tab))
(defun ada-separate ()
"Finish a body stub with `is separate'."
(interactive)
(insert " is")
(ada-newline)
(ada-tab)
(insert "separate;")
(ada-newline)
(ada-untab))
;(defun ada-with ()
; "Inserts a with clause, prompting for the list of units depended upon."
; (interactive)
; (insert "with ")
; (insert (read-string "list of units depended upon: ") ";"))
;
;(defun ada-use ()
; "Inserts a use clause, prompting for the list of packages used."
; (interactive)
; (insert "use ")
; (insert (read-string "list of packages to use: ") ";"))
(defun ada-record ()
"Insert a skeleton record type declaration."
(interactive)
(insert "record")
(ada-newline)
(ada-newline)
(insert "end record;")
(end-of-line 0)
(ada-tab))
(defun ada-subtype ()
"Start insertion of a subtype declaration, prompting for the subtype name."
(interactive)
(insert "subtype " (read-string "subtype name: ") " is ;")
(backward-char)
(message "insert subtype indication."))
(defun ada-type ()
"Start insertion of a type declaration, prompting for the type name."
(interactive)
(insert "type " (read-string "type name: "))
(let ((disc-part (read-string "discriminant specs: ")))
(if (not (string-equal disc-part ""))
(insert "(" disc-part ")")))
(insert " is ")
(message "insert type definition."))
(defun ada-while-loop ()
(interactive)
(insert "while ")
(let* ((ada-loop-name (read-string "loop name: "))
(ada-loop-is-named (not (string-equal ada-loop-name ""))))
(if ada-loop-is-named
(progn
(beginning-of-line)
(open-line 1)
(insert ada-loop-name ":")
(next-line 1)
(end-of-line 1)))
(insert (read-string "entry condition: ") " loop")
(ada-newline)
(ada-newline)
(insert "end loop")
(if ada-loop-is-named (insert " " ada-loop-name))
(insert ";"))
(end-of-line 0)
(ada-tab))
(defun ada-paired-parens ()
"Insert a pair of round parentheses, placing point between them."
(interactive)
(insert "()")
(backward-char))
(defun ada-inline-comment ()
"Start a comment after the end of the line, indented at least
`comment-column' spaces. If starting after `end-comment-column',
start a new line."
(interactive)
(end-of-line)
(if (> (current-column) ada-comment-end-column) (newline))
(if (< (current-column) comment-column) (indent-to comment-column))
(insert " -- "))
(defun ada-display-comment ()
"Inserts three comment lines, making a display comment."
(interactive)
(insert "--\n-- \n--")
(end-of-line 0))
;; Much of this is specific to Ada-Ed
(defvar ada-lib-dir-name "lib" "*Current Ada program library directory.")
(defvar ada-bind-opts "" "*Options to supply for binding.")
(defun ada-library-name (ada-lib-name)
"Specify name of Ada library directory for later compilations."
(interactive "DName of Ada library directory: ")
(setq ada-lib-dir-name ada-lib-name))
(defun ada-options-for-bind ()
"Specify options, such as -m and -i, needed for `ada-bind'."
(setq ada-bind-opts (read-string "-m and -i options for `ada-bind': ")))
(defun ada-compile (arg)
"Save the current buffer and compile it into the current program library.
Initialize the library if a prefix arg is given."
(interactive "P")
(let* ((ada-init (if (null arg) "" "-n "))
(ada-source-file (buffer-name)))
(compile
(concat "adacomp " ada-init "-l " ada-lib-dir-name " " ada-source-file))))
(defun ada-find-listing ()
"Find listing file for ada source in current buffer, using other window."
(interactive)
(find-file-other-window (concat (substring (buffer-name) 0 -4) ".lis"))
(search-forward "*** ERROR"))
(defun ada-bind ()
"Bind the current program library, using the current binding options."
(interactive)
(compile (concat "adabind " ada-bind-opts " " ada-lib-dir-name)))
;;; ada.el ends here

165
lisp/batmode.el
View file

@ -1,165 +0,0 @@
;;; batmode.el --- Simple mode for Windows BAT files
;; Copyright (C) 1996 Free Software Foundation, Inc.
;; Author: Peter Breton <pbreton@i-kinetics.com>
;; Created: Thu Jul 25 1996
;; Keywords: BAT, DOS, Windows
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;;
;; USAGE: Byte-compile this file, and add the following lines to your
;; emacs initialization file (.emacs/_emacs):
;;
;; (setq auto-mode-alist
;; (append
;; (list (cons "\\.[bB][aA][tT]$" 'bat-mode))
;; ;; For DOS init files
;; (list (cons "CONFIG\\." 'bat-mode))
;; (list (cons "AUTOEXEC\\." 'bat-mode))
;; auto-mode-alist))
;;
;; (autoload 'bat-mode "batmode"
;; "DOS and WIndows BAT files" t)
;; TODO:
;;
;; Support "compiles" ?
;; Imenu? Don't have real functions.....
;;; Change log:
;; $Log: batmode.el,v $
;; Revision 1.3 1996/08/22 02:31:47 peter
;; Added Usage message, credit to folks from NTEmacs mailing list,
;; Syntax table, New font-lock keywords
;;
;; Revision 1.2 1996/08/18 16:27:13 peter
;; Added preliminary global-font-lock support
;;
;; Revision 1.1 1996/08/18 16:14:18 peter
;; Initial revision
;;
;; Credit for suggestions, patches and bug-fixes:
;; Robert Brodersen <rbrodersen@siebel.com>
;; ACorreir@pervasive-sw.com (Alfred Correira)
;;; Code:
(defvar bat-mode-map nil "Local keymap for bat-mode buffers.")
;; Make this lowercase if you like
(defvar bat-mode-comment-start "REM "
"Comment string to use in BAT mode")
(defvar bat-mode-syntax-table nil
"Syntax table in use in Bat-mode buffers.")
(if bat-mode-map
nil
(setq bat-mode-map (copy-keymap global-map))
)
;; Make underscores count as words
(if bat-mode-syntax-table
()
(setq bat-mode-syntax-table (make-syntax-table))
(modify-syntax-entry ?_ "w" bat-mode-syntax-table)
)
(defun bat-mode ()
"Mode for DOS and Windows BAT files"
(interactive)
(kill-all-local-variables)
(use-local-map bat-mode-map)
(set-syntax-table bat-mode-syntax-table)
(make-local-variable 'parse-sexp-ignore-comments)
(make-local-variable 'comment-start)
(make-local-variable 'comment-start-skip)
(make-local-variable 'comment-end)
(make-local-variable 'executable-command)
(make-local-variable 'font-lock-defaults)
(setq major-mode 'bat-mode
mode-name "bat"
comment-end ""
comment-start bat-mode-comment-start
comment-start-skip "[Rr][Ee][Mm] *"
parse-sexp-ignore-comments t
)
;; Global font-lock support
;; (setq font-lock-defaults (list 'bat-font-lock-keywords nil t nil nil))
(setq font-lock-defaults (list 'bat-font-lock-keywords nil))
(run-hooks 'bat-mode-hook))
(defvar bat-font-lock-keywords
(list
;; Make this one first in the list, otherwise comments will
;; be over-written by other variables
(list "^[@ \t]*\\([rR][eE][mM].*\\)" 1 'font-lock-comment-face t)
(list "^[ \t]*\\(::-.*\\)" 1 'font-lock-comment-face t)
(list
(concat "\\(\\<"
(mapconcat 'identity
'(
"call"
"echo"
"exist"
"errorlevel"
"for"
"goto"
"if"
"not"
"path"
"pause"
"prompt"
"set"
"start"
)
"\\>\\|\\<")
"\\>\\)") 1 'font-lock-keyword-face)
(list "^[ \t]*\\(:\\sw+\\)" 1 'font-lock-function-name-face t)
(list "\\(%\\sw+%\\)" 1 'font-lock-reference-face)
(list "\\(%[0-9]\\)" 1 'font-lock-reference-face)
(list "\\(/[^/ \t\n]+\\)" 1 'font-lock-type-face)
(list "\\<\\(goto\\)\\>[ \t]*\\(\\sw+\\)?"
'(1 font-lock-keyword-face)
'(2 font-lock-function-name-face nil t))
)
"Keywords to hilight in BAT mode")
;;; don't do it in Win-Emacs
(if (boundp 'font-lock-defaults-alist)
(add-to-list
'font-lock-defaults-alist
(cons 'bat-mode
(list 'bat-font-lock-keywords nil t nil nil))))
(provide 'bat-mode)
;;; batmode.el ends here

15
lisp/bytecpat.el
View file

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

3162
lisp/cl.el
View file

File diff suppressed because it is too large Load diff

694
lisp/cmulisp.el
View file

@ -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 <letter>
;;; bindings, which is not allowed by the gnumacs standard.
(defun cmulisp-install-letter-bindings ()
"This function binds many cmulisp commands to C-c <letter> bindings,
where they are more accessible. C-c <letter> bindings are reserved for the
user, so these bindings are non-standard. If you want them, you should
have this function called by the cmulisp-load-hook:
(setq cmulisp-load-hook '(cmulisp-install-letter-bindings))
You can modify this function to install just the bindings you want."
(define-key lisp-mode-map "\C-ce" 'lisp-eval-defun-and-go)
(define-key lisp-mode-map "\C-cr" 'lisp-eval-region-and-go)
(define-key lisp-mode-map "\C-cc" 'lisp-compile-defun-and-go)
(define-key lisp-mode-map "\C-cz" 'switch-to-lisp)
(define-key lisp-mode-map "\C-cl" 'lisp-load-file)
(define-key lisp-mode-map "\C-ck" 'lisp-compile-file)
(define-key lisp-mode-map "\C-ca" 'lisp-show-arglist)
(define-key lisp-mode-map "\C-cd" 'lisp-describe-sym)
(define-key lisp-mode-map "\C-cf" 'lisp-show-function-documentation)
(define-key lisp-mode-map "\C-cv" 'lisp-show-variable-documentation)
(define-key cmulisp-mode-map "\C-cl" 'lisp-load-file)
(define-key cmulisp-mode-map "\C-ck" 'lisp-compile-file)
(define-key cmulisp-mode-map "\C-ca" 'lisp-show-arglist)
(define-key cmulisp-mode-map "\C-cd" 'lisp-describe-sym)
(define-key cmulisp-mode-map "\C-cf" 'lisp-show-function-documentation)
(define-key cmulisp-mode-map "\C-cv" 'lisp-show-variable-documentation))
(defvar inferior-lisp-program "lisp"
"*Program name for invoking an inferior Lisp with `cmulisp'.")
(defvar inferior-lisp-load-command "(load \"%s\")\n"
"*Format-string for building a Lisp expression to load a file.
This format string should use %s to substitute a file name
and should result in a Lisp expression that will command the inferior Lisp
to load that file. The default works acceptably on most Lisps.
The string \"(progn (load \\\"%s\\\" :verbose nil :print t) (values))\\\n\"
produces cosmetically superior output for this application,
but it works only in Common Lisp.")
(defvar inferior-lisp-prompt "^[^> ]*>+:? *"
"Regexp to recognise prompts in the inferior Lisp.
Defaults to \"^[^> ]*>+:? *\", which works pretty good for Lucid, kcl,
and franz. This variable is used to initialise comint-prompt-regexp in the
cmulisp buffer.
More precise choices:
Lucid Common Lisp: \"^\\(>\\|\\(->\\)+\\) *\"
franz: \"^\\(->\\|<[0-9]*>:\\) *\"
kcl: \"^>+ *\"
This is a fine thing to set in your .emacs file.")
(defvar cmulisp-mode-hook '()
"*Hook for customising cmulisp mode")
(defun cmulisp-mode ()
"Major mode for interacting with an inferior Lisp process.
Runs a Lisp interpreter as a subprocess of Emacs, with Lisp I/O through an
Emacs buffer. Variable inferior-lisp-program controls which Lisp interpreter
is run. Variables inferior-lisp-prompt, cmulisp-filter-regexp and
inferior-lisp-load-command can customize this mode for different Lisp
interpreters.
For information on running multiple processes in multiple buffers, see
documentation for variable cmulisp-buffer.
\\{cmulisp-mode-map}
Customisation: Entry to this mode runs the hooks on comint-mode-hook and
cmulisp-mode-hook (in that order).
You can send text to the inferior Lisp process from other buffers containing
Lisp source.
switch-to-lisp switches the current buffer to the Lisp process buffer.
lisp-eval-defun sends the current defun to the Lisp process.
lisp-compile-defun compiles the current defun.
lisp-eval-region sends the current region to the Lisp process.
lisp-compile-region compiles the current region.
Prefixing the lisp-eval/compile-defun/region commands with
a \\[universal-argument] causes a switch to the Lisp process buffer after sending
the text.
Commands:
Return after the end of the process' output sends the text from the
end of process to point.
Return before the end of the process' output copies the sexp ending at point
to the end of the process' output, and sends it.
Delete converts tabs to spaces as it moves back.
Tab indents for Lisp; with argument, shifts rest
of expression rigidly with the current line.
C-M-q does Tab on each line starting within following expression.
Paragraphs are separated only by blank lines. Semicolons start comments.
If you accidentally suspend your process, use \\[comint-continue-subjob]
to continue it."
(interactive)
(comint-mode)
(setq comint-prompt-regexp inferior-lisp-prompt)
(setq major-mode 'cmulisp-mode)
(setq mode-name "CMU Lisp")
(setq mode-line-process '(": %s"))
(lisp-mode-variables t)
(use-local-map cmulisp-mode-map) ;c-c c-k for "kompile" file
(setq comint-get-old-input (function lisp-get-old-input))
(setq comint-input-filter (function lisp-input-filter))
(setq comint-input-sentinel 'ignore)
(run-hooks 'cmulisp-mode-hook))
(defun lisp-get-old-input ()
"Snarf the sexp ending at point"
(save-excursion
(let ((end (point)))
(backward-sexp)
(buffer-substring (point) end))))
(defun lisp-input-filter (str)
"Don't save anything matching cmulisp-filter-regexp"
(not (string-match cmulisp-filter-regexp str)))
(defun cmulisp (cmd)
"Run an inferior Lisp process, input and output via buffer *cmulisp*.
If there is a process already running in *cmulisp*, just switch to that buffer.
With argument, allows you to edit the command line (default is value
of inferior-lisp-program). Runs the hooks from cmulisp-mode-hook (after the
comint-mode-hook is run).
\(Type \\[describe-mode] in the process buffer for a list of commands.)"
(interactive (list (if current-prefix-arg
(read-string "Run lisp: " inferior-lisp-program)
inferior-lisp-program)))
(if (not (comint-check-proc "*cmulisp*"))
(let ((cmdlist (cmulisp-args-to-list cmd)))
(set-buffer (apply (function make-comint) "cmulisp" (car cmdlist) nil
(cdr cmdlist)))
(cmulisp-mode)))
(setq cmulisp-buffer "*cmulisp*")
(switch-to-buffer "*cmulisp*"))
;;; Break a string up into a list of arguments.
;;; This will break if you have an argument with whitespace, as in
;;; string = "-ab +c -x 'you lose'".
(defun cmulisp-args-to-list (string)
(let ((where (string-match "[ \t]" string)))
(cond ((null where) (list string))
((not (= where 0))
(cons (substring string 0 where)
(tea-args-to-list (substring string (+ 1 where)
(length string)))))
(t (let ((pos (string-match "[^ \t]" string)))
(if (null pos)
nil
(cmulisp-args-to-list (substring string pos
(length string)))))))))
(defun lisp-eval-region (start end &optional and-go)
"Send the current region to the inferior Lisp process.
Prefix argument means switch-to-lisp afterwards."
(interactive "r\nP")
(comint-send-region (cmulisp-proc) start end)
(comint-send-string (cmulisp-proc) "\n")
(if and-go (switch-to-lisp t)))
(defun lisp-eval-defun (&optional and-go)
"Send the current defun to the inferior Lisp process.
Prefix argument means switch-to-lisp afterwards."
(interactive "P")
(save-excursion
(end-of-defun)
(skip-chars-backward " \t\n\r\f") ; Makes allegro happy
(let ((end (point)))
(beginning-of-defun)
(lisp-eval-region (point) end)))
(if and-go (switch-to-lisp t)))
(defun lisp-eval-last-sexp (&optional and-go)
"Send the previous sexp to the inferior Lisp process.
Prefix argument means switch-to-lisp afterwards."
(interactive "P")
(lisp-eval-region (save-excursion (backward-sexp) (point)) (point) and-go))
;;; Common Lisp COMPILE sux.
(defun lisp-compile-region (start end &optional and-go)
"Compile the current region in the inferior Lisp process.
Prefix argument means switch-to-lisp afterwards."
(interactive "r\nP")
(comint-send-string (cmulisp-proc)
(format "(funcall (compile nil `(lambda () (progn 'compile %s))))\n"
(buffer-substring start end)))
(if and-go (switch-to-lisp t)))
(defun lisp-compile-defun (&optional and-go)
"Compile the current defun in the inferior Lisp process.
Prefix argument means switch-to-lisp afterwards."
(interactive "P")
(save-excursion
(end-of-defun)
(skip-chars-backward " \t\n\r\f") ; Makes allegro happy
(let ((e (point)))
(beginning-of-defun)
(lisp-compile-region (point) e)))
(if and-go (switch-to-lisp t)))
(defun switch-to-lisp (eob-p)
"Switch to the inferior Lisp process buffer.
With argument, positions cursor at end of buffer."
(interactive "P")
(if (get-buffer cmulisp-buffer)
(pop-to-buffer cmulisp-buffer)
(error "No current process buffer. See variable cmulisp-buffer."))
(cond (eob-p
(push-mark)
(goto-char (point-max)))))
;;; Now that lisp-compile/eval-defun/region takes an optional prefix arg,
;;; these commands are redundant. But they are kept around for the user
;;; to bind if he wishes, for backwards functionality, and because it's
;;; easier to type C-c e than C-u C-c C-e.
(defun lisp-eval-region-and-go (start end)
"Send the current region to the inferior Lisp,
and switch to the process buffer."
(interactive "r")
(lisp-eval-region start end t))
(defun lisp-eval-defun-and-go ()
"Send the current defun to the inferior Lisp,
and switch to the process buffer."
(interactive)
(lisp-eval-defun t))
(defun lisp-compile-region-and-go (start end)
"Compile the current region in the inferior Lisp,
and switch to the process buffer."
(interactive "r")
(lisp-compile-region start end t))
(defun lisp-compile-defun-and-go ()
"Compile the current defun in the inferior Lisp,
and switch to the process buffer."
(interactive)
(lisp-compile-defun t))
;;; A version of the form in H. Shevis' soar-mode.el package. Less robust.
;(defun lisp-compile-sexp (start end)
; "Compile the s-expression bounded by START and END in the inferior lisp.
;If the sexp isn't a DEFUN form, it is evaluated instead."
; (cond ((looking-at "(defun\\s +")
; (goto-char (match-end 0))
; (let ((name-start (point)))
; (forward-sexp 1)
; (process-send-string "cmulisp" (format "(compile '%s #'(lambda "
; (buffer-substring name-start
; (point)))))
; (let ((body-start (point)))
; (goto-char start) (forward-sexp 1) ; Can't use end-of-defun.
; (process-send-region "cmulisp" (buffer-substring body-start (point))))
; (process-send-string "cmulisp" ")\n"))
; (t (lisp-eval-region start end)))))
;
;(defun lisp-compile-region (start end)
; "Each s-expression in the current region is compiled (if a DEFUN)
;or evaluated (if not) in the inferior lisp."
; (interactive "r")
; (save-excursion
; (goto-char start) (end-of-defun) (beginning-of-defun) ; error check
; (if (< (point) start) (error "region begins in middle of defun"))
; (goto-char start)
; (let ((s start))
; (end-of-defun)
; (while (<= (point) end) ; Zip through
; (lisp-compile-sexp s (point)) ; compiling up defun-sized chunks.
; (setq s (point))
; (end-of-defun))
; (if (< s end) (lisp-compile-sexp s end)))))
;;;
;;; End of HS-style code
(defvar lisp-prev-l/c-dir/file nil
"Saves the (directory . file) pair used in the last lisp-load-file or
lisp-compile-file command. Used for determining the default in the
next one.")
(defvar lisp-source-modes '(lisp-mode)
"*Used to determine if a buffer contains Lisp source code.
If it's loaded into a buffer that is in one of these major modes, it's
considered a Lisp source file by lisp-load-file and lisp-compile-file.
Used by these commands to determine defaults.")
(defun lisp-load-file (file-name)
"Load a Lisp file into the inferior Lisp process."
(interactive (comint-get-source "Load Lisp file: " lisp-prev-l/c-dir/file
lisp-source-modes nil)) ; NIL because LOAD
; doesn't need an exact name
(comint-check-source file-name) ; Check to see if buffer needs saved.
(setq lisp-prev-l/c-dir/file (cons (file-name-directory file-name)
(file-name-nondirectory file-name)))
(comint-send-string (cmulisp-proc)
(format inferior-lisp-load-command file-name))
(switch-to-lisp t))
(defun lisp-compile-file (file-name)
"Compile a Lisp file in the inferior Lisp process."
(interactive (comint-get-source "Compile Lisp file: " lisp-prev-l/c-dir/file
lisp-source-modes nil)) ; NIL = don't need
; suffix .lisp
(comint-check-source file-name) ; Check to see if buffer needs saved.
(setq lisp-prev-l/c-dir/file (cons (file-name-directory file-name)
(file-name-nondirectory file-name)))
(comint-send-string (cmulisp-proc) (concat "(compile-file \""
file-name
"\"\)\n"))
(switch-to-lisp t))
;;; 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 <letter>. These are
;;; supposed to be reserved for the user to bind. This affected
;;; mainly the compile/eval-defun/region[-and-go] commands.
;;; This was painful, but necessary to adhere to the gnumacs standard.
;;; For some backwards compatibility, see the
;;; cmulisp-install-letter-bindings
;;; function.
;;;
;;; 8/2/91 Olin
;;; - The lisp-compile/eval-defun/region commands now take a prefix arg,
;;; which means switch-to-lisp after sending the text to the Lisp process.
;;; This obsoletes all the -and-go commands. The -and-go commands are
;;; kept around for historical reasons, and because the user can bind
;;; them to key sequences shorter than C-u C-c C-<letter>.
;;; - If M-x cmulisp is invoked with a prefix arg, it allows you to
;;; edit the command line.
(provide 'cmulisp)
;;; cmulisp.el ends here

501
lisp/custom.el
View file

@ -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 <abraham@dina.kvl.dk>
;; Maintainer: FSF
;; Keywords: help, faces
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;;
;; This file only contain the code needed to declare and initialize
;; user options. The code to customize options is autoloaded from
;; `cus-edit.el' and is documented in the Emacs Lisp Reference manual.
;; The code implementing face declarations is in `cus-face.el'
;;; Code:
(require 'widget)
(defvar custom-define-hook nil
;; Customize information for this option is in `cus-edit.el'.
"Hook called after defining each customize option.")
;;; The `defcustom' Macro.
(defun custom-initialize-default (symbol value)
"Initialize SYMBOL with VALUE.
This will do nothing if symbol already has a default binding.
Otherwise, if symbol has a `saved-value' property, it will evaluate
the car of that and used as the default binding for symbol.
Otherwise, VALUE will be evaluated and used as the default binding for
symbol."
(unless (default-boundp symbol)
;; Use the saved value if it exists, otherwise the standard setting.
(set-default symbol (if (get symbol 'saved-value)
(eval (car (get symbol 'saved-value)))
(eval value)))))
(defun custom-initialize-set (symbol value)
"Initialize SYMBOL based on VALUE.
If the symbol doesn't have a default binding already,
then set it using its `:set' function (or `set-default' if it has none).
The value is either the value in the symbol's `saved-value' property,
if any, or VALUE."
(unless (default-boundp symbol)
(funcall (or (get symbol 'custom-set) 'set-default)
symbol
(if (get symbol 'saved-value)
(eval (car (get symbol 'saved-value)))
(eval value)))))
(defun custom-initialize-reset (symbol value)
"Initialize SYMBOL based on VALUE.
Set the symbol, using its `:set' function (or `set-default' if it has none).
The value is either the symbol's current value
\(as obtained using the `:get' function), if any,
or the value in the symbol's `saved-value' property if any,
or (last of all) VALUE."
(funcall (or (get symbol 'custom-set) 'set-default)
symbol
(cond ((default-boundp symbol)
(funcall (or (get symbol 'custom-get) 'default-value)
symbol))
((get symbol 'saved-value)
(eval (car (get symbol 'saved-value))))
(t
(eval value)))))
(defun custom-initialize-changed (symbol value)
"Initialize SYMBOL with VALUE.
Like `custom-initialize-reset', but only use the `:set' function if
not using the standard setting.
For the standard setting, use `set-default'."
(cond ((default-boundp symbol)
(funcall (or (get symbol 'custom-set) 'set-default)
symbol
(funcall (or (get symbol 'custom-get) 'default-value)
symbol)))
((get symbol 'saved-value)
(funcall (or (get symbol 'custom-set) 'set-default)
symbol
(eval (car (get symbol 'saved-value)))))
(t
(set-default symbol (eval value)))))
(defun custom-declare-variable (symbol default doc &rest args)
"Like `defcustom', but SYMBOL and DEFAULT are evaluated as normal arguments.
DEFAULT should be an expression to evaluate to compute the default value,
not the default value itself."
;; Remember the standard setting.
(put symbol 'standard-value (list default))
;; Maybe this option was rogue in an earlier version. It no longer is.
(when (get symbol 'force-value)
(put symbol 'force-value nil))
(when doc
(put symbol 'variable-documentation doc))
(let ((initialize 'custom-initialize-reset)
(requests nil))
(while args
(let ((arg (car args)))
(setq args (cdr args))
(unless (symbolp arg)
(error "Junk in args %S" args))
(let ((keyword arg)
(value (car args)))
(unless args
(error "Keyword %s is missing an argument" keyword))
(setq args (cdr args))
(cond ((eq keyword :initialize)
(setq initialize value))
((eq keyword :set)
(put symbol 'custom-set value))
((eq keyword :get)
(put symbol 'custom-get value))
((eq keyword :require)
(setq requests (cons value requests)))
((eq keyword :type)
(put symbol 'custom-type (purecopy value)))
((eq keyword :options)
(if (get symbol 'custom-options)
;; Slow safe code to avoid duplicates.
(mapc (lambda (option)
(custom-add-option symbol option))
value)
;; Fast code for the common case.
(put symbol 'custom-options (copy-sequence value))))
(t
(custom-handle-keyword symbol keyword value
'custom-variable))))))
(put symbol 'custom-requests requests)
;; Do the actual initialization.
(funcall initialize symbol default))
(setq current-load-list (cons symbol current-load-list))
(run-hooks 'custom-define-hook)
symbol)
(defmacro defcustom (symbol value doc &rest args)
"Declare SYMBOL as a customizable variable that defaults to VALUE.
DOC is the variable documentation.
Neither SYMBOL nor VALUE needs to be quoted.
If SYMBOL is not already bound, initialize it to VALUE.
The remaining arguments should have the form
[KEYWORD VALUE]...
The following keywords are meaningful:
:type VALUE should be a widget type for editing the symbols value.
:options VALUE should be a list of valid members of the widget type.
:group VALUE should be a customization group.
Add SYMBOL to that group.
:initialize
VALUE should be a function used to initialize the
variable. It takes two arguments, the symbol and value
given in the `defcustom' call. The default is
`custom-initialize-default'
:set VALUE should be a function to set the value of the symbol.
It takes two arguments, the symbol to set and the value to
give it. The default choice of function is `custom-set-default'.
:get VALUE should be a function to extract the value of symbol.
The function takes one argument, a symbol, and should return
the current value for that symbol. The default choice of function
is `custom-default-value'.
:require
VALUE should be a feature symbol. If you save a value
for this option, then when your `.emacs' file loads the value,
it does (require VALUE) first.
:version
VALUE should be a string specifying that the variable was
first introduced, or its default value was changed, in Emacs
version VERSION.
Read the section about customization in the Emacs Lisp manual for more
information."
;; It is better not to use backquote in this file,
;; because that makes a bootstrapping problem
;; if you need to recompile all the Lisp files using interpreted code.
(nconc (list 'custom-declare-variable
(list 'quote symbol)
(list 'quote value)
doc)
args))
;;; The `defface' Macro.
(defmacro defface (face spec doc &rest args)
"Declare FACE as a customizable face that defaults to SPEC.
FACE does not need to be quoted.
Third argument DOC is the face documentation.
If FACE has been set with `custom-set-face', set the face attributes
as specified by that function, otherwise set the face attributes
according to SPEC.
The remaining arguments should have the form
[KEYWORD VALUE]...
The following KEYWORDs are defined:
:group VALUE should be a customization group.
Add FACE to that group.
SPEC should be an alist of the form ((DISPLAY ATTS)...).
The first element of SPEC where the DISPLAY matches the frame
is the one that takes effect in that frame. The ATTRs in this
element take effect; the other elements are ignored, on that frame.
ATTS is a list of face attributes followed by their values:
(ATTR VALUE ATTR VALUE...)
The possible attributes are `:family', `:width', `:height', `:weight',
`:slant', `:underline', `:overline', `:strike-through', `:box',
`:foreground', `:background', `:stipple', and `:inverse-video'.
DISPLAY can either be the symbol t, which will match all frames, or an
alist of the form \((REQ ITEM...)...). For the DISPLAY to match a
FRAME, the REQ property of the frame must match one of the ITEM. The
following REQ are defined:
`type' (the value of `window-system')
Under X, in addition to the values `window-system' can take,
`motif', `lucid' and `x-toolkit' are allowed, and match when
the Motif toolkit, Lucid toolkit, or any X toolkit is in use.
`class' (the frame's color support)
Should be one of `color', `grayscale', or `mono'.
`background' (what color is used for the background text)
Should be one of `light' or `dark'.
Read the section about customization in the Emacs Lisp manual for more
information."
;; It is better not to use backquote in this file,
;; because that makes a bootstrapping problem
;; if you need to recompile all the Lisp files using interpreted code.
(nconc (list 'custom-declare-face (list 'quote face) spec doc) args))
;;; The `defgroup' Macro.
(defun custom-declare-group (symbol members doc &rest args)
"Like `defgroup', but SYMBOL is evaluated as a normal argument."
(while members
(apply 'custom-add-to-group symbol (car members))
(setq members (cdr members)))
(put symbol 'custom-group (nconc members (get symbol 'custom-group)))
(when doc
;; This text doesn't get into DOC.
(put symbol 'group-documentation (purecopy doc)))
(while args
(let ((arg (car args)))
(setq args (cdr args))
(unless (symbolp arg)
(error "Junk in args %S" args))
(let ((keyword arg)
(value (car args)))
(unless args
(error "Keyword %s is missing an argument" keyword))
(setq args (cdr args))
(cond ((eq keyword :prefix)
(put symbol 'custom-prefix value))
(t
(custom-handle-keyword symbol keyword value
'custom-group))))))
(run-hooks 'custom-define-hook)
symbol)
(defmacro defgroup (symbol members doc &rest args)
"Declare SYMBOL as a customization group containing MEMBERS.
SYMBOL does not need to be quoted.
Third arg DOC is the group documentation.
MEMBERS should be an alist of the form ((NAME WIDGET)...) where
NAME is a symbol and WIDGET is a widget for editing that symbol.
Useful widgets are `custom-variable' for editing variables,
`custom-face' for edit faces, and `custom-group' for editing groups.
The remaining arguments should have the form
[KEYWORD VALUE]...
The following KEYWORDs are defined:
:group VALUE should be a customization group.
Add SYMBOL to that group.
:version VALUE should be a string specifying that the group was introduced
in Emacs version VERSION.
Read the section about customization in the Emacs Lisp manual for more
information."
;; It is better not to use backquote in this file,
;; because that makes a bootstrapping problem
;; if you need to recompile all the Lisp files using interpreted code.
(nconc (list 'custom-declare-group (list 'quote symbol) members doc) args))
(defun custom-add-to-group (group option widget)
"To existing GROUP add a new OPTION of type WIDGET.
If there already is an entry for OPTION and WIDGET, nothing is done."
(let ((members (get group 'custom-group))
(entry (list option widget)))
(unless (member entry members)
(put group 'custom-group (nconc members (list entry))))))
;;; Properties.
(defun custom-handle-all-keywords (symbol args type)
"For customization option SYMBOL, handle keyword arguments ARGS.
Third argument TYPE is the custom option type."
(while args
(let ((arg (car args)))
(setq args (cdr args))
(unless (symbolp arg)
(error "Junk in args %S" args))
(let ((keyword arg)
(value (car args)))
(unless args
(error "Keyword %s is missing an argument" keyword))
(setq args (cdr args))
(custom-handle-keyword symbol keyword value type)))))
(defun custom-handle-keyword (symbol keyword value type)
"For customization option SYMBOL, handle KEYWORD with VALUE.
Fourth argument TYPE is the custom option type."
(if purify-flag
(setq value (purecopy value)))
(cond ((eq keyword :group)
(custom-add-to-group value symbol type))
((eq keyword :version)
(custom-add-version symbol value))
((eq keyword :link)
(custom-add-link symbol value))
((eq keyword :load)
(custom-add-load symbol value))
((eq keyword :tag)
(put symbol 'custom-tag value))
((eq keyword :set-after)
(custom-add-dependencies symbol value))
(t
(error "Unknown keyword %s" keyword))))
(defun custom-add-dependencies (symbol value)
"To the custom option SYMBOL, add dependencies specified by VALUE.
VALUE should be a list of symbols. For each symbol in that list,
this specifies that SYMBOL should be set after the specified symbol, if
both appear in constructs like `custom-set-variables'."
(unless (listp value)
(error "Invalid custom dependency `%s'" value))
(let* ((deps (get symbol 'custom-dependencies))
(new-deps deps))
(while value
(let ((dep (car value)))
(unless (symbolp dep)
(error "Invalid custom dependency `%s'" dep))
(unless (memq dep new-deps)
(setq new-deps (cons dep new-deps)))
(setq value (cdr value))))
(unless (eq deps new-deps)
(put symbol 'custom-dependencies new-deps))))
(defun custom-add-option (symbol option)
"To the variable SYMBOL add OPTION.
If SYMBOL is a hook variable, OPTION should be a hook member.
For other types variables, the effect is undefined."
(let ((options (get symbol 'custom-options)))
(unless (member option options)
(put symbol 'custom-options (cons option options)))))
(defun custom-add-link (symbol widget)
"To the custom option SYMBOL add the link WIDGET."
(let ((links (get symbol 'custom-links)))
(unless (member widget links)
(put symbol 'custom-links (cons (purecopy widget) links)))))
(defun custom-add-version (symbol version)
"To the custom option SYMBOL add the version VERSION."
(put symbol 'custom-version (purecopy version)))
(defun custom-add-load (symbol load)
"To the custom option SYMBOL add the dependency LOAD.
LOAD should be either a library file name, or a feature name."
(let ((loads (get symbol 'custom-loads)))
(unless (member load loads)
(put symbol 'custom-loads (cons (purecopy load) loads)))))
;;; Initializing.
(defvar custom-local-buffer nil
"Non-nil, in a Customization buffer, means customize a specific buffer.
If this variable is non-nil, it should be a buffer,
and it means customize the local bindings of that buffer.
This variable is a permanent local, and it normally has a local binding
in every Customization buffer.")
(put 'custom-local-buffer 'permanent-local t)
(defun custom-set-variables (&rest args)
"Initialize variables according to user preferences.
The arguments should be a list where each entry has the form:
(SYMBOL VALUE [NOW [REQUEST [COMMENT]]])
The unevaluated VALUE is stored as the saved value for SYMBOL.
If NOW is present and non-nil, VALUE is also evaluated and bound as
the default value for the SYMBOL.
REQUEST is a list of features we must require for SYMBOL.
COMMENT is a comment string about SYMBOL."
(setq args
(sort args
(lambda (a1 a2)
(let* ((sym1 (car a1))
(sym2 (car a2))
(1-then-2 (memq sym1 (get sym2 'custom-dependencies)))
(2-then-1 (memq sym2 (get sym1 'custom-dependencies))))
(cond ((and 1-then-2 2-then-1)
(error "Circular custom dependency between `%s' and `%s'"
sym1 sym2))
(1-then-2 t)
(t nil))))))
(while args
(let ((entry (car args)))
(if (listp entry)
(let* ((symbol (nth 0 entry))
(value (nth 1 entry))
(now (nth 2 entry))
(requests (nth 3 entry))
(comment (nth 4 entry))
set)
(when requests
(put symbol 'custom-requests requests)
(mapc 'require requests))
(setq set (or (get symbol 'custom-set) 'custom-set-default))
(put symbol 'saved-value (list value))
(put symbol 'saved-variable-comment comment)
;; Allow for errors in the case where the setter has
;; changed between versions, say, but let the user know.
(condition-case data
(cond (now
;; Rogue variable, set it now.
(put symbol 'force-value t)
(funcall set symbol (eval value)))
((default-boundp symbol)
;; Something already set this, overwrite it.
(funcall set symbol (eval value))))
(error
(message "Error setting %s: %s" symbol data)))
(setq args (cdr args))
(and (or now (default-boundp symbol))
(put symbol 'variable-comment comment)))
;; Old format, a plist of SYMBOL VALUE pairs.
(message "Warning: old format `custom-set-variables'")
(ding)
(sit-for 2)
(let ((symbol (nth 0 args))
(value (nth 1 args)))
(put symbol 'saved-value (list value)))
(setq args (cdr (cdr args)))))))
(defun custom-set-default (variable value)
"Default :set function for a customizable variable.
Normally, this sets the default value of VARIABLE to VALUE,
but if `custom-local-buffer' is non-nil,
this sets the local binding in that buffer instead."
(if custom-local-buffer
(with-current-buffer custom-local-buffer
(set variable value))
(set-default variable value)))
;;; The End.
;; Process the defcustoms for variables loaded before this file.
(while custom-declare-variable-list
(apply 'custom-declare-variable (car custom-declare-variable-list))
(setq custom-declare-variable-list (cdr custom-declare-variable-list)))
(provide 'custom)
;;; custom.el ends here

251
lisp/diary-ins.el
View file

@ -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 <reingold@cs.uiuc.edu>
;; Keywords: diary, calendar
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;;; Commentary:
;; This collection of functions implements the diary insertion features as
;; described in calendar.el.
;; Comments, corrections, and improvements should be sent to
;; Edward M. Reingold Department of Computer Science
;; (217) 333-6733 University of Illinois at Urbana-Champaign
;; reingold@cs.uiuc.edu 1304 West Springfield Avenue
;; Urbana, Illinois 61801
;;; Code:
(require 'diary-lib)
(defun make-diary-entry (string &optional nonmarking file)
"Insert a diary entry STRING which may be NONMARKING in FILE.
If omitted, NONMARKING defaults to nil and FILE defaults to diary-file."
(find-file-other-window
(substitute-in-file-name (if file file diary-file)))
(goto-char (point-max))
(insert
(if (bolp) "" "\n")
(if nonmarking diary-nonmarking-symbol "")
string " "))
(defun insert-diary-entry (arg)
"Insert a diary entry for the date indicated by point.
Prefix arg will make the entry nonmarking."
(interactive "P")
(make-diary-entry (calendar-date-string (calendar-cursor-to-date t) t t)
arg))
(defun insert-weekly-diary-entry (arg)
"Insert a weekly diary entry for the day of the week indicated by point.
Prefix arg will make the entry nonmarking."
(interactive "P")
(make-diary-entry (calendar-day-name (calendar-cursor-to-date t))
arg))
(defun insert-monthly-diary-entry (arg)
"Insert a monthly diary entry for the day of the month indicated by point.
Prefix arg will make the entry nonmarking."
(interactive "P")
(let* ((calendar-date-display-form
(if european-calendar-style
'(day " * ")
'("* " day))))
(make-diary-entry (calendar-date-string (calendar-cursor-to-date t) t)
arg)))
(defun insert-yearly-diary-entry (arg)
"Insert an annual diary entry for the day of the year indicated by point.
Prefix arg will make the entry nonmarking."
(interactive "P")
(let* ((calendar-date-display-form
(if european-calendar-style
'(day " " monthname)
'(monthname " " day))))
(make-diary-entry (calendar-date-string (calendar-cursor-to-date t) t)
arg)))
(defun insert-anniversary-diary-entry (arg)
"Insert an anniversary diary entry for the date given by point.
Prefix arg will make the entry nonmarking."
(interactive "P")
(let* ((calendar-date-display-form
(if european-calendar-style
'(day " " month " " year)
'(month " " day " " year))))
(make-diary-entry
(format "%s(diary-anniversary %s)"
sexp-diary-entry-symbol
(calendar-date-string (calendar-cursor-to-date t) nil t))
arg)))
(defun insert-block-diary-entry (arg)
"Insert a block diary entry for the days between the point and marked date.
Prefix arg will make the entry nonmarking."
(interactive "P")
(let* ((calendar-date-display-form
(if european-calendar-style
'(day " " month " " year)
'(month " " day " " year)))
(cursor (calendar-cursor-to-date t))
(mark (or (car calendar-mark-ring)
(error "No mark set in this buffer")))
(start)
(end))
(if (< (calendar-absolute-from-gregorian mark)
(calendar-absolute-from-gregorian cursor))
(setq start mark
end cursor)
(setq start cursor
end mark))
(make-diary-entry
(format "%s(diary-block %s %s)"
sexp-diary-entry-symbol
(calendar-date-string start nil t)
(calendar-date-string end nil t))
arg)))
(defun insert-cyclic-diary-entry (arg)
"Insert a cyclic diary entry starting at the date given by point.
Prefix arg will make the entry nonmarking."
(interactive "P")
(let* ((calendar-date-display-form
(if european-calendar-style
'(day " " month " " year)
'(month " " day " " year))))
(make-diary-entry
(format "%s(diary-cyclic %d %s)"
sexp-diary-entry-symbol
(calendar-read "Repeat every how many days: "
'(lambda (x) (> x 0)))
(calendar-date-string (calendar-cursor-to-date t) nil t))
arg)))
(defun insert-hebrew-diary-entry (arg)
"Insert a diary entry.
For the Hebrew date corresponding to the date indicated by point.
Prefix arg will make the entry nonmarking."
(interactive "P")
(let* ((calendar-month-name-array
calendar-hebrew-month-name-array-leap-year))
(make-diary-entry
(concat
hebrew-diary-entry-symbol
(calendar-date-string
(calendar-hebrew-from-absolute
(calendar-absolute-from-gregorian
(calendar-cursor-to-date t)))
nil t))
arg)))
(defun insert-monthly-hebrew-diary-entry (arg)
"Insert a monthly diary entry.
For the day of the Hebrew month corresponding to the date indicated by point.
Prefix arg will make the entry nonmarking."
(interactive "P")
(let* ((calendar-date-display-form
(if european-calendar-style '(day " * ") '("* " day )))
(calendar-month-name-array
calendar-hebrew-month-name-array-leap-year))
(make-diary-entry
(concat
hebrew-diary-entry-symbol
(calendar-date-string
(calendar-hebrew-from-absolute
(calendar-absolute-from-gregorian
(calendar-cursor-to-date t)))))
arg)))
(defun insert-yearly-hebrew-diary-entry (arg)
"Insert an annual diary entry.
For the day of the Hebrew year corresponding to the date indicated by point.
Prefix arg will make the entry nonmarking."
(interactive "P")
(let* ((calendar-date-display-form
(if european-calendar-style
'(day " " monthname)
'(monthname " " day)))
(calendar-month-name-array
calendar-hebrew-month-name-array-leap-year))
(make-diary-entry
(concat
hebrew-diary-entry-symbol
(calendar-date-string
(calendar-hebrew-from-absolute
(calendar-absolute-from-gregorian
(calendar-cursor-to-date t)))))
arg)))
(defun insert-islamic-diary-entry (arg)
"Insert a diary entry.
For the Islamic date corresponding to the date indicated by point.
Prefix arg will make the entry nonmarking."
(interactive "P")
(let* ((calendar-month-name-array calendar-islamic-month-name-array))
(make-diary-entry
(concat
islamic-diary-entry-symbol
(calendar-date-string
(calendar-islamic-from-absolute
(calendar-absolute-from-gregorian
(calendar-cursor-to-date t)))
nil t))
arg)))
(defun insert-monthly-islamic-diary-entry (arg)
"Insert a monthly diary entry.
For the day of the Islamic month corresponding to the date indicated by point.
Prefix arg will make the entry nonmarking."
(interactive "P")
(let* ((calendar-date-display-form
(if european-calendar-style '(day " * ") '("* " day )))
(calendar-month-name-array calendar-islamic-month-name-array))
(make-diary-entry
(concat
islamic-diary-entry-symbol
(calendar-date-string
(calendar-islamic-from-absolute
(calendar-absolute-from-gregorian
(calendar-cursor-to-date t)))))
arg)))
(defun insert-yearly-islamic-diary-entry (arg)
"Insert an annual diary entry.
For the day of the Islamic year corresponding to the date indicated by point.
Prefix arg will make the entry nonmarking."
(interactive "P")
(let* ((calendar-date-display-form
(if european-calendar-style
'(day " " monthname)
'(monthname " " day)))
(calendar-month-name-array calendar-islamic-month-name-array))
(make-diary-entry
(concat
islamic-diary-entry-symbol
(calendar-date-string
(calendar-islamic-from-absolute
(calendar-absolute-from-gregorian
(calendar-cursor-to-date t)))))
arg)))
(provide 'diary-ins)
;;; diary-ins.el ends here

1919
lisp/diary-lib.el
View file

File diff suppressed because it is too large Load diff

392
lisp/ftp.el
View file

@ -1,392 +0,0 @@
;;; ftp.el --- file input and output over Internet using FTP
;; Copyright (C) 1987 Free Software Foundation, Inc.
;; Author: Richard Mlynarik <mly@prep.ai.mit.edu>
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;;; Code:
;; Prevent changes in major modes from altering these variables.
(put 'ftp-temp-file-name 'permanent-local t)
(put 'ftp-file 'permanent-local t)
(put 'ftp-host 'permanent-local t)
;; you can turn this off by doing
;; (setq ftp-password-alist 'compulsory-urinalysis)
(defvar ftp-password-alist () "Security sucks")
(defun read-ftp-user-password (host user new)
(let (tem)
(if (and (not new)
(listp ftp-password-alist)
(setq tem (cdr (assoc host ftp-password-alist)))
(or (null user)
(string= user (car tem))))
tem
(or user
(progn
(setq tem (or (and (listp ftp-password-alist)
(car (cdr (assoc host ftp-password-alist))))
(user-login-name)))
(setq user (read-string (format
"User-name for %s (default \"%s\"): "
host tem)))
(if (equal user "") (setq user tem))))
(setq tem (cons user
;; If you want to use some non-echoing string-reader,
;; feel free to write it yourself. I don't care enough.
(read-string (format "Password for %s@%s: " user host)
(if (not (listp ftp-password-alist))
""
(or (cdr (cdr (assoc host ftp-password-alist)))
(let ((l ftp-password-alist))
(catch 'foo
(while l
(if (string= (car (cdr (car l))) user)
(throw 'foo (cdr (cdr (car l))))
(setq l (cdr l))))
nil))
"")))))
(message "")
(if (and (listp ftp-password-alist)
(not (string= (cdr tem) "")))
(setq ftp-password-alist (cons (cons host tem)
ftp-password-alist)))
tem)))
(defun ftp-read-file-name (prompt)
(let ((s ""))
(while (not (string-match "\\`[ \t]*\\([^ \t:]+\\)[ \t]*:\\(.+\\)\\'" s))
(setq s (read-string prompt s)))
(list (substring s (match-beginning 1) (match-end 1))
(substring s (match-beginning 2) (match-end 2)))))
;;;###autoload
(defun ftp-find-file (host file &optional user password)
"FTP to HOST to get FILE, logging in as USER with password PASSWORD.
Interactively, HOST and FILE are specified by reading a string with
a colon character separating the host from the filename.
USER and PASSWORD are defaulted from the values used when
last ftping from HOST (unless password-remembering is disabled).
Supply a password of the symbol `t' to override this default
(interactively, this is done by giving a prefix arg)"
(interactive
(append (ftp-read-file-name "FTP get host:file: ")
(list nil (not (null current-prefix-arg)))))
(ftp-find-file-or-directory host file t user password))
;;;###autoload
(defun ftp-list-directory (host file &optional user password)
"FTP to HOST to list DIRECTORY, logging in as USER with password PASSWORD.
Interactively, HOST and FILE are specified by reading a string with
a colon character separating the host from the filename.
USER and PASSWORD are defaulted from the values used when
last ftping from HOST (unless password-remembering is disabled).
Supply a password of the symbol `t' to override this default
(interactively, this is done by giving a prefix arg)"
(interactive
(append (ftp-read-file-name "FTP get host:directory: ")
(list nil (not (null current-prefix-arg)))))
(ftp-find-file-or-directory host file nil user password))
(defun ftp-find-file-or-directory (host file filep &optional user password)
"FTP to HOST to get FILE. Third arg is t for file, nil for directory.
Log in as USER with PASSWORD. If USER is nil or PASSWORD is nil or t,
we prompt for the user name and password."
(or (and user password (not (eq password t)))
(progn (setq user (read-ftp-user-password host user (eq password t))
password (cdr user)
user (car user))))
(let ((buffer (get-buffer-create (format "*ftp%s %s:%s*"
(if filep "" "-directory")
host file))))
(set-buffer buffer)
(let ((process nil)
(case-fold-search nil))
(let ((win nil))
(unwind-protect
(progn
(setq process (ftp-setup-buffer host file))
(if (setq win (ftp-login process host user password))
(message "Logged in")
(error "Ftp login failed")))
(or win (and process (delete-process process)))))
(message "Opening %s %s:%s..." (if filep "file" "directory")
host file)
(if (ftp-command process
(format "%s \"%s\" -\nquit\n" (if filep "get" "dir")
file)
"\\(150\\|125\\).*\n"
"200.*\n")
(progn (forward-line 1)
(let ((buffer-read-only nil))
(delete-region (point-min) (point)))
(message "Retrieving %s:%s in background. Bye!" host file)
(set-process-sentinel process
'ftp-asynchronous-input-sentinel)
process)
(switch-to-buffer buffer)
(let ((buffer-read-only nil))
(insert-before-markers "<<<Ftp lost>>>"))
(delete-process process)
(error "Ftp %s:%s lost" host file)))))
;;;###autoload
(defun ftp-write-file (host file &optional user password)
"FTP to HOST to write FILE, logging in as USER with password PASSWORD.
Interactively, HOST and FILE are specified by reading a string with colon
separating the host from the filename.
USER and PASSWORD are defaulted from the values used when
last ftping from HOST (unless `password-remembering' is disabled).
Supply a password of the symbol `t' to override this default
(interactively, this is done by giving a prefix arg)"
(interactive
(append (ftp-read-file-name "FTP write host:file: ")
(list nil (not (null current-prefix-arg)))))
(or (and user password (not (eq password t)))
(progn (setq user (read-ftp-user-password host user (eq password t))
password (cdr user)
user (car user))))
(let ((buffer (get-buffer-create (format "*ftp %s:%s*" host file)))
(tmp (make-temp-name "/tmp/emacsftp")))
(write-region (point-min) (point-max) tmp)
(save-excursion
(set-buffer buffer)
(make-local-variable 'ftp-temp-file-name)
(setq ftp-temp-file-name tmp)
(let ((process (ftp-setup-buffer host file))
(case-fold-search nil))
(let ((win nil))
(unwind-protect
(if (setq win (ftp-login process host user password))
(message "Logged in")
(error "Ftp login lost"))
(or win (delete-process process))))
(message "Opening file %s:%s..." host file)
(if (ftp-command process
(format "send \"%s\" \"%s\"\nquit\n" tmp file)
"\\(150\\|125\\).*\n"
"200.*\n")
(progn (forward-line 1)
(setq foo1 (current-buffer))
(let ((buffer-read-only nil))
(delete-region (point-min) (point)))
(message "Saving %s:%s in background. Bye!" host file)
(set-process-sentinel process
'ftp-asynchronous-output-sentinel)
process)
(switch-to-buffer buffer)
(setq foo2 (current-buffer))
(let ((buffer-read-only nil))
(insert-before-markers "<<<Ftp lost>>>"))
(delete-process process)
(error "Ftp write %s:%s lost" host file))))))
(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

409
lisp/gnus/md5.el
View file

@ -1,409 +0,0 @@
;;; md5.el -- MD5 Message Digest Algorithm
;;; Gareth Rees <gdr11@cl.cam.ac.uk>
;; LCD Archive Entry:
;; md5|Gareth Rees|gdr11@cl.cam.ac.uk|
;; MD5 cryptographic message digest algorithm|
;; 13-Nov-95|1.0|~/misc/md5.el.Z|
;;; Details: ------------------------------------------------------------------
;; This is a direct translation into Emacs LISP of the reference C
;; implementation of the MD5 Message-Digest Algorithm written by RSA
;; Data Security, Inc.
;;
;; The algorithm takes a message (that is, a string of bytes) and
;; computes a 16-byte checksum or "digest" for the message. This digest
;; is supposed to be cryptographically strong in the sense that if you
;; are given a 16-byte digest D, then there is no easier way to
;; construct a message whose digest is D than to exhaustively search the
;; space of messages. However, the robustness of the algorithm has not
;; been proven, and a similar algorithm (MD4) was shown to be unsound,
;; so treat with caution!
;;
;; The C algorithm uses 32-bit integers; because GNU Emacs
;; implementations provide 28-bit integers (with 24-bit integers on
;; versions prior to 19.29), the code represents a 32-bit integer as the
;; cons of two 16-bit integers. The most significant word is stored in
;; the car and the least significant in the cdr. The algorithm requires
;; at least 17 bits of integer representation in order to represent the
;; carry from a 16-bit addition.
;;; Usage: --------------------------------------------------------------------
;; To compute the MD5 Message Digest for a message M (represented as a
;; string or as a vector of bytes), call
;;
;; (md5-encode M)
;;
;; which returns the message digest as a vector of 16 bytes. If you
;; need to supply the message in pieces M1, M2, ... Mn, then call
;;
;; (md5-init)
;; (md5-update M1)
;; (md5-update M2)
;; ...
;; (md5-update Mn)
;; (md5-final)
;;; Copyright and licence: ----------------------------------------------------
;; Copyright (C) 1995 by Gareth Rees
;; Derived from the RSA Data Security, Inc. MD5 Message-Digest Algorithm
;;
;; md5.el is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by the
;; Free Software Foundation; either version 2, or (at your option) any
;; later version.
;;
;; md5.el is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
;; for more details.
;;
;; The original copyright notice is given below, as required by the
;; licence for the original code. This code is distributed under *both*
;; RSA's original licence and the GNU General Public Licence. (There
;; should be no problems, as the former is more liberal than the
;; latter).
;;; Original copyright notice: ------------------------------------------------
;; Copyright (C) 1990, RSA Data Security, Inc. All rights reserved.
;;
;; License to copy and use this software is granted provided that it is
;; identified as the "RSA Data Security, Inc. MD5 Message- Digest
;; Algorithm" in all material mentioning or referencing this software or
;; this function.
;;
;; License is also granted to make and use derivative works provided
;; that such works are identified as "derived from the RSA Data
;; Security, Inc. MD5 Message-Digest Algorithm" in all material
;; mentioning or referencing the derived work.
;;
;; RSA Data Security, Inc. makes no representations concerning either
;; the merchantability of this software or the suitability of this
;; software for any particular purpose. It is provided "as is" without
;; express or implied warranty of any kind.
;;
;; These notices must be retained in any copies of any part of this
;; documentation and/or software.
;;; Code: ---------------------------------------------------------------------
(defvar md5-program "md5"
"*Program that reads a message on its standard input and writes an
MD5 digest on its output.")
(defvar md5-maximum-internal-length 4096
"*The maximum size of a piece of data that should use the MD5 routines
written in lisp. If a message exceeds this, it will be run through an
external filter for processing. Also see the `md5-program' variable.
This variable has no effect if you call the md5-init|update|final
functions - only used by the `md5' function's simpler interface.")
(defvar md5-bits (make-vector 4 0)
"Number of bits handled, modulo 2^64.
Represented as four 16-bit numbers, least significant first.")
(defvar md5-buffer (make-vector 4 '(0 . 0))
"Scratch buffer (four 32-bit integers).")
(defvar md5-input (make-vector 64 0)
"Input buffer (64 bytes).")
(defun md5-unhex (x)
(if (> x ?9)
(if (>= x ?a)
(+ 10 (- x ?a))
(+ 10 (- x ?A)))
(- x ?0)))
(defun md5-encode (message)
"Encodes MESSAGE using the MD5 message digest algorithm.
MESSAGE must be a string or an array of bytes.
Returns a vector of 16 bytes containing the message digest."
(if (<= (length message) md5-maximum-internal-length)
(progn
(md5-init)
(md5-update message)
(md5-final))
(save-excursion
(set-buffer (get-buffer-create " *md5-work*"))
(erase-buffer)
(insert message)
(call-process-region (point-min) (point-max)
(or shell-file-name "/bin/sh")
t (current-buffer) nil
"-c" md5-program)
;; MD5 digest is 32 chars long
;; mddriver adds a newline to make neaten output for tty
;; viewing, make sure we leave it behind.
(let ((data (buffer-substring (point-min) (+ (point-min) 32)))
(vec (make-vector 16 0))
(ctr 0))
(while (< ctr 16)
(aset vec ctr (+ (* 16 (md5-unhex (aref data (* ctr 2))))
(md5-unhex (aref data (1+ (* ctr 2))))))
(setq ctr (1+ ctr)))))))
(defsubst md5-add (x y)
"Return 32-bit sum of 32-bit integers X and Y."
(let ((m (+ (car x) (car y)))
(l (+ (cdr x) (cdr y))))
(cons (logand 65535 (+ m (lsh l -16))) (logand l 65535))))
;; FF, GG, HH and II are basic MD5 functions, providing transformations
;; for rounds 1, 2, 3 and 4 respectively. Each function follows this
;; pattern of computation (where ROTATE(x,y) means rotate 32-bit value x
;; by y bits to the left):
;;
;; FF(a,b,c,d,x,s,ac) = ROTATE(a + F(b,c,d) + x + ac,s) + b
;;
;; so we use the macro `md5-make-step' to construct each one. The
;; helper functions F, G, H and I operate on 16-bit numbers; the full
;; operation splits its inputs, operates on the halves separately and
;; then puts the results together.
(defsubst md5-F (x y z) (logior (logand x y) (logand (lognot x) z)))
(defsubst md5-G (x y z) (logior (logand x z) (logand y (lognot z))))
(defsubst md5-H (x y z) (logxor x y z))
(defsubst md5-I (x y z) (logxor y (logior x (logand 65535 (lognot z)))))
(defmacro md5-make-step (name func)
(`
(defun (, name) (a b c d x s ac)
(let*
((m1 (+ (car a) ((, func) (car b) (car c) (car d)) (car x) (car ac)))
(l1 (+ (cdr a) ((, func) (cdr b) (cdr c) (cdr d)) (cdr x) (cdr ac)))
(m2 (logand 65535 (+ m1 (lsh l1 -16))))
(l2 (logand 65535 l1))
(m3 (logand 65535 (if (> s 15)
(+ (lsh m2 (- s 32)) (lsh l2 (- s 16)))
(+ (lsh m2 s) (lsh l2 (- s 16))))))
(l3 (logand 65535 (if (> s 15)
(+ (lsh l2 (- s 32)) (lsh m2 (- s 16)))
(+ (lsh l2 s) (lsh m2 (- s 16)))))))
(md5-add (cons m3 l3) b)))))
(md5-make-step md5-FF md5-F)
(md5-make-step md5-GG md5-G)
(md5-make-step md5-HH md5-H)
(md5-make-step md5-II md5-I)
(defun md5-init ()
"Initialise the state of the message-digest routines."
(aset md5-bits 0 0)
(aset md5-bits 1 0)
(aset md5-bits 2 0)
(aset md5-bits 3 0)
(aset md5-buffer 0 '(26437 . 8961))
(aset md5-buffer 1 '(61389 . 43913))
(aset md5-buffer 2 '(39098 . 56574))
(aset md5-buffer 3 '( 4146 . 21622)))
(defun md5-update (string)
"Update the current MD5 state with STRING (an array of bytes)."
(let ((len (length string))
(i 0)
(j 0))
(while (< i len)
;; Compute number of bytes modulo 64
(setq j (% (/ (aref md5-bits 0) 8) 64))
;; Store this byte (truncating to 8 bits to be sure)
(aset md5-input j (logand 255 (aref string i)))
;; Update number of bits by 8 (modulo 2^64)
(let ((c 8) (k 0))
(while (and (> c 0) (< k 4))
(let ((b (aref md5-bits k)))
(aset md5-bits k (logand 65535 (+ b c)))
(setq c (if (> b (- 65535 c)) 1 0)
k (1+ k)))))
;; Increment number of bytes processed
(setq i (1+ i))
;; When 64 bytes accumulated, pack them into sixteen 32-bit
;; integers in the array `in' and then tranform them.
(if (= j 63)
(let ((in (make-vector 16 (cons 0 0)))
(k 0)
(kk 0))
(while (< k 16)
(aset in k (md5-pack md5-input kk))
(setq k (+ k 1) kk (+ kk 4)))
(md5-transform in))))))
(defun md5-pack (array i)
"Pack the four bytes at ARRAY reference I to I+3 into a 32-bit integer."
(cons (+ (lsh (aref array (+ i 3)) 8) (aref array (+ i 2)))
(+ (lsh (aref array (+ i 1)) 8) (aref array (+ i 0)))))
(defun md5-byte (array n b)
"Unpack byte B (0 to 3) from Nth member of ARRAY of 32-bit integers."
(let ((e (aref array n)))
(cond ((eq b 0) (logand 255 (cdr e)))
((eq b 1) (lsh (cdr e) -8))
((eq b 2) (logand 255 (car e)))
((eq b 3) (lsh (car e) -8)))))
(defun md5-final ()
(let ((in (make-vector 16 (cons 0 0)))
(j 0)
(digest (make-vector 16 0))
(padding))
;; Save the number of bits in the message
(aset in 14 (cons (aref md5-bits 1) (aref md5-bits 0)))
(aset in 15 (cons (aref md5-bits 3) (aref md5-bits 2)))
;; Compute number of bytes modulo 64
(setq j (% (/ (aref md5-bits 0) 8) 64))
;; Pad out computation to 56 bytes modulo 64
(setq padding (make-vector (if (< j 56) (- 56 j) (- 120 j)) 0))
(aset padding 0 128)
(md5-update padding)
;; Append length in bits and transform
(let ((k 0) (kk 0))
(while (< k 14)
(aset in k (md5-pack md5-input kk))
(setq k (+ k 1) kk (+ kk 4))))
(md5-transform in)
;; Store the results in the digest
(let ((k 0) (kk 0))
(while (< k 4)
(aset digest (+ kk 0) (md5-byte md5-buffer k 0))
(aset digest (+ kk 1) (md5-byte md5-buffer k 1))
(aset digest (+ kk 2) (md5-byte md5-buffer k 2))
(aset digest (+ kk 3) (md5-byte md5-buffer k 3))
(setq k (+ k 1) kk (+ kk 4))))
;; Return digest
digest))
;; It says in the RSA source, "Note that if the Mysterious Constants are
;; arranged backwards in little-endian order and decrypted with the DES
;; they produce OCCULT MESSAGES!" Security through obscurity?
(defun md5-transform (in)
"Basic MD5 step. Transform md5-buffer based on array IN."
(let ((a (aref md5-buffer 0))
(b (aref md5-buffer 1))
(c (aref md5-buffer 2))
(d (aref md5-buffer 3)))
(setq
a (md5-FF a b c d (aref in 0) 7 '(55146 . 42104))
d (md5-FF d a b c (aref in 1) 12 '(59591 . 46934))
c (md5-FF c d a b (aref in 2) 17 '( 9248 . 28891))
b (md5-FF b c d a (aref in 3) 22 '(49597 . 52974))
a (md5-FF a b c d (aref in 4) 7 '(62844 . 4015))
d (md5-FF d a b c (aref in 5) 12 '(18311 . 50730))
c (md5-FF c d a b (aref in 6) 17 '(43056 . 17939))
b (md5-FF b c d a (aref in 7) 22 '(64838 . 38145))
a (md5-FF a b c d (aref in 8) 7 '(27008 . 39128))
d (md5-FF d a b c (aref in 9) 12 '(35652 . 63407))
c (md5-FF c d a b (aref in 10) 17 '(65535 . 23473))
b (md5-FF b c d a (aref in 11) 22 '(35164 . 55230))
a (md5-FF a b c d (aref in 12) 7 '(27536 . 4386))
d (md5-FF d a b c (aref in 13) 12 '(64920 . 29075))
c (md5-FF c d a b (aref in 14) 17 '(42617 . 17294))
b (md5-FF b c d a (aref in 15) 22 '(18868 . 2081))
a (md5-GG a b c d (aref in 1) 5 '(63006 . 9570))
d (md5-GG d a b c (aref in 6) 9 '(49216 . 45888))
c (md5-GG c d a b (aref in 11) 14 '( 9822 . 23121))
b (md5-GG b c d a (aref in 0) 20 '(59830 . 51114))
a (md5-GG a b c d (aref in 5) 5 '(54831 . 4189))
d (md5-GG d a b c (aref in 10) 9 '( 580 . 5203))
c (md5-GG c d a b (aref in 15) 14 '(55457 . 59009))
b (md5-GG b c d a (aref in 4) 20 '(59347 . 64456))
a (md5-GG a b c d (aref in 9) 5 '( 8673 . 52710))
d (md5-GG d a b c (aref in 14) 9 '(49975 . 2006))
c (md5-GG c d a b (aref in 3) 14 '(62677 . 3463))
b (md5-GG b c d a (aref in 8) 20 '(17754 . 5357))
a (md5-GG a b c d (aref in 13) 5 '(43491 . 59653))
d (md5-GG d a b c (aref in 2) 9 '(64751 . 41976))
c (md5-GG c d a b (aref in 7) 14 '(26479 . 729))
b (md5-GG b c d a (aref in 12) 20 '(36138 . 19594))
a (md5-HH a b c d (aref in 5) 4 '(65530 . 14658))
d (md5-HH d a b c (aref in 8) 11 '(34673 . 63105))
c (md5-HH c d a b (aref in 11) 16 '(28061 . 24866))
b (md5-HH b c d a (aref in 14) 23 '(64997 . 14348))
a (md5-HH a b c d (aref in 1) 4 '(42174 . 59972))
d (md5-HH d a b c (aref in 4) 11 '(19422 . 53161))
c (md5-HH c d a b (aref in 7) 16 '(63163 . 19296))
b (md5-HH b c d a (aref in 10) 23 '(48831 . 48240))
a (md5-HH a b c d (aref in 13) 4 '(10395 . 32454))
d (md5-HH d a b c (aref in 0) 11 '(60065 . 10234))
c (md5-HH c d a b (aref in 3) 16 '(54511 . 12421))
b (md5-HH b c d a (aref in 6) 23 '( 1160 . 7429))
a (md5-HH a b c d (aref in 9) 4 '(55764 . 53305))
d (md5-HH d a b c (aref in 12) 11 '(59099 . 39397))
c (md5-HH c d a b (aref in 15) 16 '( 8098 . 31992))
b (md5-HH b c d a (aref in 2) 23 '(50348 . 22117))
a (md5-II a b c d (aref in 0) 6 '(62505 . 8772))
d (md5-II d a b c (aref in 7) 10 '(17194 . 65431))
c (md5-II c d a b (aref in 14) 15 '(43924 . 9127))
b (md5-II b c d a (aref in 5) 21 '(64659 . 41017))
a (md5-II a b c d (aref in 12) 6 '(25947 . 22979))
d (md5-II d a b c (aref in 3) 10 '(36620 . 52370))
c (md5-II c d a b (aref in 10) 15 '(65519 . 62589))
b (md5-II b c d a (aref in 1) 21 '(34180 . 24017))
a (md5-II a b c d (aref in 8) 6 '(28584 . 32335))
d (md5-II d a b c (aref in 15) 10 '(65068 . 59104))
c (md5-II c d a b (aref in 6) 15 '(41729 . 17172))
b (md5-II b c d a (aref in 13) 21 '(19976 . 4513))
a (md5-II a b c d (aref in 4) 6 '(63315 . 32386))
d (md5-II d a b c (aref in 11) 10 '(48442 . 62005))
c (md5-II c d a b (aref in 2) 15 '(10967 . 53947))
b (md5-II b c d a (aref in 9) 21 '(60294 . 54161)))
(aset md5-buffer 0 (md5-add (aref md5-buffer 0) a))
(aset md5-buffer 1 (md5-add (aref md5-buffer 1) b))
(aset md5-buffer 2 (md5-add (aref md5-buffer 2) c))
(aset md5-buffer 3 (md5-add (aref md5-buffer 3) d))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Here begins the merger with the XEmacs API and the md5.el from the URL
;;; package. Courtesy wmperry@spry.com
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun md5 (object &optional start end)
"Return the MD5 (a secure message digest algorithm) of an object.
OBJECT is either a string or a buffer.
Optional arguments START and END denote buffer positions for computing the
hash of a portion of OBJECT."
(let ((buffer nil))
(unwind-protect
(save-excursion
(setq buffer (generate-new-buffer " *md5-work*"))
(set-buffer buffer)
(cond
((bufferp object)
(insert-buffer-substring object start end))
((stringp object)
(insert (if (or start end)
(substring object start end)
object)))
(t nil))
(prog1
(if (<= (point-max) md5-maximum-internal-length)
(mapconcat
(function (lambda (node) (format "%02x" node)))
(md5-encode (buffer-string))
"")
(call-process-region (point-min) (point-max)
(or shell-file-name "/bin/sh")
t buffer nil
"-c" md5-program)
;; MD5 digest is 32 chars long
;; mddriver adds a newline to make neaten output for tty
;; viewing, make sure we leave it behind.
(buffer-substring (point-min) (+ (point-min) 32)))
(kill-buffer buffer)))
(and buffer (kill-buffer buffer) nil))))
(provide 'md5)
;;; md5.el ends here ----------------------------------------------------------

156
lisp/gnus/nnheaderxm.el
View file

@ -1,156 +0,0 @@
;;; nnheaderxm.el --- making Gnus backends work under XEmacs
;; Copyright (C) 1996,97 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
;; Keywords: news
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;;; Code:
(eval-and-compile
(autoload 'nnheader-insert-file-contents "nnheader"))
(defun nnheader-xmas-run-at-time (time repeat function &rest args)
(start-itimer
"nnheader-run-at-time"
`(lambda ()
(,function ,@args))
time repeat))
(defun nnheader-xmas-cancel-timer (timer)
(delete-itimer timer))
(defun nnheader-xmas-cancel-function-timers (function)
)
(defun nnheader-xmas-find-file-noselect (filename &optional nowarn rawfile)
"Read file FILENAME into a buffer and return the buffer.
If a buffer exists visiting FILENAME, return that one, but
verify that the file has not changed since visited or saved.
The buffer is not selected, just returned to the caller."
(setq filename
(abbreviate-file-name
(expand-file-name filename)))
(if (file-directory-p filename)
(if find-file-run-dired
(dired-noselect filename)
(error "%s is a directory." filename))
(let* ((buf (get-file-buffer filename))
(truename (abbreviate-file-name (file-truename filename)))
(number (nthcdr 10 (file-attributes truename)))
;; Find any buffer for a file which has same truename.
(other (and (not buf)
(get-file-buffer filename)))
error)
;; Let user know if there is a buffer with the same truename.
(when other
(or nowarn
(string-equal filename (buffer-file-name other))
(message "%s and %s are the same file"
filename (buffer-file-name other)))
;; Optionally also find that buffer.
(when (or (and (boundp 'find-file-existing-other-name)
find-file-existing-other-name)
find-file-visit-truename)
(setq buf other)))
(if buf
(or nowarn
(verify-visited-file-modtime buf)
(cond ((not (file-exists-p filename))
(error "File %s no longer exists!" filename))
((yes-or-no-p
(if (string= (file-name-nondirectory filename)
(buffer-name buf))
(format
(if (buffer-modified-p buf)
"File %s changed on disk. Discard your edits? "
"File %s changed on disk. Reread from disk? ")
(file-name-nondirectory filename))
(format
(if (buffer-modified-p buf)
"File %s changed on disk. Discard your edits in %s? "
"File %s changed on disk. Reread from disk into %s? ")
(file-name-nondirectory filename)
(buffer-name buf))))
(save-excursion
(set-buffer buf)
(revert-buffer t t)))))
(save-excursion
;;; The truename stuff makes this obsolete.
;;; (let* ((link-name (car (file-attributes filename)))
;;; (linked-buf (and (stringp link-name)
;;; (get-file-buffer link-name))))
;;; (if (bufferp linked-buf)
;;; (message "Symbolic link to file in buffer %s"
;;; (buffer-name linked-buf))))
(setq buf (create-file-buffer filename))
;; (set-buffer-major-mode buf)
(set-buffer buf)
(erase-buffer)
(if rawfile
(condition-case ()
(nnheader-insert-file-contents filename t)
(file-error
;; Unconditionally set error
(setq error t)))
(condition-case ()
(insert-file-contents filename t)
(file-error
;; Run find-file-not-found-hooks until one returns non-nil.
(or t ; (run-hook-with-args-until-success 'find-file-not-found-hooks)
;; If they fail too, set error.
(setq error t)))))
;; Find the file's truename, and maybe use that as visited name.
(setq buffer-file-truename truename)
(setq buffer-file-number number)
;; On VMS, we may want to remember which directory in a search list
;; the file was found in.
(and (eq system-type 'vax-vms)
(let (logical)
(when (string-match ":" (file-name-directory filename))
(setq logical (substring (file-name-directory filename)
0 (match-beginning 0))))
(not (member logical find-file-not-true-dirname-list)))
(setq buffer-file-name buffer-file-truename))
(when find-file-visit-truename
(setq buffer-file-name
(setq filename
(expand-file-name buffer-file-truename))))
;; Set buffer's default directory to that of the file.
(setq default-directory (file-name-directory filename))
;; Turn off backup files for certain file names. Since
;; this is a permanent local, the major mode won't eliminate it.
(when (not (funcall backup-enable-predicate buffer-file-name))
(make-local-variable 'backup-inhibited)
(setq backup-inhibited t))
(if rawfile
nil
(after-find-file error (not nowarn)))))
buf)))
(fset 'nnheader-run-at-time 'nnheader-xmas-run-at-time)
(fset 'nnheader-cancel-timer 'nnheader-xmas-cancel-timer)
(fset 'nnheader-cancel-function-timers 'nnheader-xmas-cancel-function-timers)
(fset 'nnheader-find-file-noselect 'nnheader-xmas-find-file-noselect)
(provide 'nnheaderxm)
;;; nnheaderxm.el ends here.

220
lisp/gnusmail.el
View file

@ -1,220 +0,0 @@
;;; gnusmail.el --- mail reply commands for GNUS newsreader
;; Copyright (C) 1990, 1993 Free Software Foundation, Inc.
;; Author: Masanobu UMEDA <umerin@mse.kyutech.ac.jp>
;; Keywords: news
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;;; Commentary:
;; Provides mail reply and mail other window command using usual mail
;; interface and mh-e interface.
;;
;; To use MAIL: set the variables gnus-mail-reply-method and
;; gnus-mail-other-window-method to gnus-mail-reply-using-mail and
;; gnus-mail-other-window-using-mail, respectively.
;;
;; To use MH-E: set the variables gnus-mail-reply-method and
;; gnus-mail-other-window-method to gnus-mail-reply-using-mhe and
;; gnus-mail-other-window-using-mhe, respectively.
;;; Code:
(require 'gnus)
(autoload 'news-mail-reply "rnewspost")
(autoload 'news-mail-other-window "rnewspost")
(autoload 'mh-send "mh-e")
(autoload 'mh-send-other-window "mh-e")
(autoload 'mh-find-path "mh-e")
(autoload 'mh-yank-cur-msg "mh-e")
;;; Mail reply commands of GNUS Summary Mode
(defun gnus-summary-reply (yank)
"Reply mail to news author.
If prefix argument YANK is non-nil, original article is yanked automatically.
Customize the variable gnus-mail-reply-method to use another mailer."
(interactive "P")
;; Bug fix by jbw@bigbird.bu.edu (Joe Wells)
;; Stripping headers should be specified with mail-yank-ignored-headers.
(gnus-summary-select-article t t)
(switch-to-buffer gnus-article-buffer)
(widen)
(delete-other-windows)
(bury-buffer gnus-article-buffer)
(funcall gnus-mail-reply-method yank))
(defun gnus-summary-reply-with-original ()
"Reply mail to news author with original article.
Customize the variable gnus-mail-reply-method to use another mailer."
(interactive)
(gnus-summary-reply t))
(defun gnus-summary-mail-forward ()
"Forward the current message to another user.
Customize the variable gnus-mail-forward-method to use another mailer."
(interactive)
(gnus-summary-select-article)
(switch-to-buffer gnus-article-buffer)
(widen)
(delete-other-windows)
(bury-buffer gnus-article-buffer)
(funcall gnus-mail-forward-method))
(defun gnus-summary-mail-other-window ()
"Compose mail in other window.
Customize the variable gnus-mail-other-window-method to use another mailer."
(interactive)
(gnus-summary-select-article)
(switch-to-buffer gnus-article-buffer)
(widen)
(delete-other-windows)
(bury-buffer gnus-article-buffer)
(funcall gnus-mail-other-window-method))
;;; 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
;; <itojun@ingram.mt.cs.keio.ac.jp>
(defun gnus-mail-forward-using-mhe ()
"Forward the current message to another user using mh-e."
;; First of all, prepare mhe mail buffer.
(let ((to (read-string "To: "))
(cc (read-string "Cc: "))
(buffer (current-buffer))
subject)
;;(gnus-article-show-all-headers)
(setq subject
(concat "[" gnus-newsgroup-name "] "
;;(mail-strip-quoted-names (gnus-fetch-field "From")) ": "
(or (gnus-fetch-field "subject") "")))
(setq mh-show-buffer buffer)
(mh-find-path)
(mh-send to (or cc "") subject)
(save-excursion
(goto-char (point-max))
(insert "\n------- Forwarded Message\n\n")
(insert-buffer buffer)
(goto-char (point-max))
(insert "\n------- End of Forwarded Message\n")
(setq mh-sent-from-folder buffer)
(setq mh-sent-from-msg 1))))
(defun gnus-mail-other-window-using-mhe ()
"Compose mail other window using mh-e."
(let ((to (read-string "To: "))
(cc (read-string "Cc: "))
(subject (read-string "Subject: " (gnus-fetch-field "subject"))))
(gnus-article-show-all-headers) ;I don't think this is really needed.
(setq mh-show-buffer (current-buffer))
(mh-find-path)
(mh-send-other-window to cc subject)
(setq mh-sent-from-folder (current-buffer))
(setq mh-sent-from-msg 1)))
(provide 'gnusmail)
;;; gnusmail.el ends here

294
lisp/gnusmisc.el
View file

@ -1,294 +0,0 @@
;;; gnusmisc.el --- miscellaneous commands for GNUS newsreader
;; Copyright (C) 1989, 1990, 1993 Free Software Foundation, Inc.
;; Author: Masanobu UMEDA <umerin@mse.kyutech.ac.jp>
;; Keywords: news
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;;; Code:
(require 'gnus)
;;;
;;; GNUS Browse-Killed Mode
;;;
;; Some ideas are due to roland@wheaties.ai.mit.edu (Roland McGrath).
;; I'd like to thank him very much.
(defvar gnus-browse-killed-mode-hook nil
"*A hook for GNUS Browse-Killed Mode.")
(defvar gnus-browse-killed-buffer "*Killed Newsgroup*")
(defvar gnus-browse-killed-mode-map nil)
(defvar gnus-winconf-browse-killed nil)
(autoload 'timezone-make-date-arpa-standard "timezone")
(put 'gnus-browse-killed-mode 'mode-class 'special)
;;;
;;; 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

842
lisp/gnuspost.el
View file

@ -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 <umerin@mse.kyutech.ac.jp>
;; Keywords: news
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;;; Code:
(require 'gnus)
(defvar gnus-organization-file "/usr/lib/news/organization"
"*Local news organization file.")
(defvar gnus-post-news-buffer "*post-news*")
(defvar gnus-winconf-post-news nil)
(autoload 'news-reply-mode "rnewspost")
(autoload 'timezone-make-date-arpa-standard "timezone")
;;; Post news commands of GNUS Group Mode and Summary Mode
(defun gnus-group-post-news ()
"Post an article."
(interactive)
;; Save window configuration.
(setq gnus-winconf-post-news (current-window-configuration))
(unwind-protect
(gnus-post-news)
(or (and (eq (current-buffer) (get-buffer gnus-post-news-buffer))
(not (zerop (buffer-size))))
;; Restore last window configuration.
(set-window-configuration gnus-winconf-post-news)))
;; We don't want to return to Summary buffer nor Article buffer later.
(if (get-buffer gnus-summary-buffer)
(bury-buffer gnus-summary-buffer))
(if (get-buffer gnus-article-buffer)
(bury-buffer gnus-article-buffer)))
(defun gnus-summary-post-news ()
"Post an article."
(interactive)
(gnus-summary-select-article t nil)
;; Save window configuration.
(setq gnus-winconf-post-news (current-window-configuration))
(unwind-protect
(progn
(switch-to-buffer gnus-article-buffer)
(widen)
(delete-other-windows)
(gnus-post-news))
(or (and (eq (current-buffer) (get-buffer gnus-post-news-buffer))
(not (zerop (buffer-size))))
;; Restore last window configuration.
(set-window-configuration gnus-winconf-post-news)))
;; We don't want to return to Article buffer later.
(bury-buffer gnus-article-buffer))
(defun gnus-summary-followup (yank)
"Post a reply article.
If prefix argument YANK is non-nil, original article is yanked automatically."
(interactive "P")
(gnus-summary-select-article t nil)
;; Check Followup-To: poster.
(set-buffer gnus-article-buffer)
(if (and gnus-use-followup-to
(string-equal "poster" (gnus-fetch-field "followup-to"))
(or (not (eq gnus-use-followup-to t))
(not (y-or-n-p "Do you want to ignore `Followup-To: poster'? "))))
;; Mail to the poster. GNUS is now RFC1036 compliant.
(gnus-summary-reply yank)
;; Save window configuration.
(setq gnus-winconf-post-news (current-window-configuration))
(unwind-protect
(progn
(switch-to-buffer gnus-article-buffer)
(widen)
(delete-other-windows)
(gnus-news-reply yank))
(or (and (eq (current-buffer) (get-buffer gnus-post-news-buffer))
(not (zerop (buffer-size))))
;; Restore last window configuration.
(set-window-configuration gnus-winconf-post-news)))
;; We don't want to return to Article buffer later.
(bury-buffer gnus-article-buffer)))
(defun gnus-summary-followup-with-original ()
"Post a reply article with original article."
(interactive)
(gnus-summary-followup t))
(defun gnus-summary-cancel-article ()
"Cancel an article you posted."
(interactive)
(gnus-summary-select-article t nil)
(gnus-eval-in-buffer-window gnus-article-buffer
(gnus-cancel-news)))
;;; 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 <mrd@sun.soe.clarkson.edu>.
(if (string-match "\\." (system-name))
(substring (system-name) (match-end 0)))
(read-string "Domain name (no host): ")))
(host (or (if (string-match "\\." (system-name))
(substring (system-name) 0 (match-beginning 0)))
(system-name))))
(if (string-equal "." (substring domain 0 1))
(setq domain (substring domain 1)))
;; Support GENERICFROM as same as standard Bnews system.
;; Suggested by ohm@kaba.junet and vixie@decwrl.dec.com.
(cond ((null genericfrom)
(concat host "." domain))
;;((stringp genericfrom) genericfrom)
(t domain)))
(substring user-mail-address (1+ (string-match "@" user-mail-address)))))
(defun gnus-inews-message-id ()
"Generate unique Message-ID for user."
;; Message-ID should not contain a slash and should be terminated by
;; a number. I don't know the reason why it is so.
(concat "<" (gnus-inews-unique-id) "@" (gnus-inews-domain-name) ">"))
(defun gnus-inews-unique-id ()
"Generate unique ID from user name and current time."
(let ((date (current-time-string))
(name (gnus-inews-login-name)))
(if (string-match "^[^ ]+ \\([^ ]+\\)[ ]+\\([0-9]+\\) \\([0-9]+\\):\\([0-9]+\\):\\([0-9]+\\) [0-9][0-9]\\([0-9][0-9]\\)"
date)
(concat (upcase name) "."
(substring date (match-beginning 6) (match-end 6)) ;Year
(substring date (match-beginning 1) (match-end 1)) ;Month
(substring date (match-beginning 2) (match-end 2)) ;Day
(substring date (match-beginning 3) (match-end 3)) ;Hour
(substring date (match-beginning 4) (match-end 4)) ;Minute
(substring date (match-beginning 5) (match-end 5)) ;Second
)
(error "Cannot understand current-time-string: %s." date))
))
(defun gnus-current-time-zone (time)
"The local time zone in effect at TIME, or nil if not known."
(let ((z (and (fboundp 'current-time-zone) (current-time-zone time))))
(if (and z (car z)) z gnus-local-timezone)))
(defun gnus-inews-date ()
"Date string of today.
If `current-time-zone' works, or if `gnus-local-timezone' is set correctly,
this yields a date that conforms to RFC 822. Otherwise a buggy date will
be generated; this might work with some older news servers."
(let* ((now (and (fboundp 'current-time) (current-time)))
(zone (gnus-current-time-zone now)))
(if zone
(gnus-inews-valid-date now zone)
;; No timezone info.
(gnus-inews-buggy-date now))))
(defun gnus-inews-valid-date (&optional time zone)
"A date string that represents TIME and conforms to the Usenet standard.
TIME is optional and defaults to the current time.
Some older versions of Emacs always act as if TIME is nil.
The optional argument ZONE specifies the local time zone (default GMT)."
(timezone-make-date-arpa-standard
(if (fboundp 'current-time)
(current-time-string time)
(current-time-string))
zone "GMT"))
(defun gnus-inews-buggy-date (&optional time)
"A buggy date string that represents TIME.
TIME is optional and defaults to the current time.
Some older versions of Emacs always act as if TIME is nil."
(let ((date (if (fboundp 'current-time)
(current-time-string time)
(current-time-string))))
(if (string-match "^[^ ]+ \\([^ ]+\\)[ ]+\\([0-9]+\\) \\([0-9:]+\\) [0-9][0-9]\\([0-9][0-9]\\)"
date)
(concat (substring date (match-beginning 2) (match-end 2)) ;Day
" "
(substring date (match-beginning 1) (match-end 1)) ;Month
" "
(substring date (match-beginning 4) (match-end 4)) ;Year
" "
(substring date (match-beginning 3) (match-end 3))) ;Time
(error "Cannot understand current-time-string: %s." date))
))
(defun gnus-inews-organization ()
"Return user's organization.
The ORGANIZATION environment variable is used if defined.
If not, the variable gnus-local-organization is used instead.
If the value begins with a slash, it is taken as the name of a file
containing the organization."
;; The organization must be got in this order since the ORGANIZATION
;; environment variable is intended for user specific while
;; gnus-local-organization is for machine or organization specific.
;; Note: compatibility hack. This will be removed in the next version.
(and (null gnus-local-organization)
(boundp 'gnus-your-organization)
(setq gnus-local-organization gnus-your-organization))
;; End of compatibility hack.
(let* ((private-file (expand-file-name "~/.organization" nil))
(organization (or (getenv "ORGANIZATION")
gnus-local-organization
private-file)))
(and (stringp organization)
(> (length organization) 0)
(string-equal (substring organization 0 1) "/")
;; Get it from the user and system file.
;; Suggested by roland@wheaties.ai.mit.edu (Roland McGrath).
(let ((dist (mail-fetch-field "distribution")))
(setq organization
(cond ((file-exists-p (concat organization "-" dist))
(concat organization "-" dist))
((file-exists-p organization) organization)
((file-exists-p gnus-organization-file)
gnus-organization-file)
(t organization)))
))
(cond ((not (stringp organization)) nil)
((and (string-equal (substring organization 0 1) "/")
(file-exists-p organization))
;; If the first character is `/', assume it is the name of
;; a file containing the organization.
(save-excursion
(let ((tmpbuf (get-buffer-create " *GNUS organization*")))
(set-buffer tmpbuf)
(erase-buffer)
(insert-file-contents organization)
(prog1 (buffer-string)
(kill-buffer tmpbuf))
)))
((string-equal organization private-file) nil) ;No such file
(t organization))
))
(defun gnus-inews-lines ()
"Count the number of lines and return numeric string."
(save-excursion
(save-restriction
(widen)
(goto-char (point-min))
(search-forward "\n\n" nil 'move)
(int-to-string (count-lines (point) (point-max))))))
(provide 'gnuspost)
;;; gnuspost.el ends here

117
lisp/gosmacs.el
View file

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

41
lisp/grow-vers.el
View file

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

54
lisp/inc-vers.el
View file

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

608
lisp/isearch-old.el
View file

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

104
lisp/iso8859-1.el
View file

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

254
lisp/libc.el
View file

@ -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 <rs@purple.UL.BaWue.DE>
;;; Keywords: local c info
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;; This code has a long history. It started as a minor
;; mode for C mode. This era ended with the release of version 2
;; of the GNU C Library in 1997. The code was therefore rewritten
;; more or less from scratch so that all lookups are performed via
;; indices. Not finding an existing symbol in an index means that
;; there is an error in the manual. Long missed features like a
;; separate input history, symbol name completion in the mini-buffer,
;; highlighting of looked up symbol names in the Info buffer, and
;; implicitly prepending `struct', `union' or `enum' to data types
;; were added in this phase too.
;;; Code:
(require 'info)
(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

1186
lisp/man.el
View file

File diff suppressed because it is too large Load diff

123
lisp/medit.el
View file

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

2933
lisp/mh-e.el
View file

File diff suppressed because it is too large Load diff

490
lisp/mhspool.el
View file

@ -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 <umerin@flab.flab.fujitsu.junet>
;; Maintainer: FSF
;; Keywords: mail, news
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;;; Commentary:
;; This package enables you to read mail or articles in MH folders, or
;; articles saved by GNUS. In any case, the file names of mail or
;; articles must consist of only numeric letters.
;; Before using this package, you have to create a server specific
;; startup file according to the directory which you want to read. For
;; example, if you want to read mail under the directory named
;; `~/Mail', the file must be a file named `.newsrc-:Mail'. (There is
;; no way to specify hierarchical directory now.) In this case, the
;; name of the NNTP server passed to GNUS must be `:Mail'.
;;; Code:
(require 'nntp)
(defvar mhspool-list-folders-method
(function mhspool-list-folders-using-sh)
"*Function to list files in folders.
The function should accept a directory as its argument, and fill the
current buffer with file and directory names. The output format must
be the same as that of 'ls -R1'. Two functions
mhspool-list-folders-using-ls and mhspool-list-folders-using-sh are
provided now. I suppose the later is faster.")
(defvar mhspool-list-directory-switches '("-R")
"*Switches for mhspool-list-folders-using-ls to pass to `ls' for getting file lists.
One entry should appear on one line. You may need to add `-1' option.")
(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

848
lisp/mim-mode.el
View file

@ -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
<FOO ...> will be indented n spaces from start of form.
\(put 'FOO 'indent-mim-function 'DEFINE\) is like above but means use
value of mim-body-indent as offset from start of form.
\(put 'FOO 'indent-mim-function <cons>\) where <cons> is a list or pointed list
of integers, means indent each form in <FOO ...> by the amount specified
in <cons>. When <cons> is exhausted, indent remaining forms by
`mim-body-indent' unless <cons> is a pointed list, in which case the last
cdr is used. Confused? Here is an example:
\(put 'FROBIT 'indent-mim-function '\(4 2 . 1\)\)
<FROBIT
<CHOMP-IT>
<CHOMP-SOME-MORE>
<DIGEST>
<BELCH>
...>
Finally, the property can be a function name (read the code).")
(defvar indent-mim-comment t
"*Non-nil means indent string comments.")
(defvar mim-body-indent 2
"*Amount to indent in special forms which have DEFINE property on
`indent-mim-function'.")
(defvar indent-mim-arglist t
"*nil means indent arglists like ordinary lists.
t means strings stack under start of arglist and variables stack to
right of them. Otherwise, strings stack under last string (or start
of arglist if none) and variables stack to right of them.
Examples (for values 'stack, t, nil):
\(FOO \"OPT\" BAR \(FOO \"OPT\" BAR \(FOO \"OPT\" BAR
BAZ MUMBLE BAZ MUMBLE BAZ MUMBLE
\"AUX\" \"AUX\" \"AUX\"
BLETCH ... BLETCH ... BLETCH ...")
(put 'DEFINE 'indent-mim-function 'DEFINE)
(put 'DEFMAC 'indent-mim-function 'DEFINE)
(put 'BIND 'indent-mim-function 'DEFINE)
(put 'PROG 'indent-mim-function 'DEFINE)
(put 'REPEAT 'indent-mim-function 'DEFINE)
(put 'CASE 'indent-mim-function 'DEFINE)
(put 'FUNCTION 'indent-mim-function 'DEFINE)
(put 'MAPF 'indent-mim-function 'DEFINE)
(put 'MAPR 'indent-mim-function 'DEFINE)
(put 'UNWIND 'indent-mim-function (cons (* 2 mim-body-indent) mim-body-indent))
(defvar mim-down-parens-only t
"*nil means treat ADECLs and ATOM trailers like structures when
moving down a level of structure.")
(defvar mim-stop-for-slop t
"*Non-nil means {next previous}-mim-object consider any
non-whitespace character in column 0 to be a toplevel object, otherwise
only open paren syntax characters will be considered.")
(defalias 'mdl-mode 'mim-mode)
(defun mim-mode ()
"Major mode for editing Mim (MDL in MDL) code.
Commands:
If value of `mim-mode-hysterical-bindings' is non-nil, then following
commands are assigned to escape keys as well (e.g. ESC f = ESC C-f).
The default action is bind the escape keys.
\\{mim-mode-map}
Other Commands:
Use \\[describe-function] to obtain documentation.
replace-in-mim-object find-mim-definition fast-syntax-check-mim
slow-syntax-check-mim backward-down-mim-object forward-up-mim-object
Variables:
Use \\[describe-variable] to obtain documentation.
mim-mode-hook indent-mim-comment indent-mim-arglist indent-mim-function
mim-body-indent mim-down-parens-only mim-stop-for-slop
mim-mode-hysterical-bindings
Entry to this mode calls the value of mim-mode-hook if non-nil."
(interactive)
(kill-all-local-variables)
(if (not mim-mode-map)
(progn
(setq mim-mode-map (make-sparse-keymap))
(define-key mim-mode-map "\e\^o" 'open-mim-line)
(define-key mim-mode-map "\e\^q" 'indent-mim-object)
(define-key mim-mode-map "\e\^p" 'previous-mim-object)
(define-key mim-mode-map "\e\^n" 'next-mim-object)
(define-key mim-mode-map "\e\^a" 'beginning-of-DEFINE)
(define-key mim-mode-map "\e\^e" 'end-of-DEFINE)
(define-key mim-mode-map "\e\^t" 'transpose-mim-objects)
(define-key mim-mode-map "\e\^u" 'backward-up-mim-object)
(define-key mim-mode-map "\e\^d" 'forward-down-mim-object)
(define-key mim-mode-map "\e\^h" 'mark-mim-object)
(define-key mim-mode-map "\e\^k" 'forward-kill-mim-object)
(define-key mim-mode-map "\e\^f" 'forward-mim-object)
(define-key mim-mode-map "\e\^b" 'backward-mim-object)
(define-key mim-mode-map "\e^" 'raise-mim-line)
(define-key mim-mode-map "\e\\" 'fixup-whitespace)
(define-key mim-mode-map "\177" 'backward-delete-char-untabify)
(define-key mim-mode-map "\e\177" 'backward-kill-mim-object)
(define-key mim-mode-map "\^j" 'newline-and-mim-indent)
(define-key mim-mode-map "\e;" 'begin-mim-comment)
(define-key mim-mode-map "\t" 'indent-mim-line)
(define-key mim-mode-map "\e\t" 'indent-mim-object)
(if (not mim-mode-hysterical-bindings)
nil
;; i really hate this but too many people are accustomed to these.
(define-key mim-mode-map "\e!" 'line-to-top-of-window)
(define-key mim-mode-map "\eo" 'open-mim-line)
(define-key mim-mode-map "\ep" 'previous-mim-object)
(define-key mim-mode-map "\en" 'next-mim-object)
(define-key mim-mode-map "\ea" 'beginning-of-DEFINE)
(define-key mim-mode-map "\ee" 'end-of-DEFINE)
(define-key mim-mode-map "\et" 'transpose-mim-objects)
(define-key mim-mode-map "\eu" 'backward-up-mim-object)
(define-key mim-mode-map "\ed" 'forward-down-mim-object)
(define-key mim-mode-map "\ek" 'forward-kill-mim-object)
(define-key mim-mode-map "\ef" 'forward-mim-object)
(define-key mim-mode-map "\eb" 'backward-mim-object))))
(use-local-map mim-mode-map)
(set-syntax-table mim-mode-syntax-table)
(make-local-variable 'paragraph-start)
(setq paragraph-start (concat "$\\|" page-delimiter))
(make-local-variable 'paragraph-separate)
(setq paragraph-separate paragraph-start)
(make-local-variable 'paragraph-ignore-fill-prefix)
(setq paragraph-ignore-fill-prefix t)
;; Most people use string comments.
(make-local-variable 'comment-start)
(setq comment-start ";\"")
(make-local-variable 'comment-start-skip)
(setq comment-start-skip ";\"")
(make-local-variable 'comment-end)
(setq comment-end "\"")
(make-local-variable 'comment-column)
(setq comment-column 40)
(make-local-variable 'comment-indent-function)
(setq comment-indent-function 'indent-mim-comment)
;; tell generic indenter how to indent.
(make-local-variable 'indent-line-function)
(setq indent-line-function 'indent-mim-line)
;; look for that paren
(make-local-variable 'blink-matching-paren-distance)
(setq blink-matching-paren-distance nil)
;; so people who dont like tabs can turn them off locally in indenter.
(make-local-variable 'indent-tabs-mode)
(setq indent-tabs-mode t)
(setq local-abbrev-table mim-mode-abbrev-table)
(setq major-mode 'mim-mode)
(setq mode-name "Mim")
(run-hooks 'mim-mode-hook))
(defun line-to-top-of-window ()
"Move current line to top of window."
(interactive) ; for lazy people
(recenter 0))
(defun forward-mim-object (arg)
"Move forward across Mim object.
With ARG, move forward that many objects."
(interactive "p")
;; this function is weird because it emulates the behavior of the old
;; (gosling) mim-mode - if the arg is 1 and we are `inside' an ADECL,
;; more than one character into the ATOM part and not sitting on the
;; colon, then we move to the DECL part (just past colon) instead of
;; the end of the object (the entire ADECL). otherwise, ADECL's are
;; atomic objects. likewise for ATOM trailers.
(if (= (abs arg) 1)
(if (inside-atom-p)
;; Move to end of ATOM or to trailer (!) or to ADECL (:).
(forward-sexp arg)
;; Either scan an sexp or move over one bracket.
(forward-mim-objects arg t))
;; in the multi-object case, don't perform any magic.
;; treats ATOM trailers and ADECLs atomically, stops at unmatched
;; brackets with error.
(forward-mim-objects arg)))
(defun inside-atom-p ()
;; Returns t iff inside an atom (takes account of trailers)
(let ((c1 (preceding-char))
(c2 (following-char)))
(and (or (= (char-syntax c1) ?w) (= (char-syntax c1) ?_) (= c1 ?!))
(or (= (char-syntax c2) ?w) (= (char-syntax c2) ?_) (= c2 ?!)))))
(defun forward-mim-objects (arg &optional skip-bracket-p)
;; Move over arg objects ignoring ADECLs and trailers. If
;; skip-bracket-p is non-nil, then move over one bracket on error.
(let ((direction (sign arg)))
(condition-case conditions
(while (/= arg 0)
(forward-sexp direction)
(if (not (inside-adecl-or-trailer-p direction))
(setq arg (- arg direction))))
(error (if (not skip-bracket-p)
(signal 'error (cdr conditions))
(skip-mim-whitespace direction)
(goto-char (+ (point) direction)))))
;; If we moved too far move back to first interesting character.
(if (= (point) (buffer-end direction)) (skip-mim-whitespace (- direction)))))
(defun backward-mim-object (&optional arg)
"Move backward across Mim object.
With ARG, move backward that many objects."
(interactive "p")
(forward-mim-object (if arg (- arg) -1)))
(defun mark-mim-object (&optional arg)
"Mark following Mim object.
With ARG, mark that many following (preceding, ARG < 0) objects."
(interactive "p")
(push-mark (save-excursion (forward-mim-object (or arg 1)) (point))))
(defun forward-kill-mim-object (&optional arg)
"Kill following Mim object.
With ARG, kill that many objects."
(interactive "*p")
(kill-region (point) (progn (forward-mim-object (or arg 1)) (point))))
(defun backward-kill-mim-object (&optional arg)
"Kill preceding Mim object.
With ARG, kill that many objects."
(interactive "*p")
(forward-kill-mim-object (- (or arg 1))))
(defun raise-mim-line (&optional arg)
"Raise following line, fixing up whitespace at join.
With ARG raise that many following lines.
A negative ARG will raise current line and previous lines."
(interactive "*p")
(let* ((increment (sign (or arg (setq arg 1))))
(direction (if (> arg 0) 1 0)))
(save-excursion
(while (/= arg 0)
;; move over eol and kill it
(forward-line direction)
(delete-region (point) (1- (point)))
(fixup-whitespace)
(setq arg (- arg increment))))))
(defun forward-down-mim-object (&optional arg)
"Move down a level of Mim structure forwards.
With ARG, move down that many levels forwards (backwards, ARG < 0)."
(interactive "p")
;; another weirdo - going down `inside' an ADECL or ATOM trailer
;; depends on the value of mim-down-parens-only. if nil, treat
;; ADECLs and trailers as structured objects.
(let ((direction (sign (or arg (setq arg 1)))))
(if (and (= (abs arg) 1) (not mim-down-parens-only))
(goto-char
(save-excursion
(skip-mim-whitespace direction)
(if (> direction 0) (re-search-forward "\\s'*"))
(or (and (let ((c (next-char direction)))
(or (= (char-syntax c) ?_)
(= (char-syntax c) ?w)))
(progn (forward-sexp direction)
(if (inside-adecl-or-trailer-p direction)
(point))))
(scan-lists (point) direction -1)
(buffer-end direction))))
(while (/= arg 0)
(goto-char (or (scan-lists (point) direction -1) (buffer-end direction)))
(setq arg (- arg direction))))))
(defun backward-down-mim-object (&optional arg)
"Move down a level of Mim structure backwards.
With ARG, move down that many levels backwards (forwards, ARG < 0)."
(interactive "p")
(forward-down-mim-object (if arg (- arg) -1)))
(defun forward-up-mim-object (&optional arg)
"Move up a level of Mim structure forwards
With ARG, move up that many levels forwards (backwards, ARG < 0)."
(interactive "p")
(let ((direction (sign (or arg (setq arg 1)))))
(while (/= arg 0)
(goto-char (or (scan-lists (point) direction 1) (buffer-end arg)))
(setq arg (- arg direction)))
(if (< direction 0) (backward-prefix-chars))))
(defun backward-up-mim-object (&optional arg)
"Move up a level of Mim structure backwards
With ARG, move up that many levels backwards (forwards, ARG > 0)."
(interactive "p")
(forward-up-mim-object (if arg (- arg) -1)))
(defun replace-in-mim-object (old new)
"Replace string in following Mim object."
(interactive "*sReplace in object: \nsReplace %s with: ")
(save-restriction
(narrow-to-region (point) (save-excursion (forward-mim-object 1) (point)))
(replace-string old new)))
(defun transpose-mim-objects (&optional arg)
"Transpose Mim objects around point.
With ARG, transpose preceding object that many times with following objects.
A negative ARG will transpose backwards."
(interactive "*p")
(transpose-subr 'forward-mim-object (or arg 1)))
(defun beginning-of-DEFINE (&optional arg move)
"Move backward to beginning of surrounding or previous toplevel Mim form.
With ARG, do it that many times. Stops at last toplevel form seen if buffer
end is reached."
(interactive "p")
(let ((direction (sign (or arg (setq arg 1)))))
(if (not move) (setq move t))
(if (< direction 0) (goto-char (1+ (point))))
(while (and (/= arg 0) (re-search-backward "^<" nil move direction))
(setq arg (- arg direction)))
(if (< direction 0)
(goto-char (1- (point))))))
(defun end-of-DEFINE (&optional arg)
"Move forward to end of surrounding or next toplevel mim form.
With ARG, do it that many times. Stops at end of last toplevel form seen
if buffer end is reached."
(interactive "p")
(if (not arg) (setq arg 1))
(if (< arg 0)
(beginning-of-DEFINE (- (1- arg)))
(if (not (looking-at "^<")) (setq arg (1+ arg)))
(beginning-of-DEFINE (- arg) 'move)
(beginning-of-DEFINE 1))
(forward-mim-object 1)
(forward-line 1))
(defun next-mim-object (&optional arg)
"Move to beginning of next toplevel Mim object.
With ARG, do it that many times. Stops at last object seen if buffer end
is reached."
(interactive "p")
(let ((search-string (if mim-stop-for-slop "^\\S " "^\\s("))
(direction (sign (or arg (setq arg 1)))))
(if (> direction 0)
(goto-char (1+ (point)))) ; no error if end of buffer
(while (and (/= arg 0)
(re-search-forward search-string nil t direction))
(setq arg (- arg direction)))
(if (> direction 0)
(goto-char (1- (point)))) ; no error if beginning of buffer
;; scroll to top of window if moving forward and end not visible.
(if (not (or (< direction 0)
(save-excursion (forward-mim-object 1)
(pos-visible-in-window-p (point)))))
(recenter 0))))
(defun previous-mim-object (&optional arg)
"Move to beginning of previous toplevel Mim object.
With ARG do it that many times. Stops at last object seen if buffer end
is reached."
(interactive "p")
(next-mim-object (- (or arg 1))))
(defun calculate-mim-indent (&optional parse-start)
"Calculate indentation for Mim line. Returns column."
(save-excursion ; some excursion, huh, toto?
(beginning-of-line)
(let ((indent-point (point)) retry state containing-sexp last-sexp
desired-indent start peek where paren-depth)
(if parse-start
(goto-char parse-start) ; should be containing environment
(catch 'from-the-top
;; find a place to start parsing. going backwards is fastest.
;; forward-sexp signals error on encountering unmatched open.
(setq retry t)
(while retry
(condition-case nil (forward-sexp -1) (error (setq retry nil)))
(if (looking-at ".?[ \t]*\"")
;; cant parse backward in presence of strings, go forward.
(progn
(goto-char indent-point)
(re-search-backward "^\\s(" nil 'move 1) ; to top of object
(throw 'from-the-top nil)))
(setq retry (and retry (/= (current-column) 0))))
(skip-chars-backward mim-whitespace)
(if (not (bobp)) (forward-char -1)) ; onto unclosed open
(backward-prefix-chars)))
;; find outermost containing sexp if we started inside an sexp.
(while (< (point) indent-point)
(setq state (parse-partial-sexp (point) indent-point 0)))
;; find usual column to indent under (not in string or toplevel).
;; on termination, state will correspond to containing environment
;; (if retry is nil), where will be position of character to indent
;; under normally, and desired-indent will be the column to indent to
;; except if inside form, string, or at toplevel. point will be in
;; in column to indent to unless inside string.
(setq retry t)
(while (and retry (setq paren-depth (car state)) (> paren-depth 0))
;; find innermost containing sexp.
(setq retry nil)
(setq last-sexp (car (nthcdr 2 state)))
(setq containing-sexp (car (cdr state)))
(goto-char (1+ containing-sexp)) ; to last unclosed open
(if (and last-sexp (> last-sexp (point)))
;; is the last sexp a containing sexp?
(progn (setq peek (parse-partial-sexp last-sexp indent-point 0))
(if (setq retry (car (cdr peek))) (setq state peek))))
(if retry
nil
(setq where (1+ containing-sexp)) ; innermost containing sexp
(goto-char where)
(cond
((not last-sexp) ; indent-point after bracket
(setq desired-indent (current-column)))
((= (preceding-char) ?\<) ; it's a form
(cond ((> (progn (forward-sexp 1) (point)) last-sexp)
(goto-char where)) ; only one frob
((> (save-excursion (forward-line 1) (point)) last-sexp)
(skip-chars-forward " \t") ; last-sexp is on same line
(setq where (point))) ; as containing-sexp
((progn
(goto-char last-sexp)
(beginning-of-line)
(parse-partial-sexp (point) last-sexp 0 t)
(or (= (point) last-sexp)
(save-excursion
(= (car (parse-partial-sexp (point) last-sexp 0))
0))))
(backward-prefix-chars) ; last-sexp 1st on line or 1st
(setq where (point))) ; frob on that line level 0
(t (goto-char where)))) ; punt, should never occur
((and indent-mim-arglist ; maybe hack arglist
(= (preceding-char) ?\() ; its a list
(save-excursion ; look for magic atoms
(setq peek 0) ; using peek as counter
(forward-char -1) ; back over containing paren
(while (and (< (setq peek (1+ peek)) 6)
(condition-case nil
(progn (forward-sexp -1) t)
(error nil))))
(and (< peek 6) (looking-at "DEFINE\\|DEFMAC\\|FUNCTION"))))
;; frobs stack under strings they belong to or under first
;; frob to right of strings they belong to unless luser has
;; frob (non-string) on preceding line with different
;; indentation. strings stack under start of arglist unless
;; mim-indent-arglist is not t, in which case they stack
;; under the last string, if any, else the start of the arglist.
(let ((eol 0) last-string)
(while (< (point) last-sexp) ; find out where the strings are
(skip-chars-forward mim-whitespace last-sexp)
(if (> (setq start (point)) eol)
(progn ; simultaneously keeping track
(setq where (min where start))
(end-of-line) ; of indentation of first frob
(setq eol (point)) ; on each line
(goto-char start)))
(if (= (following-char) ?\")
(progn (setq last-string (point))
(forward-sexp 1)
(if (= last-string last-sexp)
(setq where last-sexp)
(skip-chars-forward mim-whitespace last-sexp)
(setq where (point))))
(forward-sexp 1)))
(goto-char indent-point) ; if string is first on
(skip-chars-forward " \t" (point-max)) ; line we are indenting, it
(if (= (following-char) ?\") ; goes under arglist start
(if (and last-string (not (equal indent-mim-arglist t)))
(setq where last-string) ; or under last string.
(setq where (1+ containing-sexp)))))
(goto-char where)
(setq desired-indent (current-column)))
(t ; plain vanilla structure
(cond ((> (save-excursion (forward-line 1) (point)) last-sexp)
(skip-chars-forward " \t") ; last-sexp is on same line
(setq where (point))) ; as containing-sexp
((progn
(goto-char last-sexp)
(beginning-of-line)
(parse-partial-sexp (point) last-sexp 0 t)
(or (= (point) last-sexp)
(save-excursion
(= (car (parse-partial-sexp (point) last-sexp 0))
0))))
(backward-prefix-chars) ; last-sexp 1st on line or 1st
(setq where (point))) ; frob on that line level 0
(t (goto-char where))) ; punt, should never occur
(setq desired-indent (current-column))))))
;; state is innermost containing environment unless toplevel or string.
(if (car (nthcdr 3 state)) ; inside string
(progn
(if last-sexp ; string must be next
(progn (goto-char last-sexp)
(forward-sexp 1)
(search-forward "\"")
(forward-char -1))
(goto-char indent-point) ; toplevel string, look for it
(re-search-backward "[^\\]\"")
(forward-char 1))
(setq start (point)) ; opening double quote
(skip-chars-backward " \t")
(backward-prefix-chars)
;; see if the string is really a comment.
(if (and (looking-at ";[ \t]*\"") indent-mim-comment)
;; it's a comment, line up under the start unless disabled.
(goto-char (1+ start))
;; it's a string, dont mung the indentation.
(goto-char indent-point)
(skip-chars-forward " \t"))
(setq desired-indent (current-column))))
;; point is sitting in usual column to indent to and if retry is nil
;; then state corresponds to containing environment. if desired
;; indentation not determined, we are inside a form, so call hook.
(or desired-indent
(and indent-mim-function
(not retry)
(setq desired-indent
(funcall indent-mim-function state indent-point)))
(setq desired-indent (current-column)))
(goto-char indent-point) ; back to where we started
desired-indent))) ; return column to indent to
(defun indent-mim-function (state indent-point)
"Compute indentation for Mim special forms. Returns column or nil."
(let ((containing-sexp (car (cdr state))) (current-indent (point)))
(save-excursion
(goto-char (1+ containing-sexp))
(backward-prefix-chars)
;; make sure we are looking at a symbol. if so, see if it is a special
;; symbol. if so, add the special indentation to the indentation of
;; the start of the special symbol, unless the property is not
;; an integer and not nil (in this case, call the property, it must
;; be a function which returns the appropriate indentation or nil and
;; does not change the buffer).
(if (looking-at "\\sw\\|\\s_")
(let* ((start (current-column))
(function
(intern-soft (buffer-substring (point)
(progn (forward-sexp 1)
(point)))))
(method (get function 'indent-mim-function)))
(if (or (if (equal method 'DEFINE) (setq method mim-body-indent))
(integerp method))
;; only use method if its first line after containing-sexp.
;; we could have done this in calculate-mim-indent, but someday
;; someone might want to format frobs in a special form based
;; on position instead of indenting uniformly (like lisp if),
;; so preserve right for posterity. if not first line,
;; calculate-mim-indent already knows right indentation -
;; give luser chance to change indentation manually by changing
;; 1st line after containing-sexp.
(if (> (progn (forward-line 1) (point)) (car (nthcdr 2 state)))
(+ method start))
(goto-char current-indent)
(if (consp method)
;; list or pointed list of explicit indentations
(indent-mim-offset state indent-point)
(if (and (symbolp method) (fboundp method))
;; luser function - s/he better know what's going on.
;; should take state and indent-point as arguments - for
;; description of state, see parse-partial-sexp
;; documentation the function is guaranteed the following:
;; (1) state describes the closest surrounding form,
;; (2) indent-point is the beginning of the line being
;; indented, (3) point points to char in column that would
;; normally be used for indentation, (4) function is bound
;; to the special ATOM. See indent-mim-offset for example
;; of a special function.
(funcall method state indent-point)))))))))
(defun indent-mim-offset (state indent-point)
;; offset forms explicitly according to list of indentations.
(let ((mim-body-indent mim-body-indent)
(indentations (get function 'indent-mim-function))
(containing-sexp (car (cdr state)))
(last-sexp (car (nthcdr 2 state)))
indentation)
(goto-char (1+ containing-sexp))
;; determine which of the indentations to use.
(while (and (< (point) indent-point)
(condition-case nil
(progn (forward-sexp 1)
(parse-partial-sexp (point) indent-point 1 t))
(error nil)))
(skip-chars-backward " \t")
(backward-prefix-chars)
(if (= (following-char) ?\;)
nil ; ignore comments
(setq indentation (car indentations))
(if (integerp (setq indentations (cdr indentations)))
;; if last cdr is integer, that is indentation to use for all
;; all the rest of the forms.
(progn (setq mim-body-indent indentations)
(setq indentations nil)))))
(goto-char (1+ containing-sexp))
(+ (current-column) (or indentation mim-body-indent))))
(defun indent-mim-comment (&optional start)
"Indent a one line (string) Mim comment following object, if any."
(let* ((old-point (point)) (eol (progn (end-of-line) (point))) state last-sexp)
;; this function assumes that comment indenting is enabled. it is caller's
;; responsibility to check the indent-mim-comment flag before calling.
(beginning-of-line)
(catch 'no-comment
(setq state (parse-partial-sexp (point) eol))
;; determine if there is an existing regular comment. a `regular'
;; comment is defined as a commented string which is the last thing
;; on the line and does not extend beyond the end of the line.
(if (or (not (setq last-sexp (car (nthcdr 2 state))))
(car (nthcdr 3 state)))
;; empty line or inside string (multiple line).
(throw 'no-comment nil))
;; could be a comment, but make sure its not the only object.
(beginning-of-line)
(parse-partial-sexp (point) eol 0 t)
(if (= (point) last-sexp)
;; only one object on line
(throw 'no-comment t))
(goto-char last-sexp)
(skip-chars-backward " \t")
(backward-prefix-chars)
(if (not (looking-at ";[ \t]*\""))
;; aint no comment
(throw 'no-comment nil))
;; there is an existing regular comment
(delete-horizontal-space)
;; move it to comment-column if possible else to tab-stop
(if (< (current-column) comment-column)
(indent-to comment-column)
(tab-to-tab-stop)))
(goto-char old-point)))
(defun indent-mim-line ()
"Indent line of Mim code."
(interactive "*")
(let* ((position (- (point-max) (point)))
(bol (progn (beginning-of-line) (point)))
(indent (calculate-mim-indent)))
(skip-chars-forward " \t")
(if (/= (current-column) indent)
(progn (delete-region bol (point)) (indent-to indent)))
(if (> (- (point-max) position) (point)) (goto-char (- (point-max) position)))))
(defun newline-and-mim-indent ()
"Insert newline at point and indent."
(interactive "*")
;; commented code would correct indentation of line in arglist which
;; starts with string, but it would indent every line twice. luser can
;; just say tab after typing string to get same effect.
;(if indent-mim-arglist (indent-mim-line))
(newline)
(indent-mim-line))
(defun open-mim-line (&optional lines)
"Insert newline before point and indent.
With ARG insert that many newlines."
(interactive "*p")
(beginning-of-line)
(let ((indent (calculate-mim-indent)))
(while (> lines 0)
(newline)
(forward-line -1)
(indent-to indent)
(setq lines (1- lines)))))
(defun indent-mim-object (&optional dont-indent-first-line)
"Indent object following point and all lines contained inside it.
With ARG, idents only contained lines (skips first line)."
(interactive "*P")
(let (end bol indent start)
(save-excursion (parse-partial-sexp (point) (point-max) 0 t)
(setq start (point))
(forward-sexp 1)
(setq end (- (point-max) (point))))
(save-excursion
(if (not dont-indent-first-line) (indent-mim-line))
(while (progn (forward-line 1) (> (- (point-max) (point)) end))
(setq indent (calculate-mim-indent start))
(setq bol (point))
(skip-chars-forward " \t")
(if (/= indent (current-column))
(progn (delete-region bol (point)) (indent-to indent)))
(if indent-mim-comment (indent-mim-comment))))))
(defun find-mim-definition (name)
"Search for definition of function, macro, or gfcn.
You need type only enough of the name to be unambiguous."
(interactive "sName: ")
(let (where)
(save-excursion
(goto-char (point-min))
(condition-case nil
(progn
(re-search-forward
(concat "^<\\(DEFINE\\|\\DEFMAC\\|FCN\\|GFCN\\)\\([ \t]*\\)"
name))
(setq where (point)))
(error (error "Can't find %s" name))))
(if where
(progn (push-mark)
(goto-char where)
(beginning-of-line)
(recenter 0)))))
(defun begin-mim-comment ()
"Move to existing comment or insert empty comment."
(interactive "*")
(let* ((eol (progn (end-of-line) (point)))
(bol (progn (beginning-of-line) (point))))
;; check for existing comment first.
(if (re-search-forward ";[ \t]*\"" eol t)
;; found it. indent if desired and go there.
(if indent-mim-comment
(let ((where (- (point-max) (point))))
(indent-mim-comment)
(goto-char (- (point-max) where))))
;; nothing there, make a comment.
(let (state last-sexp)
;; skip past all the sexps on the line
(goto-char bol)
(while (and (equal (car (setq state (parse-partial-sexp (point) eol 0)))
0)
(car (nthcdr 2 state)))
(setq last-sexp (car (nthcdr 2 state))))
(if (car (nthcdr 3 state))
nil ; inside a string, punt
(delete-region (point) eol) ; flush trailing whitespace
(if (and (not last-sexp) (equal (car state) 0))
(indent-to (calculate-mim-indent)) ; empty, indent like code
(if (> (current-column) comment-column) ; indent to comment column
(tab-to-tab-stop) ; unless past it, else to
(indent-to comment-column))) ; tab-stop
;; if luser changes comment-{start end} to something besides semi
;; followed by zero or more whitespace characters followed by string
;; delimiters, the code above fails to find existing comments, but as
;; taa says, `let the losers lose'.
(insert comment-start)
(save-excursion (insert comment-end)))))))
(defun skip-mim-whitespace (direction)
(if (>= direction 0)
(skip-chars-forward mim-whitespace (point-max))
(skip-chars-backward mim-whitespace (point-min))))
(defun inside-adecl-or-trailer-p (direction)
(if (>= direction 0)
(looking-at ":\\|!-")
(or (= (preceding-char) ?:)
(looking-at "!-"))))
(defun sign (n)
"Returns -1 if N < 0, else 1."
(if (>= n 0) 1 -1))
(defun abs (n)
"Returns the absolute value of N."
(if (>= n 0) n (- n)))
(defun next-char (direction)
"Returns preceding-char if DIRECTION < 0, otherwise following-char."
(if (>= direction 0) (following-char) (preceding-char)))
(provide 'mim-mode)
;;; mim-mode.el ends here

95
lisp/mim-syntax.el
View file

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

160
lisp/netunam.el
View file

@ -1,160 +0,0 @@
;;; netunam.el --- HP-UX RFA Commands
;; Copyright (C) 1988 Free Software Foundation, Inc.
;; Author: Chris Hanson <cph@zurich.ai.mit.edu>
;; Keywords: comm
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;;; Commentary:
;; Use the Remote File Access (RFA) facility of HP-UX from Emacs.
;;; Code:
(defconst rfa-node-directory "/net/"
"Directory in which RFA network special files are stored.
By HP convention, this is \"/net/\".")
(defvar rfa-default-node nil
"If not nil, this is the name of the default RFA network special file.")
(defvar rfa-password-memoize-p t
"If non-nil, remember login user's passwords after they have been entered.")
(defvar rfa-password-alist '()
"An association from node-name strings to password strings.
Used if `rfa-password-memoize-p' is non-nil.")
(defvar rfa-password-per-node-p t
"If nil, login user uses same password on all machines.
Has no effect if `rfa-password-memoize-p' is nil.")
(defun rfa-set-password (password &optional node user)
"Add PASSWORD to the RFA password database.
Optional second arg NODE is a string specifying a particular nodename;
if supplied and not nil, PASSWORD applies to only that node.
Optional third arg USER is a string specifying the (remote) user whose
password this is; if not supplied this defaults to (user-login-name)."
(if (not user) (setq user (user-login-name)))
(let ((node-entry (assoc node rfa-password-alist)))
(if node-entry
(let ((user-entry (assoc user (cdr node-entry))))
(if user-entry
(rplacd user-entry password)
(rplacd node-entry
(nconc (cdr node-entry)
(list (cons user password))))))
(setq rfa-password-alist
(nconc rfa-password-alist
(list (list node (cons user password))))))))
(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

399
lisp/old-shell.el
View file

@ -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 | <cwd> |
;;; where <cwd> is the new current working directory. Then trash the
;;; directory tracking machinery currently used in this package, and
;;; replace it with a process filter that watches for and strips out
;;; these messages.
;;; REGEXP is a regular expression. STR is a string. START is a fixnum.
;;; Returns T if REGEXP matches STR where the match is anchored to start
;;; at position START in STR. Sort of like LOOKING-AT for strings.
(defun shell-front-match (regexp str start)
(eq start (string-match regexp str start)))
(defun shell-directory-tracker (str)
"Tracks cd, pushd and popd commands issued to the shell.
This function is called on each input passed to the shell.
It watches for cd, pushd and popd commands and sets the buffer's
default directory to track these commands.
You may toggle this tracking on and off with M-x dirtrack-toggle.
If emacs gets confused, you can resync with the shell with M-x dirs.
See variables shell-cd-regexp, shell-pushd-regexp, and shell-popd-regexp.
Environment variables are expanded, see function substitute-in-file-name."
(condition-case err
(cond (shell-dirtrackp
(string-match "^\\s *" str) ; skip whitespace
(let ((bos (match-end 0))
(x nil))
(cond ((setq x (shell-match-cmd-w/optional-arg shell-popd-regexp
str bos))
(shell-process-popd (substitute-in-file-name x)))
((setq x (shell-match-cmd-w/optional-arg shell-pushd-regexp
str bos))
(shell-process-pushd (substitute-in-file-name x)))
((setq x (shell-match-cmd-w/optional-arg shell-cd-regexp
str bos))
(shell-process-cd (substitute-in-file-name x)))))))
(error (message (car (cdr err))))))
;;; Try to match regexp CMD to string, anchored at position START.
;;; CMD may be followed by a single argument. If a match, then return
;;; the argument, if there is one, or the empty string if not. If
;;; no match, return nil.
(defun shell-match-cmd-w/optional-arg (cmd str start)
(and (shell-front-match cmd str start)
(let ((eoc (match-end 0))) ; end of command
(cond ((shell-front-match "\\s *\\(\;\\|$\\)" str eoc)
"") ; no arg
((shell-front-match "\\s +\\([^ \t\;]+\\)\\s *\\(\;\\|$\\)"
str eoc)
(substring str (match-beginning 1) (match-end 1))) ; arg
(t nil))))) ; something else.
;;; The first regexp is [optional whitespace, (";" or the end of string)].
;;; The second regexp is [whitespace, (an arg), optional whitespace,
;;; (";" or end of string)].
;;; popd [+n]
(defun shell-process-popd (arg)
(let ((num (if (zerop (length arg)) 0 ; no arg means +0
(shell-extract-num arg))))
(if (and num (< num (length shell-dirstack)))
(if (= num 0) ; condition-case because the CD could lose.
(condition-case nil (progn (cd (car shell-dirstack))
(setq shell-dirstack
(cdr shell-dirstack))
(shell-dirstack-message))
(error (message "Couldn't cd.")))
(let* ((ds (cons nil shell-dirstack))
(cell (nthcdr (- num 1) ds)))
(rplacd cell (cdr (cdr cell)))
(setq shell-dirstack (cdr ds))
(shell-dirstack-message)))
(message "Bad popd."))))
;;; cd [dir]
(defun shell-process-cd (arg)
(condition-case nil (progn (cd (if (zerop (length arg)) (getenv "HOME")
arg))
(shell-dirstack-message))
(error (message "Couldn't cd."))))
;;; pushd [+n | dir]
(defun shell-process-pushd (arg)
(if (zerop (length arg))
;; no arg -- swap pwd and car of shell stack
(condition-case nil (if shell-dirstack
(let ((old default-directory))
(cd (car shell-dirstack))
(setq shell-dirstack
(cons old (cdr shell-dirstack)))
(shell-dirstack-message))
(message "Directory stack empty."))
(message "Couldn't cd."))
(let ((num (shell-extract-num arg)))
(if num ; pushd +n
(if (> num (length shell-dirstack))
(message "Directory stack not that deep.")
(let* ((ds (cons default-directory shell-dirstack))
(dslen (length ds))
(front (nthcdr num ds))
(back (reverse (nthcdr (- dslen num) (reverse ds))))
(new-ds (append front back)))
(condition-case nil
(progn (cd (car new-ds))
(setq shell-dirstack (cdr new-ds))
(shell-dirstack-message))
(error (message "Couldn't cd.")))))
;; pushd <dir>
(let ((old-wd default-directory))
(condition-case nil
(progn (cd arg)
(setq shell-dirstack
(cons old-wd shell-dirstack))
(shell-dirstack-message))
(error (message "Couldn't cd."))))))))
;; If STR is of the form +n, for n>0, return n. Otherwise, nil.
(defun shell-extract-num (str)
(and (string-match "^\\+[1-9][0-9]*$" str)
(string-to-int str)))
(defun shell-dirtrack-toggle ()
"Turn directory tracking on and off in a shell buffer."
(interactive)
(setq shell-dirtrackp (not shell-dirtrackp))
(message "directory tracking %s."
(if shell-dirtrackp "ON" "OFF")))
;;; For your typing convenience:
(fset 'dirtrack-toggle 'shell-dirtrack-toggle)
(defun shell-resync-dirs ()
"Resync the buffer's idea of the current directory stack.
This command queries the shell with the command bound to
shell-dirstack-query (default \"dirs\"), reads the next
line output and parses it to form the new directory stack.
DON'T issue this command unless the buffer is at a shell prompt.
Also, note that if some other subprocess decides to do output
immediately after the query, its output will be taken as the
new directory stack -- you lose. If this happens, just do the
command again."
(interactive)
(let* ((proc (get-buffer-process (current-buffer)))
(pmark (process-mark proc)))
(goto-char pmark)
(insert shell-dirstack-query) (insert "\n")
(sit-for 0) ; force redisplay
(comint-send-string proc shell-dirstack-query)
(comint-send-string proc "\n")
(set-marker pmark (point))
(let ((pt (point))) ; wait for 1 line
;; This extra newline prevents the user's pending input from spoofing us.
(insert "\n") (backward-char 1)
(while (not (looking-at ".+\n"))
(accept-process-output proc)
(goto-char pt)))
(goto-char pmark) (delete-char 1) ; remove the extra newline
;; That's the dirlist. grab it & parse it.
(let* ((dl (buffer-substring (match-beginning 0) (- (match-end 0) 1)))
(dl-len (length dl))
(ds '()) ; new dir stack
(i 0))
(while (< i dl-len)
;; regexp = optional whitespace, (non-whitespace), optional whitespace
(string-match "\\s *\\(\\S +\\)\\s *" dl i) ; pick off next dir
(setq ds (cons (substring dl (match-beginning 1) (match-end 1))
ds))
(setq i (match-end 0)))
(let ((ds (reverse ds)))
(condition-case nil
(progn (cd (car ds))
(setq shell-dirstack (cdr ds))
(shell-dirstack-message))
(error (message "Couldn't cd.")))))))
;;; For your typing convenience:
(fset 'dirs 'shell-resync-dirs)
;;; Show the current dirstack on the message line.
;;; Pretty up dirs a bit by changing "/usr/jqr/foo" to "~/foo".
;;; (This isn't necessary if the dirlisting is generated with a simple "dirs".)
;;; All the commands that mung the buffer's dirstack finish by calling
;;; this guy.
(defun shell-dirstack-message ()
(let ((msg "")
(ds (cons default-directory shell-dirstack)))
(while ds
(let ((dir (car ds)))
(if (string-match (format "^%s\\(/\\|$\\)" (getenv "HOME")) dir)
(setq dir (concat "~/" (substring dir (match-end 0)))))
(if (string-equal dir "~/") (setq dir "~"))
(setq msg (concat msg dir " "))
(setq ds (cdr ds))))
(message msg)))
(provide 'shell)
;;; old-shell.el ends here

134
lisp/sc-alist.el
View file

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

1547
lisp/sc.el
View file

File diff suppressed because it is too large Load diff

198
lisp/sc.elec.el
View file

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

71
lisp/setaddr.el
View file

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

77
lisp/sun-keys.el
View file

@ -1,77 +0,0 @@
;;; sun-keys.el --- support for Sun function keys
;;; Copyright (C) 1986 Free Software Foundation, Inc.
;; Author: Ian G. Batten <batten@uk.ac.bham.multics>
;; Keywords: terminals
;;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;;; Commentary:
;;; Support (cleanly) for Sun function keys. Provides help facilities,
;;; better diagnostics, etc.
;;;
;;; To use: make sure your .ttyswrc binds 'F1' to <ESC> * F1 <CR> and so on.
;;; load this lot from your start_up
;;; Code:
(defun sun-function-keys-dispatch (arg)
"Dispatcher for function keys."
(interactive "p")
(let* ((key-stroke (read t))
(command (assq key-stroke sun-function-keys-command-list)))
(cond (command (funcall (cdr command) arg))
(t (error "Unbound function key %s" key-stroke)))))
(defvar sun-function-keys-command-list
'((F1 . sun-function-keys-describe-bindings)
(R8 . previous-line) ; arrow keys
(R10 . backward-char)
(R12 . forward-char)
(R14 . next-line)))
(defun sun-function-keys-bind-key (arg1 arg2)
"Bind a specified key."
(interactive "xFunction Key Cap Label:
CCommand To Use:")
(setq sun-function-keys-command-list
(cons (cons arg1 arg2) sun-function-keys-command-list)))
(defun sun-function-keys-describe-bindings (arg)
"Describe the function key bindings we're running"
(interactive)
(with-output-to-temp-buffer "*Help*"
(sun-function-keys-write-bindings
(sort (copy-sequence sun-function-keys-command-list)
'(lambda (x y) (string-lessp (car x) (car y)))))))
(defun sun-function-keys-write-bindings (list)
(cond ((null list)
t)
(t
(princ (format "%s: %s\n"
(car (car list))
(cdr (car list))))
(sun-function-keys-write-bindings (cdr list)))))
(global-set-key "\e*" 'sun-function-keys-dispatch)
(make-variable-buffer-local 'sun-function-keys-command-list)
;;; sun-keys.el ends here

1243
lisp/superyank.el
View file

File diff suppressed because it is too large Load diff

473
lisp/timer.el
View file

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

469
lisp/tpu-doc.el
View file

@ -1,469 +0,0 @@
;;; tpu-doc.el --- Documentation for TPU-edt
;; Copyright (C) 1993, 1994 Free Software Foundation, Inc.
;; Author: Rob Riepel <riepel@networking.stanford.edu>
;; Maintainer: Rob Riepel <riepel@networking.stanford.edu>
;; Keywords: emulations
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;; This is documentation for the TPU-edt editor for GNU emacs. Major
;; sections of this document are separated with lines that begin with
;; ";; %% <topic>", where <topic> is what is discussed in that section.
;; %% Contents
;; % Introduction
;; % Terminal Support
;; % X-windows Support
;; % Differences Between TPU-edt and the Real Thing
;; % Starting TPU-edt
;; % TPU-edt Default Editing Keypad, Control and Gold Key Bindings
;; % Optional TPU-edt Extensions
;; % Customizing TPU-edt using the Emacs Initialization File
;; % Compiling TPU-edt
;; % Regular expressions in TPU-edt
;; % Etcetera
;; %% Introduction
;; TPU-edt is based on tpu.el by Jeff Kowalski and Bob Covey. TPU-edt
;; endeavors to be even more like TPU's EDT emulation than the original
;; tpu.el. Considerable effort has been expended to that end. Still,
;; emacs is emacs and there are differences between TPU-edt and the
;; real thing. Please read the "Differences Between TPU-edt and the
;; Real Thing" and "Starting TPU-edt" sections before running TPU-edt.
;; %% Terminal Support
;; TPU-edt, like it's VMS cousin, works on VT-series terminals with
;; DEC style keyboards. VT terminal emulators, including xterm with
;; the appropriate key translations, work just fine too.
;; %% X-windows Support
;; Starting with version 19 of emacs, TPU-edt works with X-windows.
;; This is accomplished through a TPU-edt X keymap. The emacs lisp
;; program tpu-mapper.el creates this map and stores it in a file.
;; Tpu-mapper will be run automatically the first time you invoke
;; the X-windows version of emacs, or you can run it by hand. See
;; the commentary in tpu-mapper.el for details.
;; %% Differences Between TPU-edt and the Real Thing (not Coke (r))
;; Emacs (version 18.58) doesn't support text highlighting, so selected
;; regions are not shown in inverse video. Emacs uses the concept of
;; "the mark". The mark is set at one end of a selected region; the
;; cursor is at the other. The letter "M" appears in the mode line
;; when the mark is set. The native emacs command ^X^X (Control-X
;; twice) exchanges the cursor with the mark; this provides a handy
;; way to find the location of the mark.
;; In TPU the cursor can be either bound or free. Bound means the
;; cursor cannot wander outside the text of the file being edited.
;; Free means the arrow keys can move the cursor past the ends of
;; lines. Free is the default mode in TPU; bound is the only mode
;; in EDT. Bound is the only mode in the base version of TPU-edt;
;; optional extensions add an approximation of free mode.
;; Like TPU, emacs uses multiple buffers. Some buffers are used to
;; hold files you are editing; other "internal" buffers are used for
;; emacs' own purposes (like showing you help). Here are some commands
;; for dealing with buffers.
;; Gold-B moves to next buffer, including internal buffers
;; Gold-N moves to next buffer containing a file
;; Gold-M brings up a buffer menu (like TPU "show buffers")
;; Emacs is very fond of throwing up new windows. Dealing with all
;; these windows can be a little confusing at first, so here are a few
;; commands to that may help:
;; Gold-Next_Scr moves to the next window on the screen
;; Gold-Prev_Scr moves to the previous window on the screen
;; Gold-TAB also moves to the next window on the screen
;; Control-x 1 deletes all but the current window
;; Control-x 0 deletes the current window
;; Note that the buffers associated with deleted windows still exist!
;; Like TPU, TPU-edt has a "command" function, invoked with Gold-KP7 or
;; Do. Most of the commands available are emacs commands. Some TPU
;; commands are available, they are: replace, exit, quit, include, and
;; Get (unfortunately, "get" is an internal emacs function, so we are
;; stuck with "Get" - to make life easier, Get is available as Gold-g).
;; Support for recall of commands, file names, and search strings was
;; added to emacs in version 19. For version 18 of emacs, optional
;; extensions are available to add this recall capability (see "Optional
;; TPU-edt Extensions" below). The history of strings recalled in both
;; versions of emacs differs slightly from TPU/edt, but it is still very
;; convenient.
;; Help is available! The traditional help keys (Help and PF2) display
;; a three page help file showing the default keypad layout, control key
;; functions, and Gold key functions. Pressing any key inside of help
;; splits the screen and prints a description of the function of the
;; pressed key. Gold-PF2 invokes the native emacs help, with it's
;; zillions of options. Gold-Help shows all the current key bindings.
;; Thanks to emacs, TPU-edt has some extensions that may make your life
;; easier, or at least more interesting. For example, Gold-r toggles
;; TPU-edt rectangular mode. In rectangular mode, Remove and Insert work
;; on rectangles. Likewise, Gold-* toggles TPU-edt regular expression
;; mode. In regular expression mode Find, Find Next, and the line-mode
;; replace command work with regular expressions. [A regular expression
;; is a pattern that denotes a set of strings; like VMS wildcards.]
;; Emacs also gives TPU-edt the undo and occur functions. Undo does
;; what it says; it undoes the last change. Multiple undos in a row
;; undo multiple changes. For your convenience, undo is available on
;; Gold-u. Occur shows all the lines containing a specific string in
;; another window. Moving to that window, and typing ^C^C (Control-C
;; twice) on a particular line moves you back to the original window
;; at that line. Occur is on Gold-o.
;; Finally, as you edit, remember that all the power of emacs is at
;; your disposal. It really is a fantastic tool. You may even want to
;; take some time and read the emacs tutorial; perhaps not to learn the
;; native emacs key bindings, but to get a feel for all the things
;; emacs can do for you. The emacs tutorial is available from the
;; emacs help function: "Gold-PF2 t"
;; %% Starting TPU-edt
;; In order to use TPU-edt, the TPU-edt editor definitions, contained
;; in tpu-edt.el, need to be loaded when emacs is run. This can be
;; done in a couple of ways. The first is by explicitly requesting
;; loading of the TPU-edt emacs definition file on the command line:
;; prompt> emacs -l /path/to/definitions/tpu-edt.el
;; If TPU-edt is installed on your system, that is, if tpu-edt.el is in
;; a directory like /usr/local/emacs/lisp, along with dozens of other
;; .el files, you should be able to use the command:
;; prompt> emacs -l tpu-edt
;; If you like TPU-edt and want to use it all the time, you can load
;; the TPU-edt definitions using the emacs initialization file, .emacs.
;; Simply create a .emacs file in your home directory containing the
;; line:
;; (load "/path/to/definitions/tpu-edt")
;; or, if (as above) TPU-edt is installed on your system:
;; (load "tpu-edt")
;; Once TPU-edt has been loaded, you will be using an editor with the
;; interface shown in the next section (A section that is suitable for
;; cutting out of this document and pasting next to your terminal!).
;; %% TPU-edt Default Editing Keypad, Control and Gold Key Bindings
;;
;; _______________________ _______________________________
;; | HELP | Do | | | | | |
;; |KeyDefs| | | | | | |
;; |_______|_______________| |_______|_______|_______|_______|
;; _______________________ _______________________________
;; | Find |Insert |Remove | | Gold | HELP |FndNxt | Del L |
;; | | |Sto Tex| | key |E-Help | Find |Undel L|
;; |_______|_______|_______| |_______|_______|_______|_______|
;; |Select |Pre Scr|Nex Scr| | Page | Sect |Append | Del W |
;; | Reset |Pre Win|Nex Win| | Do | Fill |Replace|Undel W|
;; |_______|_______|_______| |_______|_______|_______|_______|
;; |Move up| |Forward|Reverse|Remove | Del C |
;; | Top | |Bottom | Top |Insert |Undel C|
;; _______|_______|_______ |_______|_______|_______|_______|
;; |Mov Lef|Mov Dow|Mov Rig| | Word | EOL | Char | |
;; |StaOfLi|Bottom |EndOfLi| |ChngCas|Del EOL|SpecIns| Enter |
;; |_______|_______|_______| |_______|_______|_______| |
;; | Line |Select | Subs |
;; | Open Line | Reset | |
;; |_______________|_______|_______|
;; Control Characters
;;
;; ^A toggle insert and overwrite ^L insert page break
;; ^B recall ^R remember, re-center
;; ^E end of line ^U delete to beginning of line
;; ^G cancel current operation ^V quote
;; ^H beginning of line ^W refresh
;; ^J delete previous word ^Z exit
;; ^K learn ^X^X exchange point and mark
;;
;;
;; Gold-<key> Functions
;; -----------------------------------------------------------------
;; W Write - save current buffer
;; K Kill buffer - abandon edits and delete buffer
;;
;; E Exit - save current buffer and ask about others
;; X eXit - save all modified buffers and exit
;; Q Quit - exit without saving anything
;;
;; G Get - load a file into a new edit buffer
;; I Include - include a file in this buffer
;;
;; B next Buffer - display the next buffer (all buffers)
;; N Next file buffer - display next buffer containing a file
;; M buffer Menu - display a list of all buffers
;;
;; U Undo - undo the last edit
;; C Recall - edit and possibly repeat previous commands
;;
;; O Occur - show following lines containing REGEXP
;; S Search and substitute - line mode REPLACE command
;;
;; ? Spell check - check spelling in a region or entire buffer
;;
;; R Toggle Rectangular mode for remove and insert
;; * Toggle regular expression mode for search and substitute
;;
;; V Show TPU-edt version
;; -----------------------------------------------------------------
;; %% Optional TPU-edt Extensions
;; Several optional packages have been included in this distribution
;; of TPU-edt. The following is a brief description of each package.
;; See the {package}.el file for more detailed information and usage
;; instructions.
;; tpu-extras - TPU/edt scroll margins and free cursor mode.
;; tpu-recall - String, file name, and command history.
;; vt-control - VTxxx terminal width and keypad controls.
;; Packages are normally loaded from the emacs initialization file
;; (discussed below). If a package is not installed in the emacs
;; lisp directory, it can be loaded by specifying the complete path
;; to the package file. However, it is preferable to modify the
;; emacs load-path variable to include the directory where packages
;; are stored. This way, packages can be loaded by name, just as if
;; they were installed. The first part of the sample .emacs file
;; below shows how to make such a modification.
;; %% Customizing TPU-edt using the Emacs Initialization File
;; .emacs - a sample emacs initialization file
;; This is a sample emacs initialization file. It shows how to invoke
;; TPU-edt, and how to customize it.
;; The load-path is where emacs looks for files to fulfill load requests.
;; If TPU-edt is not installed in a standard emacs directory, the load-path
;; should be updated to include the directory where the TPU-edt files are
;; stored. Modify and un-comment the following section if TPU-ed is not
;; installed on your system - be sure to leave the double quotes!
;; (setq load-path
;; (append (list (expand-file-name "/path/to/tpu-edt/files"))
;; load-path))
;; Load TPU-edt
(load "tpu-edt")
;; Load the optional goodies - scroll margins, free cursor mode, command
;; and string recall. But don't complain if the file aren't available.
(load "tpu-extras" t)
(load "tpu-recall" t)
;; Uncomment this line to set scroll margins 10% (top) and 15% (bottom).
;(and (fboundp 'tpu-set-scroll-margins) (tpu-set-scroll-margins "10%" "15%"))
;; Load the vtxxx terminal control functions, but don't complain if
;; if the file is not found.
(load "vt-control" t)
;; TPU-edt treats words like EDT; here's how to add word separators.
;; Note that backslash (\) and double quote (") are quoted with '\'.
(tpu-add-word-separators "]\\[-_,.\"=+()'/*#:!&;$")
;; Emacs is happy to save files without a final newline; other Unix programs
;; hate that! This line will make sure that files end with newlines.
(setq require-final-newline t)
;; Emacs has the ability to automatically run code embedded in files
;; you edit. This line makes emacs ask if you want to run the code.
(if tpu-emacs19-p (setq enable-local-variables "ask")
(setq inhibit-local-variables t))
;; Emacs uses Control-s and Control-q. Problems can occur when using emacs
;; on terminals that use these codes for flow control (Xon/Xoff flow control).
;; These lines disable emacs' use of these characters.
(global-unset-key "\C-s")
(global-unset-key "\C-q")
;; top, bottom, bol, eol seem like a waste of Gold-arrow functions. The
;; following section re-maps up and down arrow keys to top and bottom of
;; screen, and left and right arrow keys to pan left and right (pan-left,
;; right moves the screen 16 characters left or right - try it, you'll
;; like it!).
;; Re-map the Gold-arrow functions
(define-key GOLD-CSI-map "A" 'tpu-beginning-of-window) ; up-arrow
(define-key GOLD-CSI-map "B" 'tpu-end-of-window) ; down-arrow
(define-key GOLD-CSI-map "C" 'tpu-pan-right) ; right-arrow
(define-key GOLD-CSI-map "D" 'tpu-pan-left) ; left-arrow
(define-key GOLD-SS3-map "A" 'tpu-beginning-of-window) ; up-arrow
(define-key GOLD-SS3-map "B" 'tpu-end-of-window) ; down-arrow
(define-key GOLD-SS3-map "C" 'tpu-pan-right) ; right-arrow
(define-key GOLD-SS3-map "D" 'tpu-pan-left) ; left-arrow
;; Re-map the Gold-arrow functions for X-windows TPU-edt (emacs version 19)
(cond
((and tpu-emacs19-p window-system)
(define-key GOLD-map [up] 'tpu-beginning-of-window) ; up-arrow
(define-key GOLD-map [down] 'tpu-end-of-window) ; down-arrow
(define-key GOLD-map [right] 'tpu-pan-right) ; right-arrow
(define-key GOLD-map [left] 'tpu-pan-left))) ; left-arrow
;; The emacs universal-argument function is very useful for native emacs
;; commands. This line maps universal-argument to Gold-PF1
(define-key GOLD-SS3-map "P" 'universal-argument) ; Gold-PF1
;; Make KP7 move by paragraphs, instead of pages.
(define-key SS3-map "w" 'tpu-paragraph) ; KP7
;; TPU-edt assumes you have the ispell spelling checker;
;; Un-comment this line if you don't.
;(setq tpu-have-spell nil)
;; Display the TPU-edt version.
(tpu-version)
;; End of .emacs - a sample emacs initialization file
;; After initialization with the .emacs file shown above, the editing
;; keys have been re-mapped to look like this:
;; _______________________ _______________________________
;; | HELP | Do | | | | | |
;; |KeyDefs| | | | | | |
;; |_______|_______________| |_______|_______|_______|_______|
;; _______________________ _______________________________
;; | Find |Insert |Remove | | Gold | HELP |FndNxt | Del L |
;; | | |Sto Tex| | U Arg |E-Help | Find |Undel L|
;; |_______|_______|_______| |_______|_______|_______|_______|
;; |Select |Pre Scr|Nex Scr| |Paragra| Sect |Append | Del W |
;; | Reset |Pre Win|Nex Win| | Do | Fill |Replace|Undel W|
;; |_______|_______|_______| |_______|_______|_______|_______|
;; |Move up| |Forward|Reverse|Remove | Del C |
;; |Tscreen| |Bottom | Top |Insert |Undel C|
;; _______|_______|_______ |_______|_______|_______|_______|
;; |Mov Lef|Mov Dow|Mov Rig| | Word | EOL | Char | |
;; |PanLeft|Bscreen|PanRigh| |ChngCas|Del EOL|SpecIns| Enter |
;; |_______|_______|_______| |_______|_______|_______| |
;; | Line |Select | Subs |
;; | Open Line | Reset | |
;; |_______________|_______|_______|
;; Astute emacs hackers will realize that on systems where TPU-edt is
;; installed, this documentation file can be loaded to produce the above
;; editing keypad layout. In fact, to get all the changes in the sample
;; initialization file, you only need a one line initialization file:
;; (load "tpu-doc")
;; wow!
;; %% Compiling TPU-edt
;; It is not necessary to compile (byte-compile in emacs parlance)
;; TPU-edt to use it. However, byte-compiled code loads and runs
;; faster, and takes up less memory when loaded. To byte compile
;; TPU-edt, use the following command.
;; emacs -batch -f batch-byte-compile tpu-edt.el
;; This will produce a file named tpu-edt.elc. This new file can be
;; used in place of the original tpu-edt.el file. In commands where
;; the file type is not specified, emacs always attempts to use the
;; byte-compiled version before resorting to the source.
;; %% Regular expressions in TPU-edt
;; Gold-* toggles TPU-edt regular expression mode. In regular expression
;; mode, find, find next, replace, and substitute accept emacs regular
;; expressions. A complete list of emacs regular expressions can be
;; found using the emacs "info" command (it's somewhat like the VMS help
;; command). Try the following sequence of commands:
;; DO info <enter info mode>
;; m regex <select the "regular expression" topic>
;; m directives <select the "directives" topic>
;; Type "q" to quit out of info mode.
;; There is a problem in regular expression mode when searching for
;; empty strings, like beginning-of-line (^) and end-of-line ($).
;; When searching for these strings, find-next may find the current
;; string, instead of the next one. This can cause global replace and
;; substitute commands to loop forever in the same location. For this
;; reason, commands like
;; replace "^" "> " <add "> " to beginning of line>
;; replace "$" "00711" <add "00711" to end of line>
;; may not work properly.
;; Commands like those above are very useful for adding text to the
;; beginning or end of lines. They might work on a line-by-line basis,
;; but go into an infinite loop if the "all" response is specified. If
;; the goal is to add a string to the beginning or end of a particular
;; set of lines TPU-edt provides functions to do this.
;; Gold-^ Add a string at BOL in region or buffer
;; Gold-$ Add a string at EOL in region or buffer
;; There is also a TPU-edt interface to the native emacs string
;; replacement commands. Gold-/ invokes this command. It accepts
;; regular expressions if TPU-edt is in regular expression mode. Given
;; a repeat count, it will perform the replacement without prompting
;; for confirmation.
;; This command replaces empty strings correctly, however, it has its
;; drawbacks. As a native emacs command, it has a different interface
;; than the emulated TPU commands. Also, it works only in the forward
;; direction, regardless of the current TPU-edt direction.
;; %% Etcetera
;; That's TPU-edt in a nutshell...
;; Please send any bug reports, feature requests, or cookies to the
;; author, Rob Riepel, at the address shown by the tpu-version command
;; (Gold-V).
;; Share and enjoy... Rob Riepel 7/93
;;; tpu-doc.el ends here

144
lisp/vmsx.el
View file

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

970
lisp/word-help.el
View file

@ -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 <jensthi@ifi.uio.no>
;; Keywords: help, keyword, languages, completion
;; This file is part of GNU Emacs.
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;; This package provides a rather general interface for doing keyword
;; help in most languages. In short, it'll determine which TeXinfo
;; file which is relevant for the current mode; cache the index and
;; use regexps to give you help on the keyword you're looking at.
;; Installation
;; ************
;; For the default setup to work for all supported modes, make sure
;; the Texinfo files from the following packages are installed:
;; Texinfo file | Available in archive or URL | Notes
;; autoconf.info | autoconf-2.10.tar.gz | -
;; bison.info | bison-1.25.tar.gz | -
;; libc.info | glibc-1.09.1.tar.gz | -
;; elisp.info | elisp-manual-19-2.4.tar.gz | -
;; latex.info | ftp://ftp.dante.de/pub/tex/info/latex2e-help-texinfo/latex2e.texi
;; groff.info | groff-1.10.tar.gz | -
;; m4.info | m4-1.4.tar.gz | -
;; make.info | make-3.75.tar.gz | -
;; perl.info | http://www.perl.com/CPAN/doc/manual/info/
;; simula.info | Mail bjort@ifi.uio.no | Written in Norwegian
;; texinfo.info | texinfo-3.9.tar.gz | -
;; BTW: We refer to Texinfo files by just their last component, not
;; with an absolute file name. You must thus set up
;; `Info-directory-list' and `Info-default-directory-list' so that
;; these can automatically be located.
;; Usage
;; *****
;;
;; Place the cursor over the function/variable/type/whatever you want
;; help on. Type "C-h C-i". `word-help' will then make a suggestion
;; to an index topic; press return to accept this. If not, you may use
;; tab-completion to find the topic you're interested in.
;; `word-help' is also able to do symbol completion via the
;; `word-help-complete' function. Bind this function to C-TAB by
;; adding the following line to your .emacs file:
;;
;; (global-set-key [?\M-\t] 'word-help-complete)
;;
;; Note that some modes automatically override this key; you may
;; therefore wish to either put the above statement in a hook or
;; associate the function with an other key.
;; Usually, `word-help' is able to determine the relevant Texinfo
;; file from looking at the buffer's `mode-name'; if not, you can use
;; the interactive function `set-help-file' to set this.
;; Customizing
;; ***********
;;
;; User interface
;; --------------
;;
;; Two variables control the behaviour of the user-interface of
;; `word-help': `word-help-split-window' and
;; `word-help-magic-index'. Do C-h v to get more information on
;; these.
;; Adding more Texinfo files
;; -------------------------
;;
;; Associations between mode-names and Texinfo files can be done
;; through the `word-help-mode-alist' variable, which defines an
;; `alist' making `set-help-file' able to initialize the necessary
;; variable.
;; NOTE: If you have to customize the regexps, it is *CRUCIAL* that
;; none of your regexps match the empty string! Not adhering to this
;; restriction will make `word-help' enter an infinite loop.
;; Contacting the author
;; *********************
;;
;; If you wish to contact me for any reason, please feel free to write
;; to:
;; Jens Berger
;; Spektrumveien 4
;; N-0666 Oslo
;; Norway
;;
;; E-mail: <jensthi@ifi.uio.no>
;; Have fun.
;;
;;; Code:
;;
(require 'info)
;;;--------------------
;;; USER OPTIONS
;;;--------------------
(defvar word-help-split-window t
"*Non-nil means that the info buffer will pop up in a separate window.
If nil, we will just switch to it.")
(defvar word-help-magic-index t
"*Non-nil means that the keyword will be searched for in the requested node.
This is done by determining whether the line the point is positioned
on after using `Info-goto-node', actually contains the keyword. If
not, we will search for the first occurence of the keyword. This may
help when the info file isn't correctly indexed.")
;;; ---- end of user configurable variables
;;;-------------------------
;;; ADVANCED USER OPTIONS
;;;-------------------------
(defvar word-help-mode-alist
'(
("autoconf"
(("autoconf" "Macro Index") ("m4" "Macro index"))
(("AC_\\([A-Za-z0-9_]+\\)" 1)
("[a-z]+"))
nil
nil
(("AC_\\([A-Za-z0-9_]+\\)" 1 nil (("^[A-Z_]+$")))
("[a-z_][a-z_]*" 0 nil (("^[a-z_]+$")))))
("Bison"
(("bison" "Index")
("libc" "Type Index" "Function Index" "Variable Index"))
(("%[A-Za-z]*")
("[A-Za-z_][A-Za-z0-9_]*"))
nil
nil
(("%[A-Za-z]*" nil nil (("^%")))
("[A-Za-z_][A-Za-z0-9_]*" nil nil (("[A-Za-z_][A-Za-z0-9_]*")))))
("YACC" . "Bison")
("C" (("libc" "Type Index" "Function Index" "Variable Index")))
("C++" . "C")
("Emacs-Lisp"
(("elisp" "Index"))
(("[^][ ()\n\t.\"'#]+"))
nil
nil
lisp-complete-symbol)
("LaTeX"
(("latex" "Command Index"))
(("\\\\\\(begin\\|end\\){\\([^}\n]+\\)}" 2 0)
("\\\\[A-Za-z]+")
("\\\\[^A-Za-z]")
("[A-Za-z]+"))
nil
nil
(("\\\\begin{\\([A-Za-z]*\\)" 1 "}" (("^[A-Za-z]+$")))
("\\\\end{\\([A-Za-z]*\\)" 1 "}" (("^[A-Za-z]+$")))
("\\\\renewcommand{\\(\\\\?[A-Za-z]*\\)" 1 "}" (("^\\\\[A-Za-z]+")))
("\\\\renewcommand\\(\\\\?[A-Za-z]*\\)" 1 "" (("^\\\\[A-Za-z]+")))
("\\\\renewenvironment{?\\([A-Za-z]*\\)" 1 "}"(("^[A-Za-z]+$")))
("\\\\[A-Za-z]*" 0 "" (("^\\\\[A-Za-z]+")))))
("latex" . "LaTeX")
("Nroff"
(("groff" "Macro Index" "Register Index" "Request Index"))
(("\\.[^A-Za-z]")
("\\.[A-Za-z]+")
("\\.\\([A-Za-z]+\\)" 1))
nil
nil
(("\\.[A-Za-z]*" nil nil (("^\\.[A-Za-z]+$")))
("\\.\\([A-Za-z]*\\)" 1 nil (("^[A-Za-z]+$")))))
("Groff" . "Nroff")
("m4"
(("m4" "Macro index"))
(("\\([mM]4_\\)?\\([A-Za-z_][A-Za-z_0-9]*\\)" 2))
nil
nil
(("[mM]4_\\([A-Za-z_]?[A-Za-z_0-9]*\\)" 1)
("[A-Za-z_][A-Za-z_0-9]*")))
("Makefile"
(("make" "Name Index"))
(("\\.[A-Za-z]+") ;; .SUFFIXES
("\\$[^()]") ;; $@
("\\$([^A-Za-z].)") ;; $(<@)
("\\$[\(\{]\\([a-zA-Z+]\\)" 1) ;; $(wildcard)
("[A-Za-z]+")) ;; foreach
nil
nil
(("\\.[A-Za-z]*" nil ":" (("^\\.[A-Za-z]+$")))
("\\$(\\([A-Z]*\\)" 1 ")" (("^[A-Z]")))
("[a-z]+" nil nil (("^[a-z]+$")))))
("Perl"
(("perl" "Variable Index" "Function Index"))
(("\\$[^A-Za-z^]") ;; $@
("\\$\\^[A-Za-z]?") ;; $^D
("\\$[A-Za-z][A-Za-z_0-9]+") ;; $foobar
("[A-Za-z_][A-Za-z_0-9]+")) ;; dbmopen
nil
nil
(("\\$[A-Za-z]*" nil nil (("^\\$[A-Za-z]+$"))) ;; $variable
("[A-Za-z_][A-Za-z_0-9]*" nil nil
(("^[A-Za-z_][A-Za-z_0-9]*$"))))) ;; function
("Simula" (("simula" "Index")) nil t)
("Ifi Simula" . "Simula")
("SIMULA" . "Simula")
("Texinfo"
(("texinfo" "Command and Variable Index"))
(("@\\([A-Za-z]+\\)" 1))
nil
nil
(("@\\([A-Za-z]*\\)" 1)))
)
"Assoc list between `mode-name' and Texinfo files.
The variable should be initialized with a list of elements with the
following form:
\(mode-name (word-help-info-files) (word-help-keyword-regexps)
word-help-ignore-case word-help-index-mapper
word-help-complete-list)
where `word-help-info-files', `word-help-keyword-regexps' and so
forth of course are the values which should be put in these variables
for this mode. Note that `mode-name' doesn't have to be a legal
mode-name; the user may use the call `set-help-file', where
`mode-name' will be used in the `completing-read'.
Example entry (for C):
\(\"C\" ((\"libc\" \"Type Index\" \"Function Index\" \"Variable Index\"))
((\"[A-Za-z_][A-Za-z0-9]+\")))
The two first variables must be initialized; the two remaining will
get default values if you omit them or set them to nil. The default
values are:
word-help-keyword-regexps: (\"[A-Za-z_][A-Za-z0-9]+\")
word-help-ignore-case: nil
More settings may be defined in the future.
You may also define aliases, if there are several relevant mode-names
to a single entry. These should be of the form:
\(MODE-NAME-ALIAS . MODE-NAME-REAL)
For C++, you would use the alias
\(\"C++\" . \"C\")
to make C++ mode use the same help files as C files do. Please note
that you can shoot yourself in the foot with this possibility, by
defining recursive aliases.")
;;; --- end of advanced user options
(defvar word-help-ignore-case nil
"Non-nil means that case is ignored when doing lookup.")
(make-variable-buffer-local 'word-help-ignore-case)
(defvar word-help-info-files nil
"List of info files with respective nodes, for the current mode.
This should be a list of the following form:
\((INFO-FILE-1 NODE-NAME-1 NODE-NAME-2 ...)
(INFO-FILE-1 NODE-NAME-1 NODE-NAME-2 ...)
: : :
(INFO-FILE-1 NODE-NAME-1 NODE-NAME-2 ...))
An example entry for e.g. C would be:
\((\"/local/share/gnu/info/libc\" \"Function Index\" \"Type Index\"
\"Variable Index\"))
The files and nodes will be searched/cached in the order specified.
This variable is usually set by the `word-help-switch-help-file'
function, which utilizes the `word-help-mode-alist'.")
(make-variable-buffer-local 'word-help-info-files)
(defvar word-help-keyword-regexps nil
"Regexps for finding keywords in the current mode.
This is constructed as a list of the following form:
\((REGEXP SUBMATCH-LOOKUP SUBMATCH-CURSOR)
(REGEXP SUBMATCH-LOOKUP SUBMATCH-CURSOR)
: : :
(REGEXP SUBMATCH-LOOKUP SUBMATCH-CURSOR))
The regexps will be searched in order for a match which the cursor is
within.
submatch-lookup is the submatch number which will be looked for in the
index. May be omitted; defaults to 0 (e.g. the entire pattern). This is
useful in for instance configure lookup; each command is there prefixed
with 'AC_', which must be ignored when doing a lookup. Example regexp
entry for this:
\(\"AC_\\\\([A-Za-z0-9]+\\\\)\" 1)
submatch-cursor is the part of the match which the cursor must be within.
May be omitted; defaults to 0 (e.g. the entire pattern).")
(make-variable-buffer-local 'word-help-keyword-regexps)
(set-default 'word-help-keyword-regexps '(("[A-Za-z_][A-Za-z_0-9]*")))
(defvar word-help-index-mapper nil
"Regexps to use for massaging index-entries into keywords.
This variable should contain a list of regexps with sub-expressions,
where we will only look for the sub-expression in the user text.
The regexp list should be formatted as:
((REGEXP SUBEXP) (REGEXP SUBEXP) ... )
If the index entry does not match any of the regexps, it will be ignored.
Example:
Perl has index entries of the following form:
* abs VALUE: perlfunc.
* accept NEWSOCKET,GENERICSOCKET: perlfunc.
* alarm SECONDS: perlfunc.
* atan2 Y,X: perlfunc.
* bind SOCKET,NAME: perlfunc.
: : :
We will thus try to extract the first word in the index entry -
\"abs\" from \"abs VALUE\", etc. This is done by the following entry:
\((\"^\\\\([^ \\t\\n]+\\\\)\" 1))
This value is btw. the default one, and works with most Texinfo files")
(make-variable-buffer-local 'word-help-index-mapper)
(set-default 'word-help-index-mapper '(("^\\([^ \t\n]+\\)" 1)))
(defvar word-help-complete-list nil
"Regexps or function to use for completion of symbols.
The list should have the following format:
((REGEXP SUBMATCH TEXT-APPEND (RE-FILTER-1 REG-FILTER-2 ...)
: : : : :
(REGEXP SUBMATCH TEXT-APPEND (RE-FILTER-1 REG-FILTER-2 ...))
The two first entries are similar to `word-help-keyword-regexps',
REGEXP is a regular expression which should match any relevant
expression, and where SUBMATCH should be used for look up. By
specifying non-nil REGEXP-FILTERs, we'll only include entries in the
index which matches the regexp specified.
If the contents of this variable is a symbol of a function, this
function will be called instead. This is useful for modes providing
a more intelligent function (like `lisp-complete-symbol' in Emacs Lisp mode).
If you would like to use another function instead, you may.
Non-nil TEXT-APPEND means that this text will be inserted after the
completion, if we manage to do make a completion.")
(make-variable-buffer-local 'word-help-complete-list)
(set-default 'word-help-complete-list '(("[A-Za-z_][A-Za-z_0-9]*")))
;;; Work variables
(defvar word-help-main-index nil
"List of all index entries.
See `word-help-process-indexes' for structure formatting.
Minor note: This variable is a list if it is initialized, t if
initializing failed and nil if uninitialized.")
(make-variable-buffer-local 'word-help-main-index)
(defvar word-help-complete-index nil
"List of regexps for completion, with matching index entries.
Value is nil if uninitialized, t if initialized but not accessible,
a list if we're feeling ok.")
(make-variable-buffer-local 'word-help-complete-index)
(defvar word-help-main-obarray nil
"Global work variable for `word-help' system.
Do Not mess with this!")
(defvar word-help-history nil
"History for `word-help' minibuffer queries.")
(make-local-variable 'word-help-history)
(defvar word-help-current-help-file nil
"Current help file active for this mode.")
(defvar word-help-index-alist nil
"An assoc list mapping help files to info indexes.
This means that `word-help-mode-index' can be init'ed faster.")
(defvar word-help-help-mode nil
"Which mode the help system is bound to for the current mode.")
(make-variable-buffer-local 'word-help-help-mode)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;; User Functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Debugging
;;;###autoload
(defun reset-word-help ()
"Clear all cached indexes in the `word-help' system.
You should only need this when installing new info files, and/or
adding more Texinfo files to the `word-help' system."
(interactive)
(setq word-help-index-alist nil
word-help-main-index nil
word-help-info-files nil
word-help-complete-index nil))
;;; Changing help file
;;;###autoload
(defun set-word-help-file ()
"Change which set of Texinfo files used for word-help.
`word-help' maintains a list over which Texinfo files which are
relevant for each programming language (`word-help-mode-alist'). It
usually selects the correct one, based upon the value of `mode-name'.
If this guess is incorrect, you may also use this function manually to
instruct future `word-help' calls which Texinfo files to use."
(interactive)
(let (helpfile helpguess (completion-ignore-case t))
;; Try to make a guess
(setq helpguess (cond
(word-help-current-help-file)
((word-help-guess-help-file))))
;; Ask the user
(setq helpfile (completing-read
(if helpguess
(format "Select help mode (default %s): " helpguess)
"Select help mode: ")
word-help-mode-alist
nil t nil nil))
(if (equal "" helpfile)
(setq helpfile helpguess))
(if helpfile
(word-help-switch-help-file helpfile))))
;;; Main user interface
;;;###autoload
(defun word-help ()
"Find documentation on the keyword under the cursor.
The determination of which language the keyword belongs to, is based upon
The relevant info file is selected by matching `mode-name' (the major
mode) against the assoc list `word-help-mode-alist'.
If this is not possible, `set-help-file' will be invoked for selecting
the relevant info file. `set-help-file' may also be invoked
interactively by the user.
If the keyword you are looking at is not available in any index, no
default suggestion will be presented. "
(interactive)
(let (myguess guess index-info
(completion-ignore-case word-help-ignore-case))
;; Set necessary variables for later lookup
(word-help-find-help-file)
;; Have we previously cached datas?
(word-help-process-indexes)
(if
(atom word-help-main-index)
(message "No help file available for this mode.")
;; First make a guess at what the user is looking for
(setq myguess (word-help-guess
(point)
(cond
((not (atom word-help-main-index))
(car word-help-main-index)))
word-help-keyword-regexps))
;; Ask the user himself
(setq guess (completing-read
; Format string
(if myguess
(format "Look up keyword (default %s): " myguess)
"Look up keyword: ")
; Collection
(car word-help-main-index)
nil t nil 'word-help-history))
(if (equal guess "")
(setq guess myguess))
;; If we've got anything meaningful to lookup, do so
(if (not guess)
(message "Help aborted.")
(setq index-info (word-help-find-index-node
guess
word-help-main-index))
(if (not index-info)
(message "Oops, I could not find \"%s\" anyway! Bug?" guess)
(word-help-goto-index-node (nconc index-info (list guess))))))))
;;;###autoload
(defun word-help-complete ()
"Perform completion on the symbol preceding the point.
The determination of which language the keyword belongs to, is based upon
The relevant info file is selected by matching `mode-name' (the major
mode) against the assoc list `word-help-mode-alist'.
If this is not possible, `set-help-file' will be invoked for selecting
the relevant info file. `set-help-file' may also be invoked
interactively by the user.
The keywords are extracted from the index of the info file defined for
this mode, by using the `word-help-complete-list' variable."
(interactive)
(word-help-make-complete)
(cond
((not word-help-complete-index)
(message "No completion available for this mode."))
((symbolp word-help-complete-index)
(call-interactively word-help-complete-index))
((listp word-help-complete-index)
(let ((all-match (word-help-guess-all (point)
word-help-complete-index t))
(completion-ignore-case word-help-ignore-case)
(c-list word-help-complete-index)
c-entry word-match completion completed)
;; Loop over and try to find a match
(while (and all-match (not completed))
(setq word-match (car all-match)
c-entry (car c-list)
c-list (cdr c-list)
all-match (cdr all-match))
;; Check whether the current pattern matched
(if word-match
(let ((close (nth 3 c-entry))
(words (nth 4 c-entry)))
;; Find the maximum completion for this word
; (print word-match)
; (print c-entry)
; (print close)
(setq completion (try-completion word-match words))
;; Was the match exact
(cond ((eq completion t)
(and close
(not (looking-at (regexp-quote close)))
(insert close))
(setq completed t))
;; Silently ignore non-matches
((not completion))
;; May we complete more unambiguously
((not (string-equal completion word-match))
(delete-region (- (point) (length word-match))
(point))
(insert completion)
(if (eq t (try-completion completion words))
(progn
(and close
(not (looking-at (regexp-quote close)))
(insert close))))
(setq completed t))
(t
(message "Making completion list...")
(let ((list (all-completions word-match words nil)))
(setq completed list)
(with-output-to-temp-buffer "*Completions*"
(display-completion-list list)))
(message "Making completion list...done"))))))
(if (not completed) (message "No match."))))
(t (message "No completion available for this mode."))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;; Index mapping ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun word-help-map-index-entries (str re-list)
"Transform an Info index entry into a programming keyword.
Uses this by mapping the entries through `word-help-index-mapper'."
(let ((regexp (car (car re-list)))
(subexp (car (cdr (car re-list))))
(next (cdr re-list)))
(cond
((string-match regexp str)
(substring str (match-beginning subexp) (match-end subexp)))
(next
(word-help-map-index-entries str next)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;; Switch mode files ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Mode lookup
(defun word-help-guess-help-file ()
"Guesses a relevant help file based on mode name.
Returns nil if no guess could be made. Uses `word-help-mode-alist'."
(let (guess)
(cond
((setq guess (assoc mode-name word-help-mode-alist))
(car guess)))))
(defun word-help-switch-help-file (helpfile)
"Changes the help-file to the mode name given.
Uses `word-help-mode-alist'."
(if helpfile
(let (helpdesc)
(if (not (setq helpdesc (assoc helpfile word-help-mode-alist)))
(message "No help defined for \"%s\"." helpfile)
(if (stringp (cdr helpdesc))
(word-help-switch-help-file (cdr helpdesc))
(word-help-make-default-map
helpdesc
(list 'word-help-help-mode
'word-help-info-files
'word-help-keyword-regexps
'word-help-ignore-case
'word-help-index-mapper
'word-help-complete-list))))
(setq word-help-main-index nil
word-help-complete-index nil))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;; Index collection ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun word-help-extract-index (file-name index-list index-map ignore-case)
"Extract index from filename and the first node name in index list.
`file-name' is the name of the info file, while `index-list' is a list
of node-names to search."
(let (cmd1 cmdlow nodename ob-array next (case-fold-search word-help-ignore-case))
(setq nodename (car index-list))
(setq ob-array (make-vector 211 0))
(message "Processing \"%s\" in %s..." nodename file-name)
(save-window-excursion
(Info-goto-node (concat "(" file-name ")" nodename))
(end-of-buffer)
(while (re-search-backward "\\* \\([^\n:]+\\):" nil t)
(setq cmd1 (buffer-substring (match-beginning 1) (match-end 1)))
(setq cmdlow (if ignore-case (downcase cmd1) cmd1))
(if index-map
(setq cmdlow (word-help-map-index-entries cmdlow
index-map)))
;; We have to do this workaround to support case-insensitive matching
(cond
(cmdlow
(put (intern cmdlow ob-array) 'word-help-real-name cmd1)
(intern cmdlow word-help-main-obarray)))))
(setq next (cond
((cdr index-list)
(word-help-extract-index file-name (cdr index-list)
index-map ignore-case))))
(nconc (list (list nodename ob-array)) next)))
(defun word-help-collect-indexes (info-file)
"Process all the indexes in an info file.
Uses `word-help-extract-index' on each node, and returns an entry
suitable for merging into `word-help-process-indexes'. `info-file'
is an entry of the form
\(FILE-NAME INDEX-NAME-1 INDEX-NAME-2 ...)"
(let ((file (car info-file))
(nodes (cdr info-file)))
(nconc (list file) (word-help-extract-index file nodes
word-help-index-mapper
word-help-ignore-case))))
(defun word-help-process-indexes ()
"Process all the entries in the global variable `word-help-info-files'.
Returns a list formatted as follows:
\(all-entries-ob
(file-name-1 (node-name-1 this-node-entries-ob)
(node-name-2 this-node-entries-ob)
: : :
(node-name-n this-node-entries-ob))
(file-name-2 (node-name-1 this-node-entries-ob)
(node-name-2 this-node-entries-ob)
: : :
(node-name-n this-node-entries-ob))
: : : : : : : : :
(file-name-n (node-name-1 this-node-entries-ob)
(node-name-2 this-node-entries-ob)
: : :
(node-name-n this-node-entries-ob)))
The symbols in the obarrays may contain the additional property
`word-help-real-name', which tells the *real* node to go to.
Note that we use `word-help-index-alist' to speed up the process. Note
that `word-help-switch-help-file' must have been called before this function.
This structure is then later searched by `word-help-find-index-node'."
(let (index-words old-index)
(if (not word-help-main-index)
(cond
((setq old-index
(assoc word-help-help-mode word-help-index-alist))
(setq word-help-main-index (nth 1 old-index)))
(word-help-info-files
(setq word-help-main-obarray (make-vector 307 0)
index-words (mapcar 'word-help-collect-indexes
word-help-info-files)
word-help-main-index
(append (list word-help-main-obarray) index-words))
(setq word-help-index-alist (cons (list word-help-help-mode
word-help-main-index)
word-help-index-alist)))
(t (setq word-help-main-index t))))))
(defun word-help-find-help-file ()
"Tries to find and set a relevant help file for the current mode."
(let (helpguess)
(if (not word-help-info-files)
(if (setq helpguess (word-help-guess-help-file))
(word-help-switch-help-file helpguess)
(set-help-file)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;; Keyword guess ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun word-help-guess-all (cur-point re-list
&optional copy-to-point)
"Guesses *all* keywords the user possibly may be looking at.
Returns a list of all possible keywords. "
(let ((regexp (car (car re-list)))
(submatch (cond ((nth 1 (car re-list))) (0)))
(cursmatch (cond ((nth 2 (car re-list))) (0)))
(guess nil)
(next-guess nil)
(case-fold-search word-help-ignore-case)
(end-point nil))
(save-excursion
(end-of-line)
(setq end-point (point))
;; Start at the beginning
(beginning-of-line)
(while (and (not guess) (re-search-forward regexp end-point t))
;; Look whether the cursor is within the match
(if (and (<= (match-beginning cursmatch) cur-point)
(>= (match-end cursmatch) cur-point))
(if (or (not copy-to-point) (<= cur-point (match-end submatch)))
(setq guess (buffer-substring (match-beginning submatch)
(if copy-to-point
cur-point
(match-end submatch)))))))
;; If we found anything, return it and call ourselves again
(if (cdr re-list)
(setq next-guess (word-help-guess-all cur-point (cdr re-list)
copy-to-point))))
(cons guess next-guess)))
(defun word-help-guess-match (all-match cmd-array)
(let ((sym (car all-match)))
(cond
((and sym (intern-soft (if word-help-ignore-case
(downcase sym)
sym) cmd-array)
sym))
((cdr all-match)
(word-help-guess-match (cdr all-match) cmd-array)))))
(defun word-help-guess (cur-point cmd-array re-list)
"Guesses what keyword the user is looking at, and returns that.
CUR-POINT should be the current value of `point', CMD-ARRAY an obarray
of all the keywords which are defined for the current mode, and
RE-LIST a list of regexps use for the hunt. See also
`word-help-keyword-regexps'."
(let ((all-matches (word-help-guess-all cur-point re-list)))
; (print all-matches)
(word-help-guess-match all-matches cmd-array)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;; Show node for keyword ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Find an index entry
(defun word-help-find-index-node (node index-reg)
"Finds the node named `node' in the index-register `index-reg'.
`index-reg' has the format as returned (and documented) by the
`word-help-process-indexes' call. In most cases, this will be equal to
`word-help-main-index'.
Returns a list with format
(file-name index-node-name index-entry)
which contains the file and index where the entry can be found.
Returns nil if the entry can't be found."
(let (file-info node-name)
(setq node-name (cond (word-help-ignore-case (downcase node)) (node)))
(if (intern-soft node-name (car index-reg))
(setq file-info (word-help-index-search-file node-name
(cdr index-reg))))
file-info))
(defun word-help-index-search-file (entry file-data)
"Searches a cached file for the index-entry `entry'."
(let (this-file next-files file-name node node-infos)
(setq this-file (car file-data)
next-files (cdr file-data)
file-name (car this-file)
node-infos (cdr this-file)
node (word-help-index-search-nodes entry node-infos))
(cond
(node
(cons file-name node))
(next-files (word-help-index-search-file entry next-files)))))
(defun word-help-index-search-nodes (entry node-info)
"Searches a cached list of nodes for the entry `entry'."
(let (this-node next-nodes node-name node-ob node-sym)
(setq this-node (car node-info)
next-nodes (cdr node-info)
node-name (car this-node)
node-ob (car (cdr this-node))
node-sym (intern-soft entry node-ob))
(cond
(node-sym
(list node-name (get node-sym 'word-help-real-name)))
(next-nodes (word-help-index-search-nodes entry next-nodes)))))
;;; Switch to a node in an index
(defun word-help-goto-index-node (index-info)
"Jumps to an index node.
`index-info' should be a list with the following format:
\(FILE-NAME INDEX-NODE-NAME INDEX-ENTRY KEYWORD)"
(let* ((file-name (car index-info))
(node-name (nth 1 index-info))
(entry-name (nth 2 index-info))
(kw-name (nth 3 index-info))
(buffer (current-buffer)))
(if word-help-split-window
(pop-to-buffer nil))
(Info-goto-node (concat "(" file-name ")" node-name))
(Info-menu entry-name)
;; Do magic keyword search
(if word-help-magic-index
(let (end-point regs this-re found entry-re)
(setq entry-re (regexp-quote kw-name)
regs (list (concat
(if (string-match "^[A-Za-z]" entry-name)
"\\<" "")
entry-re
(if (string-match "[A-Za-z]$" entry-name)
"\\>" ""))
(concat "[`\"\(]" entry-re)
(concat "^" entry-re
(if (string-match "[A-Za-z]$" entry-name)
"\\>" ""))))
(end-of-line)
(setq end-point (point))
(beginning-of-line)
(if (not (re-search-forward (car regs) end-point t))
(while (and (not found) (car regs))
(setq this-re (car regs)
regs (cdr regs)
found (re-search-forward this-re nil t))))
(recenter 0)))
(if word-help-split-window
(pop-to-buffer buffer))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Completion ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun word-help-extract-matches (from-ob dest-ob re-list)
"Takes atoms from from-ob, and puts them in dest-ob if they match re-list."
(let ((regexp (car (car re-list))))
(mapatoms (lambda (x)
(if (or (not regexp) (string-match regexp (symbol-name x)))
(intern (symbol-name x) dest-ob)))
from-ob)
(if (cdr re-list)
(word-help-extract-matches from-ob dest-ob (cdr re-list))))
dest-ob)
(defun word-help-make-complete ()
"Generates the `word-help-complete-index'."
(if word-help-complete-index
nil
(word-help-find-help-file)
(cond
((symbolp word-help-complete-list)
(setq word-help-complete-index word-help-complete-list))
(t
(word-help-process-indexes)
(if (not (atom word-help-main-index))
(let ((from-ob (car word-help-main-index)))
(message "Processing keywords...")
(setq word-help-complete-index
(mapcar
(lambda (cmpl)
(let
((regexp (car cmpl))
(subm (cond ((nth 1 cmpl)) (0)))
(app (cond ((nth 2 cmpl)) ("")))
(re-list (cond ((nth 3 cmpl)) ('((".")))))
(obarr (make-vector 47 0)))
(list regexp subm subm app
(word-help-extract-matches from-ob obarr
re-list))))
word-help-complete-list))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Misc. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Default mapping
(defun word-help-make-default-map (list vars)
"Makes a default mapping for `vars', which must be listed in order.
vars is a list of quoted symbols. If the nth entry in the list is
non-nil, the nth variable will be given this value. If nil, the var
will be given the global default value."
(set (car vars) (cond ((car list)) ((default-value (car vars)))))
(if (cdr vars)
(word-help-make-default-map (cdr list) (cdr vars))))
(provide 'word-help)
;;; word-help.el ends here

94
lispref/buffer-local.texi
View file

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

349
nt/config.w95
View file

@ -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 <signal.h>. */
#undef SYS_SIGLIST_DECLARED
/* Define if `struct utimbuf' is declared by <utime.h>. */
#undef HAVE_STRUCT_UTIMBUF
/* Define if `struct timeval' is declared by <sys/time.h>. */
#undef HAVE_TIMEVAL
/* If using GNU, then support inline function declarations. */
#ifdef __GNUC__
#define INLINE __inline__
#else
#define INLINE
#endif
#undef EMACS_CONFIGURATION
#undef EMACS_CONFIG_OPTIONS
/* The configuration script defines opsysfile to be the name of the
s/SYSTEM.h file that describes the system type you are using. The file
is chosen based on the configuration name you give.
See the file ../etc/MACHINES for a list of systems and the
configuration names to use for them.
See s/template.h for documentation on writing s/SYSTEM.h files. */
#undef config_opsysfile
#include "s/windows95.h"
/* The configuration script defines machfile to be the name of the
m/MACHINE.h file that describes the machine you are using. The file is
chosen based on the configuration name you give.
See the file ../etc/MACHINES for a list of machines and the
configuration names to use for them.
See m/template.h for documentation on writing m/MACHINE.h files. */
#undef config_machfile
#include "m/intel386.h"
/* These typedefs shouldn't appear when alloca.s or Makefile.in
includes config.h. */
#ifndef NOT_C_CODE
#ifndef SPECIAL_EMACS_INT
typedef long EMACS_INT;
typedef unsigned long EMACS_UINT;
#endif
#endif
/* Load in the conversion definitions if this system
needs them and the source file being compiled has not
said to inhibit this. There should be no need for you
to alter these lines. */
#ifdef SHORTNAMES
#ifndef NO_SHORTNAMES
#include "../shortnames/remap.h"
#endif /* not NO_SHORTNAMES */
#endif /* SHORTNAMES */
/* If no remapping takes place, static variables cannot be dumped as
pure, so don't worry about the `static' keyword. */
#ifdef NO_REMAP
#undef static
#endif
/* Define `subprocesses' should be defined if you want to
have code for asynchronous subprocesses
(as used in M-x compile and M-x shell).
These do not work for some USG systems yet;
for the ones where they work, the s/SYSTEM.h file defines this flag. */
#ifndef VMS
#ifndef USG
/* #define subprocesses */
#endif
#endif
/* Define LD_SWITCH_SITE to contain any special flags your loader may need. */
#undef LD_SWITCH_SITE
/* Define C_SWITCH_SITE to contain any special flags your compiler needs. */
#undef C_SWITCH_SITE
/* Define LD_SWITCH_X_SITE to contain any special flags your loader
may need to deal with X Windows. For instance, if you've defined
HAVE_X_WINDOWS above and your X libraries aren't in a place that
your loader can find on its own, you might want to add "-L/..." or
something similar. */
#undef LD_SWITCH_X_SITE
/* Define LD_SWITCH_X_SITE_AUX with an -R option
in case it's needed (for Solaris, for example). */
#undef LD_SWITCH_X_SITE_AUX
/* Define C_SWITCH_X_SITE to contain any special flags your compiler
may need to deal with X Windows. For instance, if you've defined
HAVE_X_WINDOWS above and your X include files aren't in a place
that your compiler can find on its own, you might want to add
"-I/..." or something similar. */
#undef C_SWITCH_X_SITE
/* Define STACK_DIRECTION here, but not if m/foo.h did. */
#ifndef STACK_DIRECTION
#undef STACK_DIRECTION
#endif
/* Define the return type of signal handlers if the s-xxx file
did not already do so. */
#define RETSIGTYPE void
/* SIGTYPE is the macro we actually use. */
#ifndef SIGTYPE
#define SIGTYPE RETSIGTYPE
#endif
#ifdef emacs /* Don't do this for lib-src. */
/* Tell regex.c to use a type compatible with Emacs. */
#define RE_TRANSLATE_TYPE Lisp_Object *
#endif
/* The rest of the code currently tests the CPP symbol BSTRING.
Override any claims made by the system-description files.
Note that on some SCO version it is possible to have bcopy and not bcmp. */
#undef BSTRING
#if defined (HAVE_BCOPY) && defined (HAVE_BCMP)
#define BSTRING
#endif
/* Non-ANSI C compilers usually don't have volatile. */
#ifndef HAVE_VOLATILE
#ifndef __STDC__
#define volatile
#endif
#endif
/* Some of the files of Emacs which are intended for use with other
programs assume that if you have a config.h file, you must declare
the type of getenv.
This declaration shouldn't appear when alloca.s or Makefile.in
includes config.h. */
#ifndef NOT_C_CODE
extern char *getenv ();
#endif
#endif /* EMACS_CONFIG_H */
/* These default definitions are good for almost all machines.
The exceptions override them in m/*.h. */
#ifndef BITS_PER_CHAR
#define BITS_PER_CHAR 8
#endif
#ifndef BITS_PER_SHORT
#define BITS_PER_SHORT 16
#endif
/* Note that lisp.h uses this in a preprocessor conditional, so it
would not work to use sizeof. That being so, we do all of them
without sizeof, for uniformity's sake. */
#ifndef BITS_PER_INT
#define BITS_PER_INT 32
#endif
#ifndef BITS_PER_LONG
#define BITS_PER_LONG 32
#endif

40
nt/debug.bat
View file

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

44
nt/emacs.bat
View file

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

88
nt/install
View file

@ -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/<version>.
Configuring:
(1) In previous versions, you needed to edit makefile.def
to reflect the compiler package that you are using. You should no
longer have to do this if you have defined the INCLUDE and LIB
environment variables, as is customary for use with Windows compilers.
(Unless you are using MSVCNT 1.1, in which case you will need
to set MSVCNT11 to be a non-zero value at the top of makefile.def.)
(2) Choose the directory into which Emacs will be installed, and
edit makefile.def to define INSTALL_DIR to be this directory.
(Alternatively, if you have INSTALL_DIR set as an environment
variable, the build process will ignore the value in makefile.def
and use the value of the environment variable instead.) Note
that if it is not installed in the directory in which it is built,
the ~16 MB of lisp files will be copied into the installation directory.
Also, makefile.def is sometimes unpacked read-only; use
> attrib -r makefile.def
to make it writable.
(3) You may need to edit nt/paths.h to specify some other device
instead of `C:'.
Building:
(4) The target to compile the sources is "all", and is recursive starting
one directory up. The makefiles for the NT port are in files named
"makefile.nt". To get things started, type in this directory:
> nmake -f makefile.nt all
or use the ebuild.bat file.
When the files are compiled, you will see some warning messages declaring
that some functions don't return a value, or that some data conversions
will be lossy, etc. You can safely ignore these messages. The warnings
may be fixed in the main FSF source at some point, but until then we
will just live with them.
NOTE: You should not have to edit src\paths.h to get Emacs to run
correctly. All of the variables in src\paths.h are configured
during start up using the nt\emacs.bat file (which gets installed
as bin\emacs.bat -- see below).
Installing:
(5) Currently, Emacs requires a number of environment variables to be set
for it to run correctly. A batch file, emacs.bat, is provided that
sets these variables appropriately and then runs the executable
(emacs.bat is generated using the definition of INSTALL_DIR in
nt\makefile.def and the contents of nt\emacs.bat.in).
(6) The install process will install the files necessary to run Emacs in
INSTALL_DIR (which may be the directory in which it was built),
and create a program manager/folder icon in a folder called GNU Emacs.
From this directory, type:
> nmake -f makefile.nt install
or use the install.bat file.
(7) Create the Emacs startup file. Under Unix, this file is .emacs;
under NT and Win95, this files is _emacs. (If you would like to
use a .emacs file that, for example, you share with a Unix version
of Emacs, you can invoke Emacs with the -l option to specify the
.emacs file that you would like to load.) Note that Emacs requires
the environment variable HOME to be set in order for it to locate the
_emacs file. Ideally, HOME should not be set in the emacs.bat file
as it will be different for each user. (HOME could be set,
for example, in the System panel of the Control Panel).
(8) Either click on the icon, or run the emacs.bat file, and away you go.
If you would like to resize the command window that Emacs uses,
or change the font or colors, click on the program manager icon
to start Emacs. Change the settings using the "-" menu in the upper
left hand corner of the window, making sure to select the "Save"
options in the dialog boxes as you do so. Exit Emacs and restart.

1226
src/Makefile.in
View file

File diff suppressed because it is too large Load diff

179
src/XTests.c
View file

@ -1,179 +0,0 @@
#include <X11/Xlib.h>
#include <X11/X.h>
#include <X11/Xutil.h>
#include <X11/Xresource.h>
#include "XTests.h"
#include <stdio.h>
static Display *dpy;
static void
quit (dpy)
Display *dpy;
{
XCloseDisplay (dpy);
exit (0);
}
static Colormap screen_colormap;
static unsigned long
obtain_color (color)
char *color;
{
int exists;
XColor color_def;
if (!screen_colormap)
screen_colormap = DefaultColormap (dpy, DefaultScreen (dpy));
exists = XParseColor (dpy, screen_colormap, color, &color_def)
&& XAllocColor (dpy, screen_colormap, &color_def);
if (exists)
return color_def.pixel;
fprintf (stderr, "Can't get color; using black.");
return BlackPixel (dpy, DefaultScreen (dpy));
}
static char *visual_strings[] =
{
"StaticGray ",
"GrayScale ",
"StaticColor",
"PseudoColor",
"TrueColor ",
"DirectColor"
};
main (argc,argv)
int argc;
char *argv[];
{
char *dpy_string;
int n;
long mask;
Visual *my_visual;
XVisualInfo *vinfo, visual_template;
XEvent event;
Window window;
Screen *scr;
XGCValues gc_values;
GC fill_gc, pix_gc, line_xor_gc, line_xor_inv_gc;
int i;
int x, y, width, height, geometry, gravity;
char *geo;
char default_geo[] = "80x40+0+0";
int depth;
Pixmap pix;
char *string = "Kill the head and the body will die.";
char dash_list[] = {4, 4};
int dashes = 2;
if (argc < 2)
dpy_string = "localhost:0.0";
else
dpy_string = argv[1];
if (argc >= 3)
{
XSizeHints hints;
printf ("Geometry: %s\t(default: %s)\n", argv[2], default_geo);
geo = argv[2];
XWMGeometry (dpy, DefaultScreen (dpy), geo, default_geo,
3, &hints, &x, &y, &width, &height, &gravity);
}
dpy = XOpenDisplay (dpy_string);
if (!dpy)
{
printf ("Can' open display %s\n", dpy_string);
exit (1);
}
window = XCreateSimpleWindow (dpy, DefaultRootWindow (dpy),
300, 300, 300, 300, 1,
BlackPixel (dpy, DefaultScreen (dpy)),
WhitePixel (dpy, DefaultScreen (dpy)));
XSelectInput (dpy, window, ButtonPressMask | KeyPressMask
| EnterWindowMask | LeaveWindowMask);
gc_values.foreground = obtain_color ("blue");
gc_values.background = WhitePixel (dpy, DefaultScreen (dpy));
fill_gc = XCreateGC (dpy, window, GCForeground | GCBackground,
&gc_values);
gc_values.foreground = obtain_color ("red");
gc_values.line_width = 3;
gc_values.line_style = LineOnOffDash;
gc_values.cap_style = CapRound;
gc_values.join_style = JoinRound;
line_xor_gc = XCreateGC (dpy, window,
GCForeground | GCBackground | GCLineStyle
| GCJoinStyle | GCCapStyle | GCLineWidth,
&gc_values);
XSetDashes (dpy, line_xor_gc, 0, dash_list, dashes);
line_xor_inv_gc = XCreateGC (dpy, window,
GCForeground | GCBackground | GCLineWidth,
&gc_values);
depth = DefaultDepthOfScreen (ScreenOfDisplay (dpy, DefaultScreen (dpy)));
pix = XCreateBitmapFromData (dpy, window, page_glyf_bits,
page_glyf_width, page_glyf_height);
XMapWindow (dpy, window);
XFlush (dpy);
while (1)
{
XNextEvent (dpy, &event);
switch (event.type)
{
case ButtonPress:
switch (event.xbutton.button)
{
case Button1:
XDrawLine (dpy, window, line_xor_gc, 25, 75, 300, 75);
break;
case Button2:
XDrawLine (dpy, window, line_xor_inv_gc, 25, 25, 300, 25);
break;
case Button3:
XDrawLine (dpy, window, line_xor_gc, 25, 25, 25, 125);
break;
}
break;
case KeyPress:
{
char buf[20];
int n;
XComposeStatus status;
KeySym keysym;
n = XLookupString (&event, buf, 20, &keysym,
(XComposeStatus *) &status);
if (n == 1 && buf[0] == 'q')
quit (dpy);
}
break;
case EnterNotify:
XCopyPlane (dpy, pix, window, fill_gc, 0, 0,
page_glyf_width, page_glyf_height, 100, 100, 1L);
XFillRectangle (dpy, window, fill_gc, 50, 50, 50, 50);
break;
case LeaveNotify:
XClearWindow (dpy, window);
break;
}
XFlush (dpy);
}
}

7
src/XTests.h
View file

@ -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};

10
src/convexos.h
View file

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

316
src/environ.c
View file

@ -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 */

115
src/m/dos386.h
View file

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

48
src/mach2.h
View file

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

1069
src/old-ralloc.c
View file

File diff suppressed because it is too large Load diff

18
src/sol2-2.h
View file

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

952
src/unexelf1.c
View file

@ -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 <sys/types.h>
#include <stdio.h>
#include <sys/stat.h>
#include <memory.h>
#include <string.h>
#include <errno.h>
#include <unistd.h>
#include <fcntl.h>
#include <elf.h>
#include <sys/mman.h>
#ifdef __alpha__
# include <sym.h> /* get COFF debugging symbol table declaration */
#endif
#if __GNU_LIBRARY__ - 0 >= 6
# include <link.h> /* get ElfW etc */
#endif
#ifndef ElfW
# ifdef __STDC__
# define ElfW(type) Elf32_##type
# else
# define ElfW(type) Elf32_/**/type
# endif
#endif
#ifndef emacs
#define fatal(a, b, c) fprintf (stderr, a, b, c), exit (1)
#else
#include <config.h>
extern void fatal (char *, ...);
#endif
#ifndef ELF_BSS_SECTION_NAME
#define ELF_BSS_SECTION_NAME ".bss"
#endif
/* Get the address of a particular section or program header entry,
* accounting for the size of the entries.
*/
/*
On PPC Reference Platform running Solaris 2.5.1
the plt section is also of type NOBI like the bss section.
(not really stored) and therefore sections after the bss
section start at the plt offset. The plt section is always
the one just before the bss section.
Thus, we modify the test from
if (NEW_SECTION_H (nn).sh_offset >= new_data2_offset)
to
if (NEW_SECTION_H (nn).sh_offset >=
OLD_SECTION_H (old_bss_index-1).sh_offset)
This is just a hack. We should put the new data section
before the .plt section.
And we should not have this routine at all but use
the libelf library to read the old file and create the new
file.
The changed code is minimal and depends on prep set in m/prep.h
Erik Deumens
Quantum Theory Project
University of Florida
deumens@qtp.ufl.edu
Apr 23, 1996
*/
#define OLD_SECTION_H(n) \
(*(ElfW(Shdr) *) ((byte *) old_section_h + old_file_h->e_shentsize * (n)))
#define NEW_SECTION_H(n) \
(*(ElfW(Shdr) *) ((byte *) new_section_h + new_file_h->e_shentsize * (n)))
#define OLD_PROGRAM_H(n) \
(*(ElfW(Phdr) *) ((byte *) old_program_h + old_file_h->e_phentsize * (n)))
#define NEW_PROGRAM_H(n) \
(*(ElfW(Phdr) *) ((byte *) new_program_h + new_file_h->e_phentsize * (n)))
#define PATCH_INDEX(n) \
do { \
if ((int) (n) >= old_bss_index) \
(n)++; } while (0)
typedef unsigned char byte;
/* Round X up to a multiple of Y. */
int
round_up (x, y)
int x, y;
{
int rem = x % y;
if (rem == 0)
return x;
return x - rem + y;
}
/* ****************************************************************
* unexec
*
* driving logic.
*
* In ELF, this works by replacing the old .bss section with a new
* .data section, and inserting an empty .bss immediately afterwards.
*
*/
void
unexec (new_name, old_name, data_start, bss_start, entry_address)
char *new_name, *old_name;
unsigned data_start, bss_start, entry_address;
{
int new_file, old_file, new_file_size;
/* Pointers to the base of the image of the two files. */
caddr_t old_base, new_base;
/* Pointers to the file, program and section headers for the old and new
* files.
*/
ElfW(Ehdr) *old_file_h, *new_file_h;
ElfW(Phdr) *old_program_h, *new_program_h;
ElfW(Shdr) *old_section_h, *new_section_h;
/* Point to the section name table in the old file */
char *old_section_names;
ElfW(Addr) old_bss_addr, new_bss_addr;
ElfW(Word) old_bss_size, new_data2_size;
ElfW(Off) new_data2_offset;
ElfW(Addr) new_data2_addr;
int n, nn, old_bss_index, old_data_index, new_data2_index;
struct stat stat_buf;
/* Open the old file & map it into the address space. */
old_file = open (old_name, O_RDONLY);
if (old_file < 0)
fatal ("Can't open %s for reading: errno %d\n", old_name, errno);
if (fstat (old_file, &stat_buf) == -1)
fatal ("Can't fstat (%s): errno %d\n", old_name, errno);
old_base = mmap (0, stat_buf.st_size, PROT_READ, MAP_SHARED, old_file, 0);
if (old_base == (caddr_t) -1)
fatal ("Can't mmap (%s): errno %d\n", old_name, errno);
#ifdef DEBUG
fprintf (stderr, "mmap (%s, %x) -> %x\n", old_name, stat_buf.st_size,
old_base);
#endif
/* Get pointers to headers & section names */
old_file_h = (ElfW(Ehdr) *) old_base;
old_program_h = (ElfW(Phdr) *) ((byte *) old_base + old_file_h->e_phoff);
old_section_h = (ElfW(Shdr) *) ((byte *) old_base + old_file_h->e_shoff);
old_section_names = (char *) old_base
+ OLD_SECTION_H (old_file_h->e_shstrndx).sh_offset;
/* Find the old .bss section. Figure out parameters of the new
* data2 and bss sections.
*/
for (old_bss_index = 1; old_bss_index < (int) old_file_h->e_shnum;
old_bss_index++)
{
#ifdef DEBUG
fprintf (stderr, "Looking for .bss - found %s\n",
old_section_names + OLD_SECTION_H (old_bss_index).sh_name);
#endif
if (!strcmp (old_section_names + OLD_SECTION_H (old_bss_index).sh_name,
ELF_BSS_SECTION_NAME))
break;
}
if (old_bss_index == old_file_h->e_shnum)
fatal ("Can't find .bss in %s.\n", old_name, 0);
old_bss_addr = OLD_SECTION_H (old_bss_index).sh_addr;
old_bss_size = OLD_SECTION_H (old_bss_index).sh_size;
#if defined(emacs) || !defined(DEBUG)
new_bss_addr = (ElfW(Addr)) sbrk (0);
#else
new_bss_addr = old_bss_addr + old_bss_size + 0x1234;
#endif
new_data2_addr = old_bss_addr;
new_data2_size = new_bss_addr - old_bss_addr;
new_data2_offset = OLD_SECTION_H (old_bss_index).sh_offset;
#ifdef DEBUG
fprintf (stderr, "old_bss_index %d\n", old_bss_index);
fprintf (stderr, "old_bss_addr %x\n", old_bss_addr);
fprintf (stderr, "old_bss_size %x\n", old_bss_size);
fprintf (stderr, "new_bss_addr %x\n", new_bss_addr);
fprintf (stderr, "new_data2_addr %x\n", new_data2_addr);
fprintf (stderr, "new_data2_size %x\n", new_data2_size);
fprintf (stderr, "new_data2_offset %x\n", new_data2_offset);
#endif
if ((unsigned) new_bss_addr < (unsigned) old_bss_addr + old_bss_size)
fatal (".bss shrank when undumping???\n", 0, 0);
/* Set the output file to the right size and mmap it. Set
* pointers to various interesting objects. stat_buf still has
* old_file data.
*/
new_file = open (new_name, O_RDWR | O_CREAT, 0666);
if (new_file < 0)
fatal ("Can't creat (%s): errno %d\n", new_name, errno);
new_file_size = stat_buf.st_size + old_file_h->e_shentsize + new_data2_size;
if (ftruncate (new_file, new_file_size))
fatal ("Can't ftruncate (%s): errno %d\n", new_name, errno);
#ifdef UNEXEC_USE_MAP_PRIVATE
new_base = mmap (0, new_file_size, PROT_READ | PROT_WRITE, MAP_PRIVATE,
new_file, 0);
#else
new_base = mmap (0, new_file_size, PROT_READ | PROT_WRITE, MAP_SHARED,
new_file, 0);
#endif
if (new_base == (caddr_t) -1)
fatal ("Can't mmap (%s): errno %d\n", new_name, errno);
new_file_h = (ElfW(Ehdr) *) new_base;
new_program_h = (ElfW(Phdr) *) ((byte *) new_base + old_file_h->e_phoff);
new_section_h = (ElfW(Shdr) *)
((byte *) new_base + old_file_h->e_shoff + new_data2_size);
/* Make our new file, program and section headers as copies of the
* originals.
*/
memcpy (new_file_h, old_file_h, old_file_h->e_ehsize);
memcpy (new_program_h, old_program_h,
old_file_h->e_phnum * old_file_h->e_phentsize);
/* Modify the e_shstrndx if necessary. */
PATCH_INDEX (new_file_h->e_shstrndx);
/* Fix up file header. We'll add one section. Section header is
* further away now.
*/
new_file_h->e_shoff += new_data2_size;
new_file_h->e_shnum += 1;
#ifdef DEBUG
fprintf (stderr, "Old section offset %x\n", old_file_h->e_shoff);
fprintf (stderr, "Old section count %d\n", old_file_h->e_shnum);
fprintf (stderr, "New section offset %x\n", new_file_h->e_shoff);
fprintf (stderr, "New section count %d\n", new_file_h->e_shnum);
#endif
/* Fix up a new program header. Extend the writable data segment so
* that the bss area is covered too. Find that segment by looking
* for a segment that ends just before the .bss area. Make sure
* that no segments are above the new .data2. Put a loop at the end
* to adjust the offset and address of any segment that is above
* data2, just in case we decide to allow this later.
*/
for (n = new_file_h->e_phnum - 1; n >= 0; n--)
{
/* Compute maximum of all requirements for alignment of section. */
int alignment = (NEW_PROGRAM_H (n)).p_align;
if ((OLD_SECTION_H (old_bss_index)).sh_addralign > alignment)
alignment = OLD_SECTION_H (old_bss_index).sh_addralign;
if (NEW_PROGRAM_H (n).p_vaddr + NEW_PROGRAM_H (n).p_filesz > old_bss_addr)
fatal ("Program segment above .bss in %s\n", old_name, 0);
if (NEW_PROGRAM_H (n).p_type == PT_LOAD
&& (round_up ((NEW_PROGRAM_H (n)).p_vaddr
+ (NEW_PROGRAM_H (n)).p_filesz,
alignment)
== round_up (old_bss_addr, alignment)))
break;
}
if (n < 0)
fatal ("Couldn't find segment next to .bss in %s\n", old_name, 0);
NEW_PROGRAM_H (n).p_filesz += new_data2_size;
NEW_PROGRAM_H (n).p_memsz = NEW_PROGRAM_H (n).p_filesz;
#if 0 /* Maybe allow section after data2 - does this ever happen? */
for (n = new_file_h->e_phnum - 1; n >= 0; n--)
{
if (NEW_PROGRAM_H (n).p_vaddr
&& NEW_PROGRAM_H (n).p_vaddr >= new_data2_addr)
NEW_PROGRAM_H (n).p_vaddr += new_data2_size - old_bss_size;
if (NEW_PROGRAM_H (n).p_offset >= new_data2_offset)
NEW_PROGRAM_H (n).p_offset += new_data2_size;
}
#endif
/* Fix up section headers based on new .data2 section. Any section
* whose offset or virtual address is after the new .data2 section
* gets its value adjusted. .bss size becomes zero and new address
* is set. data2 section header gets added by copying the existing
* .data header and modifying the offset, address and size.
*/
for (old_data_index = 1; old_data_index < (int) old_file_h->e_shnum;
old_data_index++)
if (!strcmp (old_section_names + OLD_SECTION_H (old_data_index).sh_name,
".data"))
break;
if (old_data_index == old_file_h->e_shnum)
fatal ("Can't find .data in %s.\n", old_name, 0);
/* Walk through all section headers, insert the new data2 section right
before the new bss section. */
for (n = 1, nn = 1; n < (int) old_file_h->e_shnum; n++, nn++)
{
caddr_t src;
/* If it is bss section, insert the new data2 section before it. */
if (n == old_bss_index)
{
/* Steal the data section header for this data2 section. */
memcpy (&NEW_SECTION_H (nn), &OLD_SECTION_H (old_data_index),
new_file_h->e_shentsize);
NEW_SECTION_H (nn).sh_addr = new_data2_addr;
NEW_SECTION_H (nn).sh_offset = new_data2_offset;
NEW_SECTION_H (nn).sh_size = new_data2_size;
/* Use the bss section's alignment. This will assure that the
new data2 section always be placed in the same spot as the old
bss section by any other application. */
NEW_SECTION_H (nn).sh_addralign = OLD_SECTION_H (n).sh_addralign;
/* Now copy over what we have in the memory now. */
memcpy (NEW_SECTION_H (nn).sh_offset + new_base,
(caddr_t) OLD_SECTION_H (n).sh_addr,
new_data2_size);
nn++;
}
memcpy (&NEW_SECTION_H (nn), &OLD_SECTION_H (n),
old_file_h->e_shentsize);
/* The new bss section's size is zero, and its file offset and virtual
address should be off by NEW_DATA2_SIZE. */
if (n == old_bss_index)
{
/* NN should be `old_bss_index + 1' at this point. */
NEW_SECTION_H (nn).sh_offset += new_data2_size;
NEW_SECTION_H (nn).sh_addr += new_data2_size;
/* Let the new bss section address alignment be the same as the
section address alignment followed the old bss section, so
this section will be placed in exactly the same place. */
NEW_SECTION_H (nn).sh_addralign = OLD_SECTION_H (nn).sh_addralign;
NEW_SECTION_H (nn).sh_size = 0;
}
else
{
/* Any section that was original placed AFTER the bss
section should now be off by NEW_DATA2_SIZE. */
#ifdef SOLARIS_POWERPC
/* On PPC Reference Platform running Solaris 2.5.1
the plt section is also of type NOBI like the bss section.
(not really stored) and therefore sections after the bss
section start at the plt offset. The plt section is always
the one just before the bss section.
It would be better to put the new data section before
the .plt section, or use libelf instead.
Erik Deumens, deumens@qtp.ufl.edu. */
if (NEW_SECTION_H (nn).sh_offset
>= OLD_SECTION_H (old_bss_index-1).sh_offset)
NEW_SECTION_H (nn).sh_offset += new_data2_size;
#else
if (round_up (NEW_SECTION_H (nn).sh_offset,
OLD_SECTION_H (old_bss_index).sh_addralign)
>= new_data2_offset)
NEW_SECTION_H (nn).sh_offset += new_data2_size;
#endif
/* Any section that was originally placed after the section
header table should now be off by the size of one section
header table entry. */
if (NEW_SECTION_H (nn).sh_offset > new_file_h->e_shoff)
NEW_SECTION_H (nn).sh_offset += new_file_h->e_shentsize;
}
/* If any section hdr refers to the section after the new .data
section, make it refer to next one because we have inserted
a new section in between. */
PATCH_INDEX (NEW_SECTION_H (nn).sh_link);
/* For symbol tables, info is a symbol table index,
so don't change it. */
if (NEW_SECTION_H (nn).sh_type != SHT_SYMTAB
&& NEW_SECTION_H (nn).sh_type != SHT_DYNSYM)
PATCH_INDEX (NEW_SECTION_H (nn).sh_info);
/* Now, start to copy the content of sections. */
if (NEW_SECTION_H (nn).sh_type == SHT_NULL
|| NEW_SECTION_H (nn).sh_type == SHT_NOBITS)
continue;
/* Write out the sections. .data and .data1 (and data2, called
".data" in the strings table) get copied from the current process
instead of the old file. */
if (!strcmp (old_section_names + NEW_SECTION_H (n).sh_name, ".data")
|| !strcmp ((old_section_names + NEW_SECTION_H (n).sh_name),
".data1"))
src = (caddr_t) OLD_SECTION_H (n).sh_addr;
else
src = old_base + OLD_SECTION_H (n).sh_offset;
memcpy (NEW_SECTION_H (nn).sh_offset + new_base, src,
NEW_SECTION_H (nn).sh_size);
#ifdef __alpha__
/* Update Alpha COFF symbol table: */
if (strcmp (old_section_names + OLD_SECTION_H (n).sh_name, ".mdebug")
== 0)
{
pHDRR symhdr = (pHDRR) (NEW_SECTION_H (nn).sh_offset + new_base);
symhdr->cbLineOffset += new_data2_size;
symhdr->cbDnOffset += new_data2_size;
symhdr->cbPdOffset += new_data2_size;
symhdr->cbSymOffset += new_data2_size;
symhdr->cbOptOffset += new_data2_size;
symhdr->cbAuxOffset += new_data2_size;
symhdr->cbSsOffset += new_data2_size;
symhdr->cbSsExtOffset += new_data2_size;
symhdr->cbFdOffset += new_data2_size;
symhdr->cbRfdOffset += new_data2_size;
symhdr->cbExtOffset += new_data2_size;
}
#endif /* __alpha__ */
/* If it is the symbol table, its st_shndx field needs to be patched. */
if (NEW_SECTION_H (nn).sh_type == SHT_SYMTAB
|| NEW_SECTION_H (nn).sh_type == SHT_DYNSYM)
{
ElfW(Shdr) *spt = &NEW_SECTION_H (nn);
unsigned int num = spt->sh_size / spt->sh_entsize;
ElfW(Sym) * sym = (ElfW(Sym) *) (NEW_SECTION_H (nn).sh_offset +
new_base);
for (; num--; sym++)
{
if ((sym->st_shndx == SHN_UNDEF)
|| (sym->st_shndx == SHN_ABS)
|| (sym->st_shndx == SHN_COMMON))
continue;
PATCH_INDEX (sym->st_shndx);
}
}
}
/* Update the symbol values of _edata and _end. */
for (n = new_file_h->e_shnum - 1; n; n--)
{
byte *symnames;
ElfW(Sym) *symp, *symendp;
if (NEW_SECTION_H (n).sh_type != SHT_DYNSYM
&& NEW_SECTION_H (n).sh_type != SHT_SYMTAB)
continue;
symnames = ((byte *) new_base
+ NEW_SECTION_H (NEW_SECTION_H (n).sh_link).sh_offset);
symp = (ElfW(Sym) *) (NEW_SECTION_H (n).sh_offset + new_base);
symendp = (ElfW(Sym) *) ((byte *)symp + NEW_SECTION_H (n).sh_size);
for (; symp < symendp; symp ++)
if (strcmp ((char *) (symnames + symp->st_name), "_end") == 0
|| strcmp ((char *) (symnames + symp->st_name), "_edata") == 0)
memcpy (&symp->st_value, &new_bss_addr, sizeof (new_bss_addr));
}
/* This loop seeks out relocation sections for the data section, so
that it can undo relocations performed by the runtime linker. */
for (n = new_file_h->e_shnum - 1; n; n--)
{
ElfW(Shdr) section = NEW_SECTION_H (n);
switch (section.sh_type) {
default:
break;
case SHT_REL:
case SHT_RELA:
/* This code handles two different size structs, but there should
be no harm in that provided that r_offset is always the first
member. */
nn = section.sh_info;
if (!strcmp (old_section_names + NEW_SECTION_H (nn).sh_name, ".data")
|| !strcmp ((old_section_names + NEW_SECTION_H (nn).sh_name),
".data1"))
{
ElfW(Addr) offset = NEW_SECTION_H (nn).sh_addr -
NEW_SECTION_H (nn).sh_offset;
caddr_t reloc = old_base + section.sh_offset, end;
for (end = reloc + section.sh_size; reloc < end;
reloc += section.sh_entsize)
{
ElfW(Addr) addr = ((ElfW(Rel) *) reloc)->r_offset - offset;
#ifdef __alpha__
/* The Alpha ELF binutils currently have a bug that
sometimes results in relocs that contain all
zeroes. Work around this for now... */
if (((ElfW(Rel) *) reloc)->r_offset == 0)
continue;
#endif
memcpy (new_base + addr, old_base + addr, sizeof(ElfW(Addr)));
}
}
break;
}
}
#ifdef UNEXEC_USE_MAP_PRIVATE
if (lseek (new_file, 0, SEEK_SET) == -1)
fatal ("Can't rewind (%s): errno %d\n", new_name, errno);
if (write (new_file, new_base, new_file_size) != new_file_size)
fatal ("Can't write (%s): errno %d\n", new_name, errno);
#endif
/* Close the files and make the new file executable. */
if (close (old_file))
fatal ("Can't close (%s): errno %d\n", old_name, errno);
if (close (new_file))
fatal ("Can't close (%s): errno %d\n", new_name, errno);
if (stat (new_name, &stat_buf) == -1)
fatal ("Can't stat (%s): errno %d\n", new_name, errno);
n = umask (777);
umask (n);
stat_buf.st_mode |= 0111 & ~n;
if (chmod (new_name, stat_buf.st_mode) == -1)
fatal ("Can't chmod (%s): errno %d\n", new_name, errno);
}

900
src/unexsgi.c
View file

@ -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 <config.h>
#include <sys/types.h>
#include <stdio.h>
#include <sys/stat.h>
#include <memory.h>
#include <string.h>
#include <errno.h>
#include <unistd.h>
#include <fcntl.h>
#include <elf.h>
#include <syms.h> /* for HDRR declaration */
#include <sys/mman.h>
#ifndef emacs
#define fatal(a, b, c) fprintf(stderr, a, b, c), exit(1)
#else
extern void fatal(char *, ...);
#endif
/* Get the address of a particular section or program header entry,
* accounting for the size of the entries.
*/
#define OLD_SECTION_H(n) \
(*(Elf32_Shdr *) ((byte *) old_section_h + old_file_h->e_shentsize * (n)))
#define NEW_SECTION_H(n) \
(*(Elf32_Shdr *) ((byte *) new_section_h + new_file_h->e_shentsize * (n)))
#define OLD_PROGRAM_H(n) \
(*(Elf32_Phdr *) ((byte *) old_program_h + old_file_h->e_phentsize * (n)))
#define NEW_PROGRAM_H(n) \
(*(Elf32_Phdr *) ((byte *) new_program_h + new_file_h->e_phentsize * (n)))
#define PATCH_INDEX(n) \
do { \
if ((n) >= old_bss_index) \
(n)++; } while (0)
typedef unsigned char byte;
/* Round X up to a multiple of Y. */
int
round_up (x, y)
int x, y;
{
int rem = x % y;
if (rem == 0)
return x;
return x - rem + y;
}
/* Return the index of the section named NAME.
SECTION_NAMES, FILE_NAME and FILE_H give information
about the file we are looking in.
If we don't find the section NAME, that is a fatal error
if NOERROR is 0; we return -1 if NOERROR is nonzero. */
static int
find_section (name, section_names, file_name, old_file_h, old_section_h, noerror)
char *name;
char *section_names;
char *file_name;
Elf32_Ehdr *old_file_h;
Elf32_Shdr *old_section_h;
int noerror;
{
int idx;
for (idx = 1; idx < old_file_h->e_shnum; idx++)
{
#ifdef DEBUG
fprintf (stderr, "Looking for %s - found %s\n", name,
section_names + OLD_SECTION_H (idx).sh_name);
#endif
if (!strcmp (section_names + OLD_SECTION_H (idx).sh_name,
name))
break;
}
if (idx == old_file_h->e_shnum)
{
if (noerror)
return -1;
else
fatal ("Can't find .bss in %s.\n", file_name, 0);
}
return idx;
}
/* ****************************************************************
* unexec
*
* driving logic.
*
* In ELF, this works by replacing the old .bss section with a new
* .data section, and inserting an empty .bss immediately afterwards.
*
*/
void
unexec (new_name, old_name, data_start, bss_start, entry_address)
char *new_name, *old_name;
unsigned data_start, bss_start, entry_address;
{
extern unsigned int bss_end;
int new_file, old_file, new_file_size;
/* Pointers to the base of the image of the two files. */
caddr_t old_base, new_base;
/* Pointers to the file, program and section headers for the old and new
files. */
Elf32_Ehdr *old_file_h, *new_file_h;
Elf32_Phdr *old_program_h, *new_program_h;
Elf32_Shdr *old_section_h, *new_section_h;
/* Point to the section name table in the old file. */
char *old_section_names;
Elf32_Addr old_bss_addr, new_bss_addr;
Elf32_Word old_bss_size, new_data2_size;
Elf32_Off new_data2_offset;
Elf32_Addr new_data2_addr;
Elf32_Addr new_offsets_shift;
int n, nn, old_bss_index, old_data_index, new_data2_index;
int old_mdebug_index;
struct stat stat_buf;
/* Open the old file & map it into the address space. */
old_file = open (old_name, O_RDONLY);
if (old_file < 0)
fatal ("Can't open %s for reading: errno %d\n", old_name, errno);
if (fstat (old_file, &stat_buf) == -1)
fatal ("Can't fstat(%s): errno %d\n", old_name, errno);
old_base = mmap (0, stat_buf.st_size, PROT_READ, MAP_SHARED, old_file, 0);
if (old_base == (caddr_t) -1)
fatal ("Can't mmap(%s): errno %d\n", old_name, errno);
#ifdef DEBUG
fprintf (stderr, "mmap(%s, %x) -> %x\n", old_name, stat_buf.st_size,
old_base);
#endif
/* Get pointers to headers & section names. */
old_file_h = (Elf32_Ehdr *) old_base;
old_program_h = (Elf32_Phdr *) ((byte *) old_base + old_file_h->e_phoff);
old_section_h = (Elf32_Shdr *) ((byte *) old_base + old_file_h->e_shoff);
old_section_names
= (char *) old_base + OLD_SECTION_H (old_file_h->e_shstrndx).sh_offset;
/* Find the mdebug section, if any. */
old_mdebug_index = find_section (".mdebug", old_section_names,
old_name, old_file_h, old_section_h, 1);
/* Find the old .bss section. */
old_bss_index = find_section (".bss", old_section_names,
old_name, old_file_h, old_section_h, 0);
/* Find the old .data section. Figure out parameters of
the new data2 and bss sections. */
old_data_index = find_section (".data", old_section_names,
old_name, old_file_h, old_section_h, 0);
old_bss_addr = OLD_SECTION_H (old_bss_index).sh_addr;
old_bss_size = OLD_SECTION_H (old_bss_index).sh_size;
#if defined(emacs) || !defined(DEBUG)
bss_end = (unsigned int) sbrk (0);
new_bss_addr = (Elf32_Addr) bss_end;
#else
new_bss_addr = old_bss_addr + old_bss_size + 0x1234;
#endif
new_data2_addr = old_bss_addr;
new_data2_size = new_bss_addr - old_bss_addr;
new_data2_offset = OLD_SECTION_H (old_data_index).sh_offset +
(new_data2_addr - OLD_SECTION_H (old_data_index).sh_addr);
new_offsets_shift = new_bss_addr -
((old_bss_addr & ~0xfff) + ((old_bss_addr & 0xfff) ? 0x1000 : 0));
#ifdef DEBUG
fprintf (stderr, "old_bss_index %d\n", old_bss_index);
fprintf (stderr, "old_bss_addr %x\n", old_bss_addr);
fprintf (stderr, "old_bss_size %x\n", old_bss_size);
fprintf (stderr, "new_bss_addr %x\n", new_bss_addr);
fprintf (stderr, "new_data2_addr %x\n", new_data2_addr);
fprintf (stderr, "new_data2_size %x\n", new_data2_size);
fprintf (stderr, "new_data2_offset %x\n", new_data2_offset);
fprintf (stderr, "new_offsets_shift %x\n", new_offsets_shift);
#endif
if ((unsigned) new_bss_addr < (unsigned) old_bss_addr + old_bss_size)
fatal (".bss shrank when undumping???\n", 0, 0);
/* Set the output file to the right size and mmap it. Set
pointers to various interesting objects. stat_buf still has
old_file data. */
new_file = open (new_name, O_RDWR | O_CREAT, 0666);
if (new_file < 0)
fatal ("Can't creat (%s): errno %d\n", new_name, errno);
new_file_size = stat_buf.st_size + old_file_h->e_shentsize + new_offsets_shift;
if (ftruncate (new_file, new_file_size))
fatal ("Can't ftruncate (%s): errno %d\n", new_name, errno);
new_base = mmap (0, new_file_size, PROT_READ | PROT_WRITE, MAP_SHARED,
new_file, 0);
if (new_base == (caddr_t) -1)
fatal ("Can't mmap (%s): errno %d\n", new_name, errno);
new_file_h = (Elf32_Ehdr *) new_base;
new_program_h = (Elf32_Phdr *) ((byte *) new_base + old_file_h->e_phoff);
new_section_h
= (Elf32_Shdr *) ((byte *) new_base + old_file_h->e_shoff
+ new_offsets_shift);
/* Make our new file, program and section headers as copies of the
originals. */
memcpy (new_file_h, old_file_h, old_file_h->e_ehsize);
memcpy (new_program_h, old_program_h,
old_file_h->e_phnum * old_file_h->e_phentsize);
/* Modify the e_shstrndx if necessary. */
PATCH_INDEX (new_file_h->e_shstrndx);
/* Fix up file header. We'll add one section. Section header is
further away now. */
new_file_h->e_shoff += new_offsets_shift;
new_file_h->e_shnum += 1;
#ifdef DEBUG
fprintf (stderr, "Old section offset %x\n", old_file_h->e_shoff);
fprintf (stderr, "Old section count %d\n", old_file_h->e_shnum);
fprintf (stderr, "New section offset %x\n", new_file_h->e_shoff);
fprintf (stderr, "New section count %d\n", new_file_h->e_shnum);
#endif
/* Fix up a new program header. Extend the writable data segment so
that the bss area is covered too. Find that segment by looking
for a segment that ends just before the .bss area. Make sure
that no segments are above the new .data2. Put a loop at the end
to adjust the offset and address of any segment that is above
data2, just in case we decide to allow this later. */
for (n = new_file_h->e_phnum - 1; n >= 0; n--)
{
/* Compute maximum of all requirements for alignment of section. */
int alignment = (NEW_PROGRAM_H (n)).p_align;
if ((OLD_SECTION_H (old_bss_index)).sh_addralign > alignment)
alignment = OLD_SECTION_H (old_bss_index).sh_addralign;
/* Supposedly this condition is okay for the SGI. */
#if 0
if (NEW_PROGRAM_H (n).p_vaddr + NEW_PROGRAM_H (n).p_filesz > old_bss_addr)
fatal ("Program segment above .bss in %s\n", old_name, 0);
#endif
if (NEW_PROGRAM_H (n).p_type == PT_LOAD
&& (round_up ((NEW_PROGRAM_H (n)).p_vaddr
+ (NEW_PROGRAM_H (n)).p_filesz,
alignment)
== round_up (old_bss_addr, alignment)))
break;
}
if (n < 0)
fatal ("Couldn't find segment next to .bss in %s\n", old_name, 0);
NEW_PROGRAM_H (n).p_filesz += new_offsets_shift;
NEW_PROGRAM_H (n).p_memsz = NEW_PROGRAM_H (n).p_filesz;
#if 1 /* Maybe allow section after data2 - does this ever happen? */
for (n = new_file_h->e_phnum - 1; n >= 0; n--)
{
if (NEW_PROGRAM_H (n).p_vaddr
&& NEW_PROGRAM_H (n).p_vaddr >= new_data2_addr)
NEW_PROGRAM_H (n).p_vaddr += new_offsets_shift - old_bss_size;
if (NEW_PROGRAM_H (n).p_offset >= new_data2_offset)
NEW_PROGRAM_H (n).p_offset += new_offsets_shift;
}
#endif
/* Fix up section headers based on new .data2 section. Any section
whose offset or virtual address is after the new .data2 section
gets its value adjusted. .bss size becomes zero and new address
is set. data2 section header gets added by copying the existing
.data header and modifying the offset, address and size. */
for (old_data_index = 1; old_data_index < old_file_h->e_shnum;
old_data_index++)
if (!strcmp (old_section_names + OLD_SECTION_H (old_data_index).sh_name,
".data"))
break;
if (old_data_index == old_file_h->e_shnum)
fatal ("Can't find .data in %s.\n", old_name, 0);
/* Walk through all section headers, insert the new data2 section right
before the new bss section. */
for (n = 1, nn = 1; n < old_file_h->e_shnum; n++, nn++)
{
caddr_t src;
/* If it is bss section, insert the new data2 section before it. */
if (n == old_bss_index)
{
/* Steal the data section header for this data2 section. */
memcpy (&NEW_SECTION_H (nn), &OLD_SECTION_H (old_data_index),
new_file_h->e_shentsize);
NEW_SECTION_H (nn).sh_addr = new_data2_addr;
NEW_SECTION_H (nn).sh_offset = new_data2_offset;
NEW_SECTION_H (nn).sh_size = new_data2_size;
/* Use the bss section's alignment. This will assure that the
new data2 section always be placed in the same spot as the old
bss section by any other application. */
NEW_SECTION_H (nn).sh_addralign = OLD_SECTION_H (n).sh_addralign;
/* Now copy over what we have in the memory now. */
memcpy (NEW_SECTION_H (nn).sh_offset + new_base,
(caddr_t) OLD_SECTION_H (n).sh_addr,
new_data2_size);
nn++;
memcpy (&NEW_SECTION_H (nn), &OLD_SECTION_H (n),
old_file_h->e_shentsize);
/* The new bss section's size is zero, and its file offset and virtual
address should be off by NEW_OFFSETS_SHIFT. */
NEW_SECTION_H (nn).sh_offset += new_offsets_shift;
NEW_SECTION_H (nn).sh_addr = new_bss_addr;
/* Let the new bss section address alignment be the same as the
section address alignment followed the old bss section, so
this section will be placed in exactly the same place. */
NEW_SECTION_H (nn).sh_addralign = OLD_SECTION_H (nn).sh_addralign;
NEW_SECTION_H (nn).sh_size = 0;
}
else
{
memcpy (&NEW_SECTION_H (nn), &OLD_SECTION_H (n),
old_file_h->e_shentsize);
/* Any section that was original placed AFTER the bss
section must now be adjusted by NEW_OFFSETS_SHIFT. */
if (NEW_SECTION_H (nn).sh_offset >= new_data2_offset)
NEW_SECTION_H (nn).sh_offset += new_offsets_shift;
}
/* If any section hdr refers to the section after the new .data
section, make it refer to next one because we have inserted
a new section in between. */
PATCH_INDEX (NEW_SECTION_H (nn).sh_link);
/* For symbol tables, info is a symbol table index,
so don't change it. */
if (NEW_SECTION_H (nn).sh_type != SHT_SYMTAB
&& NEW_SECTION_H (nn).sh_type != SHT_DYNSYM)
PATCH_INDEX (NEW_SECTION_H (nn).sh_info);
/* Now, start to copy the content of sections. */
if (NEW_SECTION_H (nn).sh_type == SHT_NULL
|| NEW_SECTION_H (nn).sh_type == SHT_NOBITS)
continue;
/* Write out the sections. .data and .data1 (and data2, called
".data" in the strings table) get copied from the current process
instead of the old file. */
if (!strcmp (old_section_names + NEW_SECTION_H (nn).sh_name, ".data")
|| !strcmp (old_section_names + NEW_SECTION_H (nn).sh_name, ".data1")
#ifdef IRIX6_5
/* Under IRIX 6.5 gcc places objects with adresses relative to
shared symbols in the section .rodata, which are adjusted at
startup time. Unfortunately they aren't adjusted after unexec,
so with this configuration we must get .rodata also from memory.
Do any other configurations need this, too?
<Wolfgang.Glas@hfm.tu-graz.ac.at> 1999-06-08. */
|| !strcmp (old_section_names + NEW_SECTION_H (nn).sh_name, ".rodata")
#endif
|| !strcmp (old_section_names + NEW_SECTION_H (nn).sh_name, ".got"))
src = (caddr_t) OLD_SECTION_H (n).sh_addr;
else
src = old_base + OLD_SECTION_H (n).sh_offset;
memcpy (NEW_SECTION_H (nn).sh_offset + new_base, src,
NEW_SECTION_H (nn).sh_size);
/* Adjust the HDRR offsets in .mdebug and copy the
line data if it's in its usual 'hole' in the object.
Makes the new file debuggable with dbx.
patches up two problems: the absolute file offsets
in the HDRR record of .mdebug (see /usr/include/syms.h), and
the ld bug that gets the line table in a hole in the
elf file rather than in the .mdebug section proper.
David Anderson. davea@sgi.com Jan 16,1994. */
if (n == old_mdebug_index)
{
#define MDEBUGADJUST(__ct,__fileaddr) \
if (n_phdrr->__ct > 0) \
{ \
n_phdrr->__fileaddr += movement; \
}
HDRR * o_phdrr = (HDRR *)((byte *)old_base + OLD_SECTION_H (n).sh_offset);
HDRR * n_phdrr = (HDRR *)((byte *)new_base + NEW_SECTION_H (nn).sh_offset);
unsigned movement = new_offsets_shift;
MDEBUGADJUST (idnMax, cbDnOffset);
MDEBUGADJUST (ipdMax, cbPdOffset);
MDEBUGADJUST (isymMax, cbSymOffset);
MDEBUGADJUST (ioptMax, cbOptOffset);
MDEBUGADJUST (iauxMax, cbAuxOffset);
MDEBUGADJUST (issMax, cbSsOffset);
MDEBUGADJUST (issExtMax, cbSsExtOffset);
MDEBUGADJUST (ifdMax, cbFdOffset);
MDEBUGADJUST (crfd, cbRfdOffset);
MDEBUGADJUST (iextMax, cbExtOffset);
/* The Line Section, being possible off in a hole of the object,
requires special handling. */
if (n_phdrr->cbLine > 0)
{
if (o_phdrr->cbLineOffset > (OLD_SECTION_H (n).sh_offset
+ OLD_SECTION_H (n).sh_size))
{
/* line data is in a hole in elf. do special copy and adjust
for this ld mistake.
*/
n_phdrr->cbLineOffset += movement;
memcpy (n_phdrr->cbLineOffset + new_base,
o_phdrr->cbLineOffset + old_base, n_phdrr->cbLine);
}
else
{
/* somehow line data is in .mdebug as it is supposed to be. */
MDEBUGADJUST (cbLine, cbLineOffset);
}
}
}
/* If it is the symbol table, its st_shndx field needs to be patched. */
if (NEW_SECTION_H (nn).sh_type == SHT_SYMTAB
|| NEW_SECTION_H (nn).sh_type == SHT_DYNSYM)
{
Elf32_Shdr *spt = &NEW_SECTION_H (nn);
unsigned int num = spt->sh_size / spt->sh_entsize;
Elf32_Sym * sym = (Elf32_Sym *) (NEW_SECTION_H (nn).sh_offset
+ new_base);
for (; num--; sym++)
{
/* don't patch special section indices. */
if (sym->st_shndx == SHN_UNDEF
|| sym->st_shndx >= SHN_LORESERVE)
continue;
PATCH_INDEX (sym->st_shndx);
}
}
}
/* Close the files and make the new file executable. */
if (close (old_file))
fatal ("Can't close (%s): errno %d\n", old_name, errno);
if (close (new_file))
fatal ("Can't close (%s): errno %d\n", new_name, errno);
if (stat (new_name, &stat_buf) == -1)
fatal ("Can't stat (%s): errno %d\n", new_name, errno);
n = umask (777);
umask (n);
stat_buf.st_mode |= 0111 & ~n;
if (chmod (new_name, stat_buf.st_mode) == -1)
fatal ("Can't chmod (%s): errno %d\n", new_name, errno);
}

24
src/x11term.h
View file

@ -1,24 +0,0 @@
#include <X11/Xlib.h>
#include <X11/Xatom.h>
#include <X11/keysym.h>
#include <X11/cursorfont.h>
#include <X11/Xutil.h>
#include <X11/X10.h>
#define XMOUSEBUFSIZE 64
#ifndef sigmask
#define sigmask(no) (1L << ((no) - 1))
#endif
#define BLOCK_INPUT_DECLARE() int BLOCK_INPUT_mask
#ifdef SIGIO
#define BLOCK_INPUT() EMACS_SIGBLOCKX (SIGIO, BLOCK_INPUT_mask)
#define UNBLOCK_INPUT() \
do { int _dummy; EMACS_SIGSETMASK (BLOCK_INPUT_mask, _dummy); } while (0)
#else /* not SIGIO */
#define BLOCK_INPUT()
#define UNBLOCK_INPUT()
#endif /* SIGIO */
#define CLASS "Emacs" /* class id for GNU Emacs, used in .Xdefaults, etc. */

123
src/xscrollbar.h
View file

@ -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 */

950
src/xselect.c.old
View file

@ -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: <target, prop> */
{
Atom type;
int return_format;
unsigned long items, bytes_left;
unsigned char *data;
int result, i;
if (event.property == 0 /* 0 == NILP */
|| event.property == None)
return;
result = XGetWindowProperty (event.display, event.requestor,
event.property, 0L, 10000000L,
True, Xatom_pair, &type, &return_format,
&items, &bytes_left, &data);
if (result == Success && type == Xatom_pair)
for (i = items; i > 0; i--)
{
/* Convert each element of the list. */
}
(void) XSendEvent (x_current_display, evt.requestor, False,
0L, (XEvent *) &evt);
return;
}
else if (event.target == Xatom_timestamp) /* Send ownership timestamp */
{
if (! emacs_own_time)
abort ();
format = 32;
XChangeProperty (evt.display, evt.requestor, evt.property,
evt.target, format, PropModeReplace,
(unsigned char *) &emacs_own_time, 1);
return;
}
else if (event.target == Xatom_delete) /* Delete our selection. */
{
if (EQ (Qnil, selection_value))
abort ();
x_disown_selection (event.owner, event.selection, event.time);
/* Now return property of type NILP, length 0. */
XChangeProperty (event.display, event.requestor, event.property,
0, format, PropModeReplace, (unsigned char *) 0, 0);
return;
}
else if (event.target == Xatom_insert_selection)
{
Atom type;
int return_format;
unsigned long items, bytes_left;
unsigned char *data;
int result = XGetWindowProperty (event.display, event.requestor,
event.property, 0L, 10000000L,
True, Xatom_pair, &type, &return_format,
&items, &bytes_left, &data);
if (result == Success && type == Xatom_pair)
{
/* Convert the first atom to (a selection) to the target
indicated by the second atom. */
}
}
else if (event.target == Xatom_insert_property)
{
Atom type;
int return_format;
unsigned long items, bytes_left;
unsigned char *data;
int result = XGetWindowProperty (event.display, event.requestor,
event.property, 0L, 10000000L,
True, XA_STRING, &type, &return_format,
&items, &bytes_left, &data);
if (result == Success && type == XA_STRING && return_format == 8)
{
if (event.selection == Xatom_emacs_selection)
Vx_selection_value = make_string (data);
else if (event.selection == Xatom_emacs_secondary_selection)
Vx_secondary_selection_value = make_string (data);
else if (event.selection == Xatom_clipboard_selection)
Vx_clipboard_value = make_string (data);
else
abort ();
}
return;
}
else if ((event.target == Xatom_text
|| event.target == XA_STRING))
{
int size = XSTRING (selection_value)->size;
unsigned char *data = XSTRING (selection_value)->data;
if (EQ (Qnil, selection_value))
abort ();
/* Place data on requestor window's property. */
if (SELECTION_LENGTH (size, format)
<= MAX_SELECTION (x_current_display))
{
x_converting_selection = 1;
XChangeProperty (evt.display, evt.requestor, evt.property,
evt.target, format, PropModeReplace,
data, size);
if (x_selection_alloc_error)
{
x_selection_alloc_error = 0;
abort ();
}
x_converting_selection = 0;
}
else /* Send incrementally */
{
evt.target = Xatom_incremental;
incr_requestor = evt.requestor;
incr_property = evt.property;
x_converting_selection = 1;
/* Need to handle Alloc errors on these requests. */
XChangeProperty (evt.display, incr_requestor, incr_property,
Xatom_incremental, 32,
PropModeReplace,
(unsigned char *) &size, 1);
if (x_selection_alloc_error)
{
x_selection_alloc_error = 0;
x_converting_selection = 0;
abort ();
/* Now abort the send. */
}
incr_nbytes = size;
incr_value = data;
incr_ptr = data;
/* Ask for notification when requestor deletes property. */
XSelectInput (x_current_display, incr_requestor, PropertyChangeMask);
/* If we're sending incrementally, perhaps block here
until all sent? */
}
}
else
evt.property = None;
/* Don't do this if there was an Alloc error: abort the transfer
by sending None. */
(void) XSendEvent (x_current_display, evt.requestor, False,
0L, (XEvent *) &evt);
}
/* Send an increment of selection data in response to a PropertyNotify event.
The increment is placed in a property on the requestor's window.
When the requestor has processed the increment, it deletes the property,
which sends us another PropertyNotify event.
When there is no more data to send, we send a zero-length increment. */
void
x_send_incremental (event)
XPropertyEvent event;
{
if (incr_requestor
&& incr_requestor == event.window
&& incr_property == event.atom
&& event.state == PropertyDelete)
{
int format = 8;
int length = MAX_SELECTION (x_current_display);
int bytes_left = (incr_nbytes - (incr_ptr - incr_value));
if (length > bytes_left) /* Also sends 0 len when finished. */
length = bytes_left;
XChangeProperty (x_current_display, incr_requestor,
incr_property, XA_STRING, format,
PropModeAppend, incr_ptr, length);
if (x_selection_alloc_error)
{
x_selection_alloc_error = 0;
x_converting_selection = 0;
/* Abandon the transmission. */
abort ();
}
if (length > 0)
incr_ptr += length;
else
{ /* Everything's sent */
XSelectInput (x_current_display, incr_requestor, 0L);
incr_requestor = (Window) 0;
incr_property = (Atom) 0;
incr_nbytes = 0;
incr_value = (unsigned char *) 0;
incr_ptr = (unsigned char *) 0;
x_converting_selection = 0;
}
}
}
/* 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 */

324
tparam.c
View file

@ -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 <config.h>
#endif
#ifndef emacs
#if defined(HAVE_STRING_H) || defined(STDC_HEADERS)
#define bcopy(s, d, n) memcpy ((d), (s), (n))
#endif
#ifdef STDC_HEADERS
#include <stdlib.h>
#include <string.h>
#else
char *malloc ();
char *realloc ();
#endif
#endif /* not emacs */
#ifndef NULL
#define NULL (char *) 0
#endif
#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 */