mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2024-11-21 06:55:39 +00:00
Code Issues Releases Activity

Initial revision

Browse Source
This commit is contained in:
Joseph Arceneaux 1989-10-31 16:00:07 +00:00
parent 0d20f9a04e
commit a2535589a9
33 changed files with 7240 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

340
lib-src/emacstool.c Normal file
View File

@ -0,0 +1,340 @@
/*
*
* 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. */
*
*
* For Emacs in SunView/Sun-Windows: (supported by Sun Unix v3.2)
* Insert a notifier filter-function to convert all useful input
* to "key" sequences that emacs can understand. See: Emacstool(1).
*
* Author: Jeff Peck, Sun Microsystems, Inc. <peck@sun.com>
*
* Original Idea: Ian Batten
* Updated 15-Mar-88, Jeff Peck: set IN_EMACSTOOL, TERM, TERMCAP
*
*/
#include <suntool/sunview.h>
#include <suntool/tty.h>
#include <stdio.h>
#include <sys/file.h>
#define BUFFER_SIZE 128 /* Size of all the buffers */
/* define WANT_CAPS_LOCK to make f-key T1 (aka F1) behave as CapsLock */
#define WANT_CAPS_LOCK
#ifdef WANT_CAPS_LOCK
int caps_lock; /* toggle indicater for f-key T1 caps lock */
static char *Caps = "[CAPS] "; /* Caps Lock prefix string */
#define CAPS_LEN 7 /* strlen (Caps) */
#endif
static char *mouse_prefix = "\030\000"; /* C-x C-@ */
static int m_prefix_length = 2; /* mouse_prefix length */
static char *key_prefix = "\030*"; /* C-x * */
static int k_prefix_length = 2; /* key_prefix length */
static char *emacs_name = "emacs"; /* default run command */
static char buffer[BUFFER_SIZE]; /* send to ttysw_input */
static char *title = "Emacstool - "; /* initial title */
Frame frame; /* Base frame for system */
Tty ttysw; /* Where emacs is */
int font_width, font_height; /* For translating pixels to chars */
int console_fd = 0; /* for debugging: setenv DEBUGEMACSTOOL */
FILE *console; /* for debugging: setenv DEBUGEMACSTOOL */
Icon frame_icon;
/* make an icon_image for the default frame_icon */
static short default_image[258] =
{
#include <images/terminal.icon>
};
mpr_static(icon_image, 64, 64, 1, default_image);
/*
* Assign a value to a set of keys
*/
int
button_value (event)
Event *event;
{
int retval = 0;
/*
* Code up the current situation:
*
* 1 = MS_LEFT;
* 2 = MS_MIDDLE;
* 4 = MS_RIGHT;
* 8 = SHIFT;
* 16 = CONTROL;
* 32 = META;
* 64 = DOUBLE;
* 128 = UP;
*/
if (MS_LEFT == (event_id (event))) retval = 1;
if (MS_MIDDLE == (event_id (event))) retval = 2;
if (MS_RIGHT == (event_id (event))) retval = 4;
if (event_shift_is_down (event)) retval += 8;
if (event_ctrl_is_down (event)) retval += 16;
if (event_meta_is_down (event)) retval += 32;
if (event_is_up (event)) retval += 128;
return retval;
}
/*
* Variables to store the time of the previous mouse event that was
* sent to emacs.
*
* The theory is that to time double clicks while ignoreing UP buttons,
* we must keep track of the accumulated time.
*
* If someone writes a SUN-SET-INPUT-MASK for emacstool,
* That could be used to selectively disable UP events,
* and then this cruft wouldn't be necessary.
*/
static long prev_event_sec = 0;
static long prev_event_usec = 0;
/*
* Give the time difference in milliseconds, where one second
* is considered infinite.
*/
int
time_delta (now_sec, now_usec, prev_sec, prev_usec)
long now_sec, now_usec, prev_sec, prev_usec;
{
long sec_delta = now_sec - prev_sec;
long usec_delta = now_usec - prev_usec;
if (usec_delta < 0) { /* "borrow" a second */
usec_delta += 1000000;
--sec_delta;
}
if (sec_delta >= 10)
return (9999); /* Infinity */
else
return ((sec_delta * 1000) + (usec_delta / 1000));
}
/*
* Filter function to translate selected input events for emacs
* Mouse button events become ^X^@(button x-col y-line time-delta) .
* Function keys: ESC-*{c}{lrt} l,r,t for Left, Right, Top;
* {c} encodes the keynumber as a character [a-o]
*/
static Notify_value
input_event_filter_function (window, event, arg, type)
Window window;
Event *event;
Notify_arg arg;
Notify_event_type type;
{
struct timeval time_stamp;
if (console_fd) fprintf(console, "Event: %d\n", event_id(event));
/* UP L1 is the STOP key */
if (event_id(event) == WIN_STOP) {
ttysw_input(ttysw, "\007\007\007\007\007\007\007", 7);
return NOTIFY_IGNORED;
}
/* UP L5 & L7 is Expose & Open, let them pass to sunview */
if (event_id(event) == KEY_LEFT(5) || event_id(event) == KEY_LEFT(7))
if(event_is_up (event))
return notify_next_event_func (window, event, arg, type);
else return NOTIFY_IGNORED;
if (event_is_button (event)) { /* do Mouse Button events */
/* Commented out so that we send mouse up events too.
if (event_is_up (event))
return notify_next_event_func (window, event, arg, type);
*/
time_stamp = event_time (event);
ttysw_input (ttysw, mouse_prefix, m_prefix_length);
sprintf (buffer, "(%d %d %d %d)\015",
button_value (event),
event_x (event) / font_width,
event_y (event) / font_height,
time_delta (time_stamp.tv_sec, time_stamp.tv_usec,
prev_event_sec, prev_event_usec)
);
ttysw_input (ttysw, buffer, strlen(buffer));
prev_event_sec = time_stamp.tv_sec;
prev_event_usec = time_stamp.tv_usec;
return NOTIFY_IGNORED;
}
{ /* Do the function key events */
int d;
char c = (char) 0;
if ((event_is_key_left (event)) ?
((d = event_id(event) - KEY_LEFT(1) + 'a'), c='l') :
((event_is_key_right (event)) ?
((d = event_id(event) - KEY_RIGHT(1) + 'a'), c='r') :
((event_is_key_top (event)) ?
((d = event_id(event) - KEY_TOP(1) + 'a'), c='t') : 0)))
{
if (event_is_up(event)) return NOTIFY_IGNORED;
if (event_shift_is_down (event)) c = c - 32;
/* this will give a non-{lrt} for unshifted keys */
if (event_ctrl_is_down (event)) c = c - 64;
if (event_meta_is_down (event)) c = c + 128;
#ifdef WANT_CAPS_LOCK
/* set a toggle and relabel window so T1 can act like caps-lock */
if (event_id(event) == KEY_TOP(1))
{
/* make a frame label with and without CAPS */
strcpy (buffer, Caps);
title = &buffer[CAPS_LEN];
strncpy (title, (char *)window_get (frame, FRAME_LABEL),
BUFFER_SIZE - CAPS_LEN);
buffer[BUFFER_SIZE] = (char) 0;
if (strncmp (title, Caps, CAPS_LEN) == 0)
title += CAPS_LEN; /* already Caps */
caps_lock = (caps_lock ? 0 : CAPS_LEN);
window_set(frame, FRAME_LABEL, (title -= caps_lock), 0);
return NOTIFY_IGNORED;
}
#endif
ttysw_input (ttysw, key_prefix, k_prefix_length);
sprintf (buffer, "%c%c", d, c);
ttysw_input(ttysw, buffer, strlen(buffer));
return NOTIFY_IGNORED;
}
}
if ((event_is_ascii(event) || event_is_meta(event))
&& event_is_up(event)) return NOTIFY_IGNORED;
#ifdef WANT_CAPS_LOCK
/* shift alpha chars to upper case if toggle is set */
if ((caps_lock) && event_is_ascii(event)
&& (event_id(event) >= 'a') && (event_id(event) <= 'z'))
event_set_id(event, (event_id(event) - 32));
/* crufty, but it works for now. is there an UPCASE(event)? */
#endif
return notify_next_event_func (window, event, arg, type);
}
main (argc, argv)
int argc;
char **argv;
{
int error_code; /* Error codes */
if(getenv("DEBUGEMACSTOOL"))
console = fdopen (console_fd = open("/dev/console",O_WRONLY), "w");
/* do this first, so arglist can override it */
frame_icon = icon_create (ICON_LABEL, "Emacstool",
ICON_IMAGE, &icon_image,
0);
putenv("IN_EMACSTOOL=t"); /* notify subprocess that it is in emacstool */
if (putenv("TERM=sun") != 0) /* TTYSW will be a TERM=sun window */
{fprintf (stderr, "%s: Could not set TERM=sun, using `%s'\n",
argv[0], (char *)getenv("TERM")) ;};
/*
* If TERMCAP starts with a slash, it is the pathname of the
* termcap file, not an entry extracted from it, so KEEP it!
* Otherwise, it may not relate to the new TERM, so Nuke-It.
* If there is no TERMCAP environment variable, don't make one.
*/
{
char *termcap ; /* Current TERMCAP value */
termcap = (char *)getenv("TERMCAP") ;
if (termcap && (*termcap != '/'))
{
if (putenv("TERMCAP=") != 0)
{fprintf (stderr, "%s: Could not clear TERMCAP\n", argv[0]) ;} ;
} ;
} ;
/* find command to run as subprocess in window */
if (!(argv[0] = (char *)getenv("EMACSTOOL"))) /* Set emacs command name */
argv[0] = emacs_name;
for (argc = 1; argv[argc]; argc++) /* Use last one on line */
if(!(strcmp ("-rc", argv[argc]))) /* Override if -rc given */
{
int i = argc;
argv[argc--]=0; /* kill the -rc argument */
if (argv[i+1]) { /* move to agrv[0] and squeeze the rest */
argv[0]=argv[i+1];
for (; argv[i+2]; (argv[i]=argv[i+2],argv[++i]=0));
}
}
strcpy (buffer, title);
strncat (buffer, argv[0], /* append run command name */
(BUFFER_SIZE - (strlen (buffer)) - (strlen (argv[0]))) - 1);
/* Build a frame to run in */
frame = window_create ((Window)NULL, FRAME,
FRAME_LABEL, buffer,
FRAME_ICON, frame_icon,
FRAME_ARGC_PTR_ARGV, &argc, argv,
0);
/* Create a tty with emacs in it */
ttysw = window_create (frame, TTY,
TTY_QUIT_ON_CHILD_DEATH, TRUE,
TTY_BOLDSTYLE, 8,
TTY_ARGV, argv,
0);
window_set(ttysw,
WIN_CONSUME_PICK_EVENTS,
WIN_STOP,
WIN_MOUSE_BUTTONS, WIN_UP_EVENTS,
/* LOC_WINENTER, LOC_WINEXIT, LOC_MOVE, */
0,
WIN_CONSUME_KBD_EVENTS,
WIN_STOP,
WIN_ASCII_EVENTS,
WIN_LEFT_KEYS, WIN_TOP_KEYS, WIN_RIGHT_KEYS,
/* WIN_UP_ASCII_EVENTS, */
0,
0);
font_height = (int)window_get (ttysw, WIN_ROW_HEIGHT);
font_width = (int)window_get (ttysw, WIN_COLUMN_WIDTH);
/* Interpose my event function */
error_code = (int) notify_interpose_event_func
(ttysw, input_event_filter_function, NOTIFY_SAFE);
if (error_code != 0) /* Barf */
{
fprintf (stderr, "notify_interpose_event_func got %d.\n", error_code);
exit (1);
}
window_main_loop (frame); /* And away we go */
}

101
lisp/case-table.el Normal file
View File

@ -0,0 +1,101 @@
;; Functions for extending the character set and dealing with case tables.
;; Copyright (C) 1988 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 1, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;; Written by:
;; TN/ETX/TX/UMG Howard Gayle UUCP : seismo!enea!erix!howard
;; Telefonaktiebolaget L M Ericsson Phone: +46 8 719 55 65
;; Ericsson Telecom Telex: 14910 ERIC S
;; S-126 25 Stockholm FAX : +46 8 719 64 82
;; Sweden
(defun describe-buffer-case-table ()
"Describe the case table of the current buffer."
(interactive)
(let ((vector (make-vector 256 nil))
(case-table (current-case-table))
(i 0))
(while (< i 256)
(aset vector i
(cond ((/= ch (downcase ch))
(concat "uppercase, matches "
(text-char-description (downcase ch))))
((/= ch (upcase ch))
(concat "lowercase, matches "
(text-char-description (upcase ch))))
(t "case-invariant")))
(setq i (1+ i))))
(with-output-to-temp-buffer "*Help*"
(describe-vector vector)))
(defun invert-case (count)
"Change the case of the character just after point and move over it.
With arg, applies to that many chars.
Negative arg inverts characters before point but does not move."
(interactive "p")
(if (< count 0)
(progn (setq count (min (1- (point)) (- count)))
(forward-char (- count))))
(while (> count 0)
(let ((oc (following-char))) ; Old character.
(cond ((/= (upcase ch) ch)
(replace-char (upcase ch)))
((/= (downcase ch) ch)
(replace-char (downcase ch)))))
(forward-char 1)
(setq count (1- count))))
(defun set-case-syntax-delims (l r table)
"Make characters L and R a matching pair of non-case-converting delimiters.
Sets the entries for L and R in standard-case-table,
standard-syntax-table, and text-mode-syntax-table to indicate
left and right delimiters."
(aset (car table) l l)
(aset (car table) r r)
(modify-syntax-entry l (concat "(" (char-to-string r) " ")
(standard-syntax-table))
(modify-syntax-entry l (concat "(" (char-to-string r) " ")
text-mode-syntax-table)
(modify-syntax-entry r (concat ")" (char-to-string l) " ")
(standard-syntax-table))
(modify-syntax-entry r (concat ")" (char-to-string l) " ")
text-mode-syntax-table))
(defun set-case-syntax-pair (uc lc table)
"Make characters UC and LC a pair of inter-case-converting letters.
Sets the entries for characters UC and LC in
standard-case-table, standard-syntax-table, and
text-mode-syntax-table to indicate an (uppercase, lowercase)
pair of letters."
(aset (car table) uc lc)
(modify-syntax-entry lc "w " (standard-syntax-table))
(modify-syntax-entry lc "w " text-mode-syntax-table)
(modify-syntax-entry uc "w " (standard-syntax-table))
(modify-syntax-entry uc "w " text-mode-syntax-table))
(defun set-case-syntax (c syntax table)
"Make characters C case-invariant with syntax SYNTAX.
Sets the entries for character C in standard-case-table,
standard-syntax-table, and text-mode-syntax-table to indicate this.
SYNTAX should be \" \", \"w\", \".\" or \"_\"."
(aset (car table) c c)
(modify-syntax-entry c syntax (standard-syntax-table))
(modify-syntax-entry c syntax text-mode-syntax-table))
(provide 'case-table)

115
lisp/disp-table.el Normal file
View File

@ -0,0 +1,115 @@
;; Functions for dealing with char tables.
;; Copyright (C) 1987 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 1, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;; Written by Howard Gayle. See case-table.el for details.
(require 'case-table)
(defun rope-to-vector (rope)
(let* ((len (/ (length rope) 2))
(vector (make-vector len nil))
(i 0))
(while (< i len)
(aset vector i (rope-elt rope i))
(setq i (1+ i)))))
(defun describe-display-table (DT)
"Describe the display-table DT in a help buffer."
(with-output-to-temp-buffer "*Help*"
(princ "\nTruncation glyf: ")
(prin1 (aref dt 256))
(princ "\nWrap glyf: ")
(prin1 (aref dt 257))
(princ "\nEscape glyf: ")
(prin1 (aref dt 258))
(princ "\nCtrl glyf: ")
(prin1 (aref dt 259))
(princ "\nSelective display rope: ")
(prin1 (rope-to-vector (aref dt 260)))
(princ "\nCharacter display ropes:\n")
(let ((vector (make-vector 256 nil))
(i 0))
(while (< i 256)
(aset vector i
(if (stringp (aref dt i))
(rope-to-vector (aref dt i))
(aref dt i)))
(setq i (1+ i)))
(describe-vector vector))
(print-help-return-message)))
(defun describe-current-display-table ()
"Describe the display-table in use in the selected window and buffer."
(interactive)
(describe-display-table
(or (window-display-table (selected-window))
buffer-display-table
standard-display-table)))
(defun make-display-table ()
(make-vector 261 nil))
(defun standard-display-8bit (l h)
"Display characters in the range [L, H] literally."
(while (<= l h)
(if (and (>= l ?\ ) (< l 127))
(if standard-display-table (aset standard-display-table l nil))
(or standard-display-table
(setq standard-display-table (make-vector 261 nil)))
(aset standard-display-table l l))
(setq l (1+ l))))
(defun standard-display-ascii (c s)
"Display character C using string S."
(or standard-display-table
(setq standard-display-table (make-vector 261 nil)))
(aset standard-display-table c (apply 'make-rope (append s nil))))
(defun standard-display-g1 (c sc)
"Display character C as character SC in the g1 character set."
(or standard-display-table
(setq standard-display-table (make-vector 261 nil)))
(aset standard-display-table c
(make-rope (create-glyf (concat "\016" (char-to-string sc) "\017")))))
(defun standard-display-graphic (c gc)
"Display character C as character GC in graphics character set."
(or standard-display-table
(setq standard-display-table (make-vector 261 nil)))
(aset standard-display-table c
(make-rope (create-glyf (concat "\e(0" (char-to-string gc) "\e(B")))))
(defun standard-display-underline (c uc)
"Display character C as character UC plus underlining."
(or standard-display-table
(setq standard-display-table (make-vector 261 nil)))
(aset standard-display-table c
(make-rope (create-glyf (concat "\e[4m" (char-to-string uc) "\e[m")))))
(defun create-glyf (string)
(let ((i 256))
(while (and (< i 65536) (aref glyf-table i)
(not (string= (aref glyf-table i) string)))
(setq i (1+ i)))
(if (= i 65536)
(error "No free glyf codes remain"))
(aset glyf-table i string)))
(provide 'disp-table)

338
lisp/ehelp.el Normal file
View File

@ -0,0 +1,338 @@
;; Copyright (C) 1986 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 1, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
(require 'electric)
(provide 'ehelp)
(defvar electric-help-map ()
"Keymap defining commands available whilst scrolling
through a buffer in electric-help-mode")
(put 'electric-help-undefined 'suppress-keymap t)
(if electric-help-map
()
(let ((map (make-keymap)))
(fillarray map 'electric-help-undefined)
(define-key map (char-to-string meta-prefix-char) (copy-keymap map))
(define-key map (char-to-string help-char) 'electric-help-help)
(define-key map "?" 'electric-help-help)
(define-key map " " 'scroll-up)
(define-key map "\^?" 'scroll-down)
(define-key map "." 'beginning-of-buffer)
(define-key map "<" 'beginning-of-buffer)
(define-key map ">" 'end-of-buffer)
;(define-key map "\C-g" 'electric-help-exit)
(define-key map "q" 'electric-help-exit)
(define-key map "Q" 'electric-help-exit)
;;a better key than this?
(define-key map "r" 'electric-help-retain)
(setq electric-help-map map)))
(defun electric-help-mode ()
"with-electric-help temporarily places its buffer in this mode
\(On exit from with-electric-help, the buffer is put in default-major-mode)"
(setq buffer-read-only t)
(setq mode-name "Help")
(setq major-mode 'help)
(setq mode-line-buffer-identification '(" Help: %b"))
(use-local-map electric-help-map)
;; this is done below in with-electric-help
;(run-hooks 'electric-help-mode-hook)
)
(defun with-electric-help (thunk &optional buffer noerase)
"Arguments are THUNK &optional BUFFER NOERASE.
BUFFER defaults to \"*Help*\"
THUNK is a function of no arguments which is called to initialise
the contents of BUFFER. BUFFER will be erased before THUNK is called unless
NOERASE is non-nil. THUNK will be called with standard-output bound to
the buffer specified by BUFFER
After THUNK has been called, this function \"electrically\" pops up a window
in which BUFFER is displayed and allows the user to scroll through that buffer
in electric-help-mode.
When the user exits (with electric-help-exit, or otherwise) the help
buffer's window disappears (ie we use save-window-excursion)
BUFFER is put into default-major-mode (or fundamental-mode) when we exit"
(setq buffer (get-buffer-create (or buffer "*Help*")))
(let ((one (one-window-p t))
(two nil))
(save-window-excursion
(save-excursion
(if one (goto-char (window-start (selected-window))))
(let ((pop-up-windows t))
(pop-to-buffer buffer))
(unwind-protect
(progn
(save-excursion
(set-buffer buffer)
(electric-help-mode)
(setq buffer-read-only nil)
(or noerase (erase-buffer)))
(let ((standard-output buffer))
(if (funcall thunk)
()
(set-buffer buffer)
(set-buffer-modified-p nil)
(goto-char (point-min))
(if one (shrink-window-if-larger-than-buffer (selected-window)))))
(set-buffer buffer)
(run-hooks 'electric-help-mode-hook)
(setq two (electric-help-command-loop))
(cond ((eq (car-safe two) 'retain)
(setq two (vector (window-height (selected-window))
(window-start (selected-window))
(window-hscroll (selected-window))
(point))))
(t (setq two nil))))
(message "")
(set-buffer buffer)
(setq buffer-read-only nil)
(condition-case ()
(funcall (or default-major-mode 'fundamental-mode))
(error nil)))))
(if two
(let ((pop-up-windows t)
tem)
(pop-to-buffer buffer)
(setq tem (- (window-height (selected-window)) (elt two 0)))
(if (> tem 0) (shrink-window tem))
(set-window-start (selected-window) (elt two 1) t)
(set-window-hscroll (selected-window) (elt two 2))
(goto-char (elt two 3)))
;;>> Perhaps this shouldn't be done.
;; so that when we say "Press space to bury" we mean it
(replace-buffer-in-windows buffer)
;; must do this outside of save-window-excursion
(bury-buffer buffer))))
(defun electric-help-command-loop ()
(catch 'exit
(if (pos-visible-in-window-p (point-max))
(progn (message "<<< Press Space to bury the help buffer >>>")
(if (= (setq unread-command-char (read-char)) ?\ )
(progn (setq unread-command-char -1)
(throw 'exit t)))))
(let (up down both neither
(standard (and (eq (key-binding " ")
'scroll-up)
(eq (key-binding "\^?")
'scroll-down)
(eq (key-binding "Q")
'electric-help-exit)
(eq (key-binding "q")
'electric-help-exit))))
(Electric-command-loop
'exit
(function (lambda ()
(let ((min (pos-visible-in-window-p (point-min)))
(max (pos-visible-in-window-p (point-max))))
(cond ((and min max)
(cond (standard "Press Q to exit ")
(neither)
(t (setq neither (substitute-command-keys "Press \\[scroll-up] to exit ")))))
(min
(cond (standard "Press SPC to scroll, Q to exit ")
(up)
(t (setq up (substitute-command-keys "Press \\[scroll-up] to scroll; \\[electric-help-exit] to exit ")))))
(max
(cond (standard "Press DEL to scroll back, Q to exit ")
(down)
(t (setq down (substitute-command-keys "Press \\[scroll-down] to scroll back, \\[scroll-up] to exit ")))))
(t
(cond (standard "Press SPC to scroll, DEL to scroll back, Q to exit ")
(both)
(t (setq both (substitute-command-keys "Press \\[scroll-up] to scroll, \\[scroll-down] to scroll back, \\[electric-help-exit] to exit ")))))))))
t))))
;(defun electric-help-scroll-up (arg)
; ">>>Doc"
; (interactive "P")
; (if (and (null arg) (pos-visible-in-window-p (point-max)))
; (electric-help-exit)
; (scroll-up arg)))
(defun electric-help-exit ()
">>>Doc"
(interactive)
(throw 'exit t))
(defun electric-help-retain ()
"Exit electric-help, retaining the current window/buffer conifiguration.
\(The *Help* buffer will not be selected, but \\[switch-to-buffer-other-window] RET
will select it.)"
(interactive)
(throw 'exit '(retain)))
;(defun electric-help-undefined ()
; (interactive)
; (let* ((keys (this-command-keys))
; (n (length keys)))
; (if (or (= n 1)
; (and (= n 2)
; meta-flag
; (eq (aref keys 0) meta-prefix-char)))
; (setq unread-command-char last-input-char
; current-prefix-arg prefix-arg)
; ;;>>> I don't care.
; ;;>>> The emacs command-loop is too much pure pain to
; ;;>>> duplicate
; ))
; (throw 'exit t))
(defun electric-help-undefined ()
(interactive)
(error "%s is undefined -- Press %s to exit"
(mapconcat 'single-key-description (this-command-keys) " ")
(if (eq (key-binding "Q") 'electric-help-exit)
"Q"
(substitute-command-keys "\\[electric-help-exit]"))))
;>>> this needs to be hairified (recursive help, anybody?)
(defun electric-help-help ()
(interactive)
(if (and (eq (key-binding "Q") 'electric-help-exit)
(eq (key-binding " ") 'scroll-up)
(eq (key-binding "\^?") 'scroll-down))
(message "SPC scrolls forward, DEL scrolls back, Q exits and burys help buffer")
;; to give something for user to look at while slow substitute-cmd-keys
;; grinds away
(message "Help...")
(message "%s" (substitute-command-keys "\\[scroll-up] scrolls forward, \\[scroll-down] scrolls back, \\[electric-help-exit] exits.")))
(sit-for 2))
(defun electric-helpify (fun)
(let ((name "*Help*"))
(if (save-window-excursion
;; kludge-o-rama
(let* ((p (symbol-function 'print-help-return-message))
(b (get-buffer name))
(m (buffer-modified-p b)))
(and b (not (get-buffer-window b))
(setq b nil))
(unwind-protect
(progn
(message "%s..." (capitalize (symbol-name fun)))
;; with-output-to-temp-buffer marks the buffer as unmodified.
;; kludging excessively and relying on that as some sort
;; of indication leads to the following abomination...
;;>> This would be doable without such icky kludges if either
;;>> (a) there were a function to read the interactive
;;>> args for a command and return a list of those args.
;;>> (To which one would then just apply the command)
;;>> (The only problem with this is that interactive-p
;;>> would break, but that is such a misfeature in
;;>> any case that I don't care)
;;>> It is easy to do this for emacs-lisp functions;
;;>> the only problem is getting the interactive spec
;;>> for subrs
;;>> (b) there were a function which returned a
;;>> modification-tick for a buffer. One could tell
;;>> whether a buffer had changed by whether the
;;>> modification-tick were different.
;;>> (Presumably there would have to be a way to either
;;>> restore the tick to some previous value, or to
;;>> suspend updating of the tick in order to allow
;;>> things like momentary-string-display)
(and b
(save-excursion
(set-buffer b)
(set-buffer-modified-p t)))
(fset 'print-help-return-message 'ignore)
(call-interactively fun)
(and (get-buffer name)
(get-buffer-window (get-buffer name))
(or (not b)
(not (eq b (get-buffer name)))
(not (buffer-modified-p b)))))
(fset 'print-help-return-message p)
(and b (buffer-name b)
(save-excursion
(set-buffer b)
(set-buffer-modified-p m))))))
(with-electric-help 'ignore name t))))
(defun electric-describe-key ()
(interactive)
(electric-helpify 'describe-key))
(defun electric-describe-mode ()
(interactive)
(electric-helpify 'describe-mode))
(defun electric-view-lossage ()
(interactive)
(electric-helpify 'view-lossage))
;(defun electric-help-for-help ()
; "See help-for-help"
; (interactive)
; )
(defun electric-describe-function ()
(interactive)
(electric-helpify 'describe-function))
(defun electric-describe-variable ()
(interactive)
(electric-helpify 'describe-variable))
(defun electric-describe-bindings ()
(interactive)
(electric-helpify 'describe-bindings))
(defun electric-describe-syntax ()
(interactive)
(electric-helpify 'describe-syntax))
(defun electric-command-apropos ()
(interactive)
(electric-helpify 'command-apropos))
;(define-key help-map "a" 'electric-command-apropos)
;;;; ehelp-map
(defvar ehelp-map ())
(if ehelp-map
nil
(let ((map (copy-keymap help-map)))
(substitute-key-definition 'describe-key 'electric-describe-key map)
(substitute-key-definition 'describe-mode 'electric-describe-mode map)
(substitute-key-definition 'view-lossage 'electric-view-lossage map)
(substitute-key-definition 'describe-function 'electric-describe-function map)
(substitute-key-definition 'describe-variable 'electric-describe-variable map)
(substitute-key-definition 'describe-bindings 'electric-describe-bindings map)
(substitute-key-definition 'describe-syntax 'electric-describe-syntax map)
(setq ehelp-map map)
(fset 'ehelp-command map)))
;; Do (define-key global-map "\C-h" 'ehelp-command) if you want to win

147
lisp/emacs-lisp/helper.el Normal file
View File

@ -0,0 +1,147 @@
;; helper - utility help package for modes which want to provide help
;; without relinquishing control, e.g. `electric' modes.
;; Copyright (C) 1985 Free Software Foundation, Inc.
;; Principal author K. Shane Hartman
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 1, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
(provide 'helper) ; hey, here's a helping hand.
;; Bind this to a string for <blank> in "... Other keys <blank>".
;; Helper-help uses this to construct help string when scrolling.
;; Defaults to "return"
(defvar Helper-return-blurb nil)
;; Keymap implementation doesn't work too well for non-standard loops.
;; But define it anyway for those who can use it. Non-standard loops
;; will probably have to use Helper-help. You can't autoload the
;; keymap either.
(defvar Helper-help-map nil)
(if Helper-help-map
nil
(setq Helper-help-map (make-keymap))
;(fillarray Helper-help-map 'undefined)
(define-key Helper-help-map "m" 'Helper-describe-mode)
(define-key Helper-help-map "b" 'Helper-describe-bindings)
(define-key Helper-help-map "c" 'Helper-describe-key-briefly)
(define-key Helper-help-map "k" 'Helper-describe-key)
;(define-key Helper-help-map "f" 'Helper-describe-function)
;(define-key Helper-help-map "v" 'Helper-describe-variable)
(define-key Helper-help-map "?" 'Helper-help-options)
(define-key Helper-help-map (char-to-string help-char) 'Helper-help-options)
(fset 'Helper-help-map Helper-help-map))
(defun Helper-help-scroller ()
(let ((blurb (or (and (boundp 'Helper-return-blurb)
Helper-return-blurb)
"return")))
(save-window-excursion
(goto-char (window-start (selected-window)))
(if (get-buffer-window "*Help*")
(pop-to-buffer "*Help*")
(switch-to-buffer "*Help*"))
(goto-char (point-min))
(let ((continue t) state)
(while continue
(setq state (+ (* 2 (if (pos-visible-in-window-p (point-max)) 1 0))
(if (pos-visible-in-window-p (point-min)) 1 0)))
(message
(nth state
'("Space forward, Delete back. Other keys %s"
"Space scrolls forward. Other keys %s"
"Delete scrolls back. Other keys %s"
"Type anything to %s"))
blurb)
(setq continue (read-char))
(cond ((and (memq continue '(?\ ?\C-v)) (< state 2))
(scroll-up))
((= continue ?\C-l)
(recenter))
((and (= continue ?\177) (zerop (% state 2)))
(scroll-down))
(t (setq continue nil))))))))
(defun Helper-help-options ()
"Describe help options."
(interactive)
(message "c (key briefly), m (mode), k (key), b (bindings)")
;(message "c (key briefly), m (mode), k (key), v (variable), f (function)")
(sit-for 4))
(defun Helper-describe-key-briefly (key)
"Briefly describe binding of KEYS."
(interactive "kDescribe key briefly: ")
(describe-key-briefly key)
(sit-for 4))
(defun Helper-describe-key (key)
"Describe binding of KEYS."
(interactive "kDescribe key: ")
(save-window-excursion (describe-key key))
(Helper-help-scroller))
(defun Helper-describe-function ()
"Describe a function. Name read interactively."
(interactive)
(save-window-excursion (call-interactively 'describe-function))
(Helper-help-scroller))
(defun Helper-describe-variable ()
"Describe a variable. Name read interactively."
(interactive)
(save-window-excursion (call-interactively 'describe-variable))
(Helper-help-scroller))
(defun Helper-describe-mode ()
"Describe the current mode."
(interactive)
(let ((name mode-name)
(documentation (documentation major-mode)))
(save-excursion
(set-buffer (get-buffer-create "*Help*"))
(erase-buffer)
(insert name " Mode\n" documentation)))
(Helper-help-scroller))
(defun Helper-describe-bindings ()
"Describe local key bindings of current mode."
(interactive)
(message "Making binding list...")
(save-window-excursion (describe-bindings))
(Helper-help-scroller))
(defun Helper-help ()
"Provide help for current mode."
(interactive)
(let ((continue t) c)
(while continue
(message "Help (Type ? for further options)")
(setq c (char-to-string (downcase (read-char))))
(setq c (lookup-key Helper-help-map c))
(cond ((eq c 'Helper-help-options)
(Helper-help-options))
((commandp c)
(call-interactively c)
(setq continue nil))
(t
(ding)
(setq continue nil))))))

272
lisp/emulation/mlconvert.el Normal file
View File

@ -0,0 +1,272 @@
;; Convert buffer of Mocklisp code to real lisp.
;; Copyright (C) 1985 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 1, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
(defun convert-mocklisp-buffer ()
"Convert buffer of Mocklisp code to real Lisp that GNU Emacs can run."
(interactive)
(emacs-lisp-mode)
(set-syntax-table (copy-sequence (syntax-table)))
(modify-syntax-entry ?\| "w")
(message "Converting mocklisp (ugh!)...")
(goto-char (point-min))
(fix-mlisp-syntax)
;; Emulation of mocklisp is accurate only within a mocklisp-function
;; so turn any non-function into a defun and then call it.
(goto-char (point-min))
(condition-case ignore
(while t
(let ((opt (point))
(form (read (current-buffer))))
(and (listp form)
(not (eq (car form) 'defun))
(progn (insert "))\n\n(ml-foo)\n\n")
(save-excursion
(goto-char opt)
(skip-chars-forward "\n")
(insert "(defun (ml-foo \n "))))))
(end-of-file nil))
(goto-char (point-min))
(insert ";;; GNU Emacs code converted from Mocklisp\n")
(insert "(require 'mlsupport)\n\n")
(fix-mlisp-symbols)
(goto-char (point-min))
(message "Converting mocklisp...done"))
(defun fix-mlisp-syntax ()
(while (re-search-forward "['\"]" nil t)
(if (= (preceding-char) ?\")
(progn (forward-char -1)
(forward-sexp 1))
(delete-char -1)
(insert "?")
(if (or (= (following-char) ?\\) (= (following-char) ?^))
(forward-char 1)
(if (looking-at "[^a-zA-Z]")
(insert ?\\)))
(forward-char 1)
(delete-char 1))))
(defun fix-mlisp-symbols ()
(while (progn
(skip-chars-forward " \t\n()")
(not (eobp)))
(cond ((or (= (following-char) ?\?)
(= (following-char) ?\"))
(forward-sexp 1))
((= (following-char) ?\;)
(forward-line 1))
(t
(let ((start (point)) prop)
(forward-sexp 1)
(setq prop (get (intern-soft (buffer-substring start (point)))
'mocklisp))
(cond ((null prop))
((stringp prop)
(delete-region start (point))
(insert prop))
(t
(save-excursion
(goto-char start)
(funcall prop)))))))))
(defun ml-expansion (ml-name lisp-string)
(put ml-name 'mocklisp lisp-string))
(ml-expansion 'defun "ml-defun")
(ml-expansion 'if "ml-if")
(ml-expansion 'setq '(lambda ()
(if (looking-at "setq[ \t\n]+buffer-modified-p")
(replace-match "set-buffer-modified-p"))))
(ml-expansion 'while '(lambda ()
(let ((end (progn (forward-sexp 2) (point-marker)))
(start (progn (forward-sexp -1) (point))))
(let ((cond (buffer-substring start end)))
(cond ((equal cond "1")
(delete-region (point) end)
(insert "t"))
(t
(insert "(not (zerop ")
(goto-char end)
(insert "))")))
(set-marker end nil)
(goto-char start)))))
(ml-expansion 'arg "ml-arg")
(ml-expansion 'nargs "ml-nargs")
(ml-expansion 'interactive "ml-interactive")
(ml-expansion 'message "ml-message")
(ml-expansion 'print "ml-print")
(ml-expansion 'set "ml-set")
(ml-expansion 'set-default "ml-set-default")
(ml-expansion 'provide-prefix-argument "ml-provide-prefix-argument")
(ml-expansion 'prefix-argument-loop "ml-prefix-argument-loop")
(ml-expansion 'prefix-argument "ml-prefix-arg")
(ml-expansion 'use-local-map "ml-use-local-map")
(ml-expansion 'use-global-map "ml-use-global-map")
(ml-expansion 'modify-syntax-entry "ml-modify-syntax-entry")
(ml-expansion 'error-message "error")
(ml-expansion 'dot "point-marker")
(ml-expansion 'mark "mark-marker")
(ml-expansion 'beginning-of-file "beginning-of-buffer")
(ml-expansion 'end-of-file "end-of-buffer")
(ml-expansion 'exchange-dot-and-mark "exchange-point-and-mark")
(ml-expansion 'set-mark "set-mark-command")
(ml-expansion 'argument-prefix "universal-arg")
(ml-expansion 'previous-page "ml-previous-page")
(ml-expansion 'next-page "ml-next-page")
(ml-expansion 'next-window "ml-next-window")
(ml-expansion 'previous-window "ml-previous-window")
(ml-expansion 'newline "ml-newline")
(ml-expansion 'next-line "ml-next-line")
(ml-expansion 'previous-line "ml-previous-line")
(ml-expansion 'self-insert "self-insert-command")
(ml-expansion 'meta-digit "digit-argument")
(ml-expansion 'meta-minus "negative-argument")
(ml-expansion 'newline-and-indent "ml-newline-and-indent")
(ml-expansion 'yank-from-killbuffer "yank")
(ml-expansion 'yank-buffer "insert-buffer")
(ml-expansion 'copy-region "copy-region-as-kill")
(ml-expansion 'delete-white-space "delete-horizontal-space")
(ml-expansion 'widen-region "widen")
(ml-expansion 'forward-word '(lambda ()
(if (looking-at "forward-word[ \t\n]*)")
(replace-match "forward-word 1)"))))
(ml-expansion 'backward-word '(lambda ()
(if (looking-at "backward-word[ \t\n]*)")
(replace-match "backward-word 1)"))))
(ml-expansion 'forward-paren "forward-list")
(ml-expansion 'backward-paren "backward-list")
(ml-expansion 'search-reverse "ml-search-backward")
(ml-expansion 're-search-reverse "ml-re-search-backward")
(ml-expansion 'search-forward "ml-search-forward")
(ml-expansion 're-search-forward "ml-re-search-forward")
(ml-expansion 'quote "regexp-quote")
(ml-expansion 're-query-replace "query-replace-regexp")
(ml-expansion 're-replace-string "replace-regexp")
; forward-paren-bl, backward-paren-bl
(ml-expansion 'get-tty-character "read-char")
(ml-expansion 'get-tty-input "read-input")
(ml-expansion 'get-tty-string "read-string")
(ml-expansion 'get-tty-buffer "read-buffer")
(ml-expansion 'get-tty-command "read-command")
(ml-expansion 'get-tty-variable "read-variable")
(ml-expansion 'get-tty-no-blanks-input "read-no-blanks-input")
(ml-expansion 'get-tty-key "read-key")
(ml-expansion 'c= "char-equal")
(ml-expansion 'goto-character "goto-char")
(ml-expansion 'substr "ml-substr")
(ml-expansion 'variable-apropos "apropos")
(ml-expansion 'execute-mlisp-buffer "eval-current-buffer")
(ml-expansion 'execute-mlisp-file "load")
(ml-expansion 'visit-file "find-file")
(ml-expansion 'read-file "find-file")
(ml-expansion 'write-modified-files "save-some-buffers")
(ml-expansion 'backup-before-writing "make-backup-files")
(ml-expansion 'write-file-exit "save-buffers-kill-emacs")
(ml-expansion 'write-named-file "write-file")
(ml-expansion 'change-file-name "set-visited-file-name")
(ml-expansion 'change-buffer-name "rename-buffer")
(ml-expansion 'buffer-exists "get-buffer")
(ml-expansion 'delete-buffer "kill-buffer")
(ml-expansion 'unlink-file "delete-file")
(ml-expansion 'unlink-checkpoint-files "delete-auto-save-files")
(ml-expansion 'file-exists "file-exists-p")
(ml-expansion 'write-current-file "save-buffer")
(ml-expansion 'change-directory "cd")
(ml-expansion 'temp-use-buffer "set-buffer")
(ml-expansion 'fast-filter-region "filter-region")
(ml-expansion 'pending-input "input-pending-p")
(ml-expansion 'execute-keyboard-macro "call-last-kbd-macro")
(ml-expansion 'start-remembering "start-kbd-macro")
(ml-expansion 'end-remembering "end-kbd-macro")
(ml-expansion 'define-keyboard-macro "name-last-kbd-macro")
(ml-expansion 'define-string-macro "ml-define-string-macro")
(ml-expansion 'current-column "ml-current-column")
(ml-expansion 'current-indent "ml-current-indent")
(ml-expansion 'insert-character "insert")
(ml-expansion 'users-login-name "user-login-name")
(ml-expansion 'users-full-name "user-full-name")
(ml-expansion 'current-time "current-time-string")
(ml-expansion 'current-numeric-time "current-numeric-time-you-lose")
(ml-expansion 'current-buffer-name "buffer-name")
(ml-expansion 'current-file-name "buffer-file-name")
(ml-expansion 'local-binding-of "local-key-binding")
(ml-expansion 'global-binding-of "global-key-binding")
;defproc (ProcedureType, "procedure-type");
(ml-expansion 'remove-key-binding "global-unset-key")
(ml-expansion 'remove-binding "global-unset-key")
(ml-expansion 'remove-local-binding "local-unset-key")
(ml-expansion 'remove-all-local-bindings "use-local-map nil")
(ml-expansion 'autoload "ml-autoload")
(ml-expansion 'checkpoint-frequency "auto-save-interval")
(ml-expansion 'mode-string "mode-name")
(ml-expansion 'right-margin "fill-column")
(ml-expansion 'tab-size "tab-width")
(ml-expansion 'default-right-margin "default-fill-column")
(ml-expansion 'default-tab-size "default-tab-width")
(ml-expansion 'buffer-is-modified "(buffer-modified-p)")
(ml-expansion 'file-modified-time "you-lose-on-file-modified-time")
(ml-expansion 'needs-checkpointing "you-lose-on-needs-checkpointing")
(ml-expansion 'lines-on-screen "set-screen-height")
(ml-expansion 'columns-on-screen "set-screen-width")
(ml-expansion 'dumped-emacs "t")
(ml-expansion 'buffer-size "ml-buffer-size")
(ml-expansion 'dot-is-visible "pos-visible-in-window-p")
(ml-expansion 'track-eol-on-^N-^P "track-eol")
(ml-expansion 'ctlchar-with-^ "ctl-arrow")
(ml-expansion 'help-on-command-completion-error "completion-auto-help")
(ml-expansion 'dump-stack-trace "backtrace")
(ml-expansion 'pause-emacs "suspend-emacs")
(ml-expansion 'compile-it "compile")
(ml-expansion '!= "/=")
(ml-expansion '& "logand")
(ml-expansion '| "logior")
(ml-expansion '^ "logxor")
(ml-expansion '! "ml-not")
(ml-expansion '<< "lsh")
;Variable pause-writes-files

53
lisp/float-sup.el Normal file
View File

@ -0,0 +1,53 @@
;; Basic editing commands for Emacs
;; Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 1, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;; Provide a meaningful error message if we are running on
;; bare (non-float) emacs.
;; Can't test for 'floatp since that may be defined by float-imitation
;; packages like float.el in this very directory.
(if (fboundp 'atan)
nil
(error "Floating point was disabled at compile time"))
;; provide an easy hook to tell if we are running with floats or not.
(provide 'lisp-float-type)
;; define pi and e via math-lib calls. (much less prone to killer typos.)
(defconst pi (* 4 (atan 1)) "The value of Pi (3.1415926...)")
(defconst e (exp 1) "The value of e (2.7182818...)")
;; Careful when editing this file ... typos here will be hard to spot.
;; (defconst pi 3.14159265358979323846264338327
;; "The value of Pi (3.14159265358979323846264338327...)")
(defconst degrees-to-radians (/ pi 180.0)
"Degrees to radian conversion constant")
(defconst radians-to-degrees (/ 180.0 pi)
"Radian to degree conversion constant")
;; these expand to a single multiply by a float
;; when byte compiled
(defmacro degrees-to-radians (x)
"Convert ARG from degrees to radians."
(list '* (/ pi 180.0) x))
(defmacro radians-to-degrees (x)
"Convert ARG from radians to degrees."
(list '* (/ 180.0 pi) x))

102
lisp/gosmacs.el Normal file
View File

@ -0,0 +1,102 @@
;; Rebindings to imitate Gosmacs.
;; 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.
(defvar non-gosmacs-binding-alist nil)
(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 is an alist whose elements are (KEY DEFINITION).
Value is a similar alist whose elements describe the same KEYs
but each with the old definition that was replaced,"
(let (old)
(while bindings
(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))

668
lisp/hexl.el Normal file
View File

@ -0,0 +1,668 @@
;; -*-Emacs-Lisp-*-
;; hexl-mode -- Edit a file in a hex dump format.
;; Copyright (C) 1989 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 1, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;;
;; By: Keith Gabryelski (ag@wheaties.ai.mit.edu)
;;
;; This may be useful in your .emacs:
;;
;; (autoload 'hexl-find-file "hexl"
;; "Edit file FILENAME in hexl-mode." t)
;;
;; (define-key global-map "\C-c\C-h" 'hexl-find-file)
;;
;; NOTE: Remember to change HEXL-PROGRAM or HEXL-OPTIONS if needed.
;;
;; Currently hexl only supports big endian hex output with 16 bit
;; grouping.
;;
;; -iso in `hexl-options' will allow iso characters to display in the
;; ASCII region of the screen (if your emacs supports this) instead of
;; changing them to dots.
;;
;; vars here
;;
(defvar hexl-program "hexl"
"The program that will hexlify and de-hexlify its stdin. hexl-program
will always be concated with hexl-options and "-de" when dehexlfying a
buffer.")
(defvar hexl-iso ""
"If your emacs can handle ISO characters, this should be set to
\"-iso\" otherwise it should be \"\".")
(defvar hexl-options (format "-hex %s" hexl-iso)
"Options to hexl-program that suit your needs.")
(defvar hexlify-command (format "%s %s" hexl-program hexl-options)
"The command to use to hexlify a buffer. It is the concatination of
`hexl-program' and `hexl-options'.")
(defvar dehexlify-command (format "%s -de %s" hexl-program hexl-options)
"The command to use to unhexlify a buffer. It is the concatination of
`hexl-program', the option \"-de\", and `hexl-options'.")
(defvar hexl-max-address 0
"Maximum offset into hexl buffer.")
(defvar hexl-mode-map nil)
;; routines
(defun hexl-mode (&optional arg)
"\\<hexl-mode-map>
A major mode for editting binary files in hex dump format.
This function automatically converts a buffer into the hexl format
using the function `hexlify-buffer'.
Each line in the buffer has an `address' (displayed in hexadecimal)
representing the offset into the file that the characters on this line
are at and 16 characters from the file (displayed as hexadecimal
values grouped every 16 bits) and as their ASCII values.
If any of the characters (displayed as ASCII characters) are
unprintable (control or meta characters) they will be replaced as
periods.
If hexl-mode is invoked with an argument the buffer is assumed to be
in hexl-format.
A sample format:
HEX ADDR: 0001 0203 0405 0607 0809 0a0b 0c0d 0e0f ASCII-TEXT
-------- ---- ---- ---- ---- ---- ---- ---- ---- ----------------
00000000: 5468 6973 2069 7320 6865 786c 2d6d 6f64 This is hexl-mod
00000010: 652e 2020 4561 6368 206c 696e 6520 7265 e. Each line re
00000020: 7072 6573 656e 7473 2031 3620 6279 7465 presents 16 byte
00000030: 7320 6173 2068 6578 6164 6563 696d 616c s as hexadecimal
00000040: 2041 5343 4949 0a61 6e64 2070 7269 6e74 ASCII.and print
00000050: 6162 6c65 2041 5343 4949 2063 6861 7261 able ASCII chara
00000060: 6374 6572 732e 2020 416e 7920 636f 6e74 cters. Any cont
00000070: 726f 6c20 6f72 206e 6f6e 2d41 5343 4949 rol or non-ASCII
00000080: 2063 6861 7261 6374 6572 730a 6172 6520 characters.are
00000090: 6469 7370 6c61 7965 6420 6173 2070 6572 displayed as per
000000a0: 696f 6473 2069 6e20 7468 6520 7072 696e iods in the prin
000000b0: 7461 626c 6520 6368 6172 6163 7465 7220 table character
000000c0: 7265 6769 6f6e 2e0a region..
Movement is as simple as movement in a normal emacs text buffer. Most
cursor movement bindings are the same (ie. Use \\[hexl-backward-char], \\[hexl-forward-char], \\[hexl-next-line], and \\[hexl-previous-line]
to move the cursor left, right, down, and up).
Advanced cursor movement commands (ala \\[hexl-beginning-of-line], \\[hexl-end-of-line], \\[hexl-beginning-of-buffer], and \\[hexl-end-of-buffer]) are
also supported.
There are several ways to change text in hexl mode:
ASCII characters (character between space (0x20) and tilde (0x7E)) are
bound to self-insert so you can simply type the character and it will
insert itself (actually overstrike) into the buffer.
\\[hexl-quoted-insert] followed by another keystroke allows you to insert the key even if
it isn't bound to self-insert. An octal number can be supplied in place
of another key to insert the octal number's ASCII representation.
\\[hexl-insert-hex-char] will insert a given hexadecimal value (if it is between 0 and 0xFF)
into the buffer at the current point.
\\[hexl-insert-octal-char] will insert a given octal value (if it is between 0 and 0377)
into the buffer at the current point.
\\[hexl-insert-decimal-char] will insert a given decimal value (if it is between 0 and 255)
into the buffer at the current point.
\\[hexl-save-buffer] will save the buffer in is binary format.
\\[hexl-mode-exit] will exit hexl-mode.
Note: \\[write-file] will write the file out in HEXL FORMAT.
You can use \\[hexl-find-file] to visit a file in hexl-mode.
\\[describe-bindings] for advanced commands."
(interactive "p")
(if (eq major-mode 'hexl-mode)
(error "You are already in hexl mode.")
(kill-all-local-variables)
(make-local-variable 'hexl-mode-old-local-map)
(setq hexl-mode-old-local-map (current-local-map))
(use-local-map hexl-mode-map)
(make-local-variable 'hexl-mode-old-mode-name)
(setq hexl-mode-old-mode-name mode-name)
(setq mode-name "Hexl")
(make-local-variable 'hexl-mode-old-major-mode)
(setq hexl-mode-old-major-mode major-mode)
(setq major-mode 'hexl-mode)
(let ((modified (buffer-modified-p))
(read-only buffer-read-only)
(original-point (1- (point))))
(if (not (or (eq arg 1) (not arg)))
;; if no argument then we guess at hexl-max-address
(setq hexl-max-address (+ (* (/ (1- (buffer-size)) 68) 16) 15))
(setq buffer-read-only nil)
(setq hexl-max-address (1- (buffer-size)))
(hexlify-buffer)
(set-buffer-modified-p modified)
(setq buffer-read-only read-only)
(hexl-goto-address original-point)))))
(defun hexl-save-buffer ()
"Save a hexl format buffer as binary in visited file if modified."
(interactive)
(set-buffer-modified-p (if (buffer-modified-p)
(save-excursion
(let ((buf (generate-new-buffer " hexl"))
(name (buffer-name))
(file-name (buffer-file-name))
(start (point-min))
(end (point-max))
modified)
(set-buffer buf)
(insert-buffer-substring name start end)
(set-buffer name)
(dehexlify-buffer)
(save-buffer)
(setq modified (buffer-modified-p))
(delete-region (point-min) (point-max))
(insert-buffer-substring buf start end)
(kill-buffer buf)
modified))
(message "(No changes need to be saved)")
nil)))
(defun hexl-find-file (filename)
"Edit file FILENAME in hexl-mode.
Switch to a buffer visiting file FILENAME, creating one in none exists."
(interactive "fFilename: ")
(find-file filename)
(if (not (eq major-mode 'hexl-mode))
(hexl-mode)))
(defun hexl-mode-exit (&optional arg)
"Exit hexl-mode returning to previous mode.
With arg, don't unhexlify buffer."
(interactive "p")
(if (or (eq arg 1) (not arg))
(let ((modified (buffer-modified-p))
(read-only buffer-read-only)
(original-point (1+ (hexl-current-address))))
(setq buffer-read-only nil)
(dehexlify-buffer)
(set-buffer-modified-p modified)
(setq buffer-read-only read-only)
(goto-char original-point)))
(setq mode-name hexl-mode-old-mode-name)
(use-local-map hexl-mode-old-local-map)
(setq major-mode hexl-mode-old-major-mode)
;; Kludge to update mode-line
(switch-to-buffer (current-buffer))
)
(defun hexl-current-address ()
"Return current hexl-address."
(interactive)
(let ((current-column (- (% (point) 68) 11))
(hexl-address 0))
(setq hexl-address (+ (* (/ (point) 68) 16)
(/ (- current-column (/ current-column 5)) 2)))
hexl-address))
(defun hexl-address-to-marker (address)
"Return marker for ADDRESS."
(interactive "nAddress: ")
(+ (* (/ address 16) 68) 11 (/ (* (% address 16) 5) 2)))
(defun hexl-goto-address (address)
"Goto hexl-mode (decimal) address ADDRESS.
Signal error if ADDRESS out of range."
(interactive "nAddress: ")
(if (or (< address 0) (> address hexl-max-address))
(error "Out of hexl region."))
(goto-char (hexl-address-to-marker address)))
(defun hexl-goto-hex-address (hex-address)
"Goto hexl-mode address (hex string) HEX-ADDRESS.
Signal error if HEX-ADDRESS is out of range."
(interactive "sHex Address: ")
(hexl-goto-address (hexl-hex-string-to-integer hex-address)))
(defun hexl-hex-string-to-integer (hex-string)
"Return decimal integer for HEX-STRING."
(interactive "sHex number: ")
(let ((hex-num 0))
(while (not (equal hex-string ""))
(setq hex-num (+ (* hex-num 16)
(hexl-hex-char-to-integer (string-to-char hex-string))))
(setq hex-string (substring hex-string 1)))
hex-num))
(defun hexl-octal-string-to-integer (octal-string)
"Return decimal integer for OCTAL-STRING."
(interactive "sOctal number: ")
(let ((oct-num 0))
(while (not (equal octal-string ""))
(setq oct-num (+ (* oct-num 8)
(hexl-oct-char-to-integer
(string-to-char octal-string))))
(setq octal-string (substring octal-string 1)))
oct-num))
;; move point functions
(defun hexl-backward-char (arg)
"Move to left ARG bytes (right if ARG negative) in hexl-mode."
(interactive "p")
(hexl-goto-address (- (hexl-current-address) arg)))
(defun hexl-forward-char (arg)
"Move right ARG bytes (left if ARG negative) in hexl-mode."
(interactive "p")
(hexl-goto-address (+ (hexl-current-address) arg)))
(defun hexl-backward-short (arg)
"Move to left ARG shorts (right if ARG negative) in hexl-mode."
(interactive "p")
(hexl-goto-address (let ((address (hexl-current-address)))
(if (< arg 0)
(progn
(setq arg (- arg))
(while (> arg 0)
(if (not (equal address (logior address 3)))
(if (> address hexl-max-address)
(progn
(message "End of buffer.")
(setq address hexl-max-address))
(setq address (logior address 3)))
(if (> address hexl-max-address)
(progn
(message "End of buffer.")
(setq address hexl-max-address))
(setq address (+ address 4))))
(setq arg (1- arg)))
(if (> address hexl-max-address)
(progn
(message "End of buffer.")
(setq address hexl-max-address))
(setq address (logior address 3))))
(while (> arg 0)
(if (not (equal address (logand address -4)))
(setq address (logand address -4))
(if (not (equal address 0))
(setq address (- address 4))
(message "Beginning of buffer.")))
(setq arg (1- arg))))
address)))
(defun hexl-forward-short (arg)
"Move right ARG shorts (left if ARG negative) in hexl-mode."
(interactive "p")
(hexl-backward-short (- arg)))
(defun hexl-backward-word (arg)
"Move to left ARG words (right if ARG negative) in hexl-mode."
(interactive "p")
(hexl-goto-address (let ((address (hexl-current-address)))
(if (< arg 0)
(progn
(setq arg (- arg))
(while (> arg 0)
(if (not (equal address (logior address 7)))
(if (> address hexl-max-address)
(progn
(message "End of buffer.")
(setq address hexl-max-address))
(setq address (logior address 7)))
(if (> address hexl-max-address)
(progn
(message "End of buffer.")
(setq address hexl-max-address))
(setq address (+ address 8))))
(setq arg (1- arg)))
(if (> address hexl-max-address)
(progn
(message "End of buffer.")
(setq address hexl-max-address))
(setq address (logior address 7))))
(while (> arg 0)
(if (not (equal address (logand address -8)))
(setq address (logand address -8))
(if (not (equal address 0))
(setq address (- address 8))
(message "Beginning of buffer.")))
(setq arg (1- arg))))
address)))
(defun hexl-forward-word (arg)
"Move right ARG words (left if ARG negative) in hexl-mode."
(interactive "p")
(hexl-backward-word (- arg)))
(defun hexl-previous-line (arg)
"Move vertically up ARG lines [16 bytes] (down if ARG negative) in
hexl-mode.
If there is byte at the target address move to the last byte in that
line."
(interactive "p")
(hexl-next-line (- arg)))
(defun hexl-next-line (arg)
"Move vertically down ARG lines [16 bytes] (up if ARG negative) in
hexl-mode.
If there is no byte at the target address move to the last byte in that
line."
(interactive "p")
(hexl-goto-address (let ((address (+ (hexl-current-address) (* arg 16)) t))
(if (and (< arg 0) (< address 0))
(progn (message "Out of hexl region.")
(setq address
(% (hexl-current-address) 16)))
(if (and (> address hexl-max-address)
(< (% hexl-max-address 16) (% address 16)))
(setq address hexl-max-address)
(if (> address hexl-max-address)
(progn (message "Out of hexl region.")
(setq
address
(+ (logand hexl-max-address -16)
(% (hexl-current-address) 16)))))))
address)))
(defun hexl-beginning-of-buffer (arg)
"Move to the beginning of the hexl buffer; leave hexl-mark at previous
posistion.
With arg N, put point N bytes of the way from the true beginning."
(interactive "p")
(push-mark (point))
(hexl-goto-address (+ 0 (1- arg))))
(defun hexl-end-of-buffer (arg)
"Goto hexl-max-address minus ARG."
(interactive "p")
(push-mark (point))
(hexl-goto-address (- hexl-max-address (1- arg))))
(defun hexl-beginning-of-line ()
"Goto beginning of line in hexl mode."
(interactive)
(goto-char (+ (* (/ (point) 68) 68) 11)))
(defun hexl-end-of-line ()
"Goto end of line in hexl mode."
(interactive)
(hexl-goto-address (let ((address (logior (hexl-current-address) 15)))
(if (> address hexl-max-address)
(setq address hexl-max-address))
address)))
(defun hexl-scroll-down (arg)
"Scroll hexl buffer window upward ARG lines; or near full window if no ARG."
(interactive "P")
(if (null arg)
(setq arg (1- (window-height)))
(setq arg (prefix-numeric-value arg)))
(hexl-scroll-up (- arg)))
(defun hexl-scroll-up (arg)
"Scroll hexl buffer window upward ARG lines; or near full window if no ARG."
(interactive "P")
(if (null arg)
(setq arg (1- (window-height)))
(setq arg (prefix-numeric-value arg)))
(let ((movement (* arg 16))
(address (hexl-current-address)))
(if (or (> (+ address movement) hexl-max-address)
(< (+ address movement) 0))
(message "Out of hexl region.")
(hexl-goto-address (+ address movement))
(recenter 0))))
(defun hexl-beginning-of-1k-page ()
"Goto to beginning of 1k boundry."
(interactive)
(hexl-goto-address (logand (hexl-current-address) -1024)))
(defun hexl-end-of-1k-page ()
"Goto to end of 1k boundry."
(interactive)
(hexl-goto-address (let ((address (logior (hexl-current-address) 1023)))
(if (> address hexl-max-address)
(setq address hexl-max-address))
address)))
(defun hexl-beginning-of-512b-page ()
"Goto to beginning of 512 byte boundry."
(interactive)
(hexl-goto-address (logand (hexl-current-address) -512)))
(defun hexl-end-of-512b-page ()
"Goto to end of 512 byte boundry."
(interactive)
(hexl-goto-address (let ((address (logior (hexl-current-address) 511)))
(if (> address hexl-max-address)
(setq address hexl-max-address))
address)))
(defun hexl-quoted-insert (arg)
"Read next input character and insert it.
Useful for inserting control characters.
You may also type up to 3 octal digits, to insert a character with that code"
(interactive "p")
(hexl-insert-char (read-quoted-char) arg))
;00000000: 0011 2233 4455 6677 8899 aabb ccdd eeff 0123456789ABCDEF
(defun hexlify-buffer ()
"Convert a binary buffer to hexl format"
(interactive)
(shell-command-on-region (point-min) (point-max) hexlify-command t))
(defun dehexlify-buffer ()
"Convert a hexl format buffer to binary."
(interactive)
(shell-command-on-region (point-min) (point-max) dehexlify-command t))
(defun hexl-char-after-point ()
"Return char for ASCII hex digits at point."
(setq lh (char-after (point)))
(setq rh (char-after (1+ (point))))
(hexl-htoi lh rh))
(defun hexl-htoi (lh rh)
"Hex (char) LH (char) RH to integer."
(+ (* (hexl-hex-char-to-integer lh) 16)
(hexl-hex-char-to-integer rh)))
(defun hexl-hex-char-to-integer (character)
"Take a char and return its value as if it was a hex digit."
(if (and (>= character ?0) (<= character ?9))
(- character ?0)
(let ((ch (logior character 32)))
(if (and (>= ch ?a) (<= ch ?f))
(- ch (- ?a 10))
(error (format "Invalid hex digit `%c'." ch))))))
(defun hexl-oct-char-to-integer (character)
"Take a char and return its value as if it was a octal digit."
(if (and (>= character ?0) (<= character ?7))
(- character ?0)
(error (format "Invalid octal digit `%c'." character))))
(defun hexl-printable-character (ch)
"Return a displayable string for character CH."
(format "%c" (if hexl-iso
(if (or (< ch 32) (and (>= ch 127) (< ch 160)))
46
ch)
(if (or (< ch 32) (>= ch 127))
46
ch))))
(defun hexl-self-insert-command (arg)
"Insert this character."
(interactive "p")
(hexl-insert-char last-command-char arg))
(defun hexl-insert-char (ch num)
"Insert a character in a hexl buffer."
(let ((address (hexl-current-address)))
(while (> num 0)
(delete-char 2)
(insert (format "%02x" ch))
(goto-char
(+ (* (/ address 16) 68) 52 (% address 16)))
(delete-char 1)
(insert (hexl-printable-character ch))
(if (eq address hexl-max-address)
(hexl-goto-address address)
(hexl-goto-address (1+ address)))
(setq num (1- num)))))
;; hex conversion
(defun hexl-insert-hex-char (arg)
"Insert a ASCII char ARG times at point for a given hexadecimal number."
(interactive "p")
(let ((num (hexl-hex-string-to-integer (read-string "Hex number: "))))
(if (or (> num 255) (< num 0))
(error "Hex number out of range.")
(hexl-insert-char num arg))))
(defun hexl-insert-decimal-char (arg)
"Insert a ASCII char ARG times at point for a given decimal number."
(interactive "p")
(let ((num (string-to-int (read-string "Decimal Number: "))))
(if (or (> num 255) (< num 0))
(error "Decimal number out of range.")
(hexl-insert-char num arg))))
(defun hexl-insert-octal-char (arg)
"Insert a ASCII char ARG times at point for a given octal number."
(interactive "p")
(let ((num (hexl-octal-string-to-integer (read-string "Octal Number: "))))
(if (or (> num 255) (< num 0))
(error "Decimal number out of range.")
(hexl-insert-char num arg))))
;; startup stuff.
(if hexl-mode-map
nil
(setq hexl-mode-map (make-sparse-keymap))
(define-key hexl-mode-map "\C-a" 'hexl-beginning-of-line)
(define-key hexl-mode-map "\C-b" 'hexl-backward-char)
(define-key hexl-mode-map "\C-d" 'undefined)
(define-key hexl-mode-map "\C-e" 'hexl-end-of-line)
(define-key hexl-mode-map "\C-f" 'hexl-forward-char)
(if (not (eq (key-binding "\C-h") 'help-command))
(define-key hexl-mode-map "\C-h" 'undefined))
(define-key hexl-mode-map "\C-i" 'hexl-self-insert-command)
(define-key hexl-mode-map "\C-j" 'hexl-self-insert-command)
(define-key hexl-mode-map "\C-k" 'undefined)
(define-key hexl-mode-map "\C-m" 'hexl-self-insert-command)
(define-key hexl-mode-map "\C-n" 'hexl-next-line)
(define-key hexl-mode-map "\C-o" 'undefined)
(define-key hexl-mode-map "\C-p" 'hexl-previous-line)
(define-key hexl-mode-map "\C-q" 'hexl-quoted-insert)
(define-key hexl-mode-map "\C-t" 'undefined)
(define-key hexl-mode-map "\C-v" 'hexl-scroll-up)
(define-key hexl-mode-map "\C-w" 'undefined)
(define-key hexl-mode-map "\C-y" 'undefined)
(let ((ch 32))
(while (< ch 127)
(define-key hexl-mode-map (format "%c" ch) 'hexl-self-insert-command)
(setq ch (1+ ch))))
(define-key hexl-mode-map "\e\C-a" 'hexl-beginning-of-512b-page)
(define-key hexl-mode-map "\e\C-b" 'hexl-backward-short)
(define-key hexl-mode-map "\e\C-c" 'undefined)
(define-key hexl-mode-map "\e\C-d" 'hexl-insert-decimal-char)
(define-key hexl-mode-map "\e\C-e" 'hexl-end-of-512b-page)
(define-key hexl-mode-map "\e\C-f" 'hexl-forward-short)
(define-key hexl-mode-map "\e\C-g" 'undefined)
(define-key hexl-mode-map "\e\C-h" 'undefined)
(define-key hexl-mode-map "\e\C-i" 'undefined)
(define-key hexl-mode-map "\e\C-j" 'undefined)
(define-key hexl-mode-map "\e\C-k" 'undefined)
(define-key hexl-mode-map "\e\C-l" 'undefined)
(define-key hexl-mode-map "\e\C-m" 'undefined)
(define-key hexl-mode-map "\e\C-n" 'undefined)
(define-key hexl-mode-map "\e\C-o" 'hexl-insert-octal-char)
(define-key hexl-mode-map "\e\C-p" 'undefined)
(define-key hexl-mode-map "\e\C-q" 'undefined)
(define-key hexl-mode-map "\e\C-r" 'undefined)
(define-key hexl-mode-map "\e\C-s" 'undefined)
(define-key hexl-mode-map "\e\C-t" 'undefined)
(define-key hexl-mode-map "\e\C-u" 'undefined)
(define-key hexl-mode-map "\e\C-w" 'undefined)
(define-key hexl-mode-map "\e\C-x" 'hexl-insert-hex-char)
(define-key hexl-mode-map "\e\C-y" 'undefined)
(define-key hexl-mode-map "\ea" 'hexl-beginning-of-1k-page)
(define-key hexl-mode-map "\eb" 'hexl-backward-word)
(define-key hexl-mode-map "\ec" 'undefined)
(define-key hexl-mode-map "\ed" 'undefined)
(define-key hexl-mode-map "\ee" 'hexl-end-of-1k-page)
(define-key hexl-mode-map "\ef" 'hexl-forward-word)
(define-key hexl-mode-map "\eg" 'hexl-goto-hex-address)
(define-key hexl-mode-map "\eh" 'undefined)
(define-key hexl-mode-map "\ei" 'undefined)
(define-key hexl-mode-map "\ej" 'hexl-goto-address)
(define-key hexl-mode-map "\ek" 'undefined)
(define-key hexl-mode-map "\el" 'undefined)
(define-key hexl-mode-map "\em" 'undefined)
(define-key hexl-mode-map "\en" 'undefined)
(define-key hexl-mode-map "\eo" 'undefined)
(define-key hexl-mode-map "\ep" 'undefined)
(define-key hexl-mode-map "\eq" 'undefined)
(define-key hexl-mode-map "\er" 'undefined)
(define-key hexl-mode-map "\es" 'undefined)
(define-key hexl-mode-map "\et" 'undefined)
(define-key hexl-mode-map "\eu" 'undefined)
(define-key hexl-mode-map "\ev" 'hexl-scroll-down)
(define-key hexl-mode-map "\ey" 'undefined)
(define-key hexl-mode-map "\ez" 'undefined)
(define-key hexl-mode-map "\e<" 'hexl-beginning-of-buffer)
(define-key hexl-mode-map "\e>" 'hexl-end-of-buffer)
(define-key hexl-mode-map "\C-c\C-c" 'hexl-mode-exit)
(define-key hexl-mode-map "\C-x\C-p" 'undefined)
(define-key hexl-mode-map "\C-x\C-s" 'hexl-save-buffer)
(define-key hexl-mode-map "\C-x\C-t" 'undefined))
;; The End.

138
lisp/ledit.el Normal file
View File

@ -0,0 +1,138 @@
;; Emacs side of ledit interface
;; Copyright (C) 1985 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 1, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;;; To do:
;;; o lisp -> emacs side of things (grind-definition and find-definition)
(defvar ledit-mode-map nil)
(defconst ledit-zap-file (concat "/tmp/" (user-login-name) ".l1")
"File name for data sent to Lisp by Ledit.")
(defconst ledit-read-file (concat "/tmp/" (user-login-name) ".l2")
"File name for data sent to Ledit by Lisp.")
(defconst ledit-compile-file
(concat "/tmp/" (user-login-name) ".l4")
"File name for data sent to Lisp compiler by Ledit.")
(defconst ledit-buffer "*LEDIT*"
"Name of buffer in which Ledit accumulates data to send to Lisp.")
;These are now in loaddefs.el
;(defconst ledit-save-files t
; "*Non-nil means Ledit should save files before transferring to Lisp.")
;(defconst ledit-go-to-lisp-string "%?lisp"
; "*Shell commands to execute to resume Lisp job.")
;(defconst ledit-go-to-liszt-string "%?liszt"
; "*Shell commands to execute to resume Lisp compiler job.")
(defun ledit-save-defun ()
"Save the current defun in the ledit buffer"
(interactive)
(save-excursion
(end-of-defun)
(let ((end (point)))
(beginning-of-defun)
(append-to-buffer ledit-buffer (point) end))
(message "Current defun saved for Lisp")))
(defun ledit-save-region (beg end)
"Save the current region in the ledit buffer"
(interactive "r")
(append-to-buffer ledit-buffer beg end)
(message "Region saved for Lisp"))
(defun ledit-zap-defun-to-lisp ()
"Carry the current defun to lisp"
(interactive)
(ledit-save-defun)
(ledit-go-to-lisp))
(defun ledit-zap-defun-to-liszt ()
"Carry the current defun to liszt"
(interactive)
(ledit-save-defun)
(ledit-go-to-liszt))
(defun ledit-zap-region-to-lisp (beg end)
"Carry the current region to lisp"
(interactive "r")
(ledit-save-region beg end)
(ledit-go-to-lisp))
(defun ledit-go-to-lisp ()
"Suspend Emacs and restart a waiting Lisp job."
(interactive)
(if ledit-save-files
(save-some-buffers))
(if (get-buffer ledit-buffer)
(save-excursion
(set-buffer ledit-buffer)
(goto-char (point-min))
(write-region (point-min) (point-max) ledit-zap-file)
(erase-buffer)))
(suspend-emacs ledit-go-to-lisp-string)
(load ledit-read-file t t))
(defun ledit-go-to-liszt ()
"Suspend Emacs and restart a waiting Liszt job."
(interactive)
(if ledit-save-files
(save-some-buffers))
(if (get-buffer ledit-buffer)
(save-excursion
(set-buffer ledit-buffer)
(goto-char (point-min))
(insert "(declare (macros t))\n")
(write-region (point-min) (point-max) ledit-compile-file)
(erase-buffer)))
(suspend-emacs ledit-go-to-liszt-string)
(load ledit-read-file t t))
(defun ledit-setup ()
"Set up key bindings for the Lisp / Emacs interface"
(if (not ledit-mode-map)
(progn (setq ledit-mode-map (make-sparse-keymap))
(lisp-mode-commands ledit-mode-map)))
(define-key ledit-mode-map "\e\^d" 'ledit-save-defun)
(define-key ledit-mode-map "\e\^r" 'ledit-save-region)
(define-key ledit-mode-map "\^xz" 'ledit-go-to-lisp)
(define-key ledit-mode-map "\e\^c" 'ledit-go-to-liszt))
(ledit-setup)
(defun ledit-mode ()
"Major mode for editing text and stuffing it to a Lisp job.
Like Lisp mode, plus these special commands:
M-C-d -- record defun at or after point
for later transmission to Lisp job.
M-C-r -- record region for later transmission to Lisp job.
C-x z -- transfer to Lisp job and transmit saved text.
M-C-c -- transfer to Liszt (Lisp compiler) job
and transmit saved text.
\\{ledit-mode-map}
To make Lisp mode automatically change to Ledit mode,
do (setq lisp-mode-hook 'ledit-from-lisp-mode)"
(interactive)
(lisp-mode)
(ledit-from-lisp-mode))
(defun ledit-from-lisp-mode ()
(use-local-map ledit-mode-map)
(setq mode-name "Ledit")
(setq major-mode 'ledit-mode)
(run-hooks 'ledit-mode-hook))

103
lisp/macros.el Normal file
View File

@ -0,0 +1,103 @@
;; Non-primitive commands for keyboard macros.
;; Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 1, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
(defun name-last-kbd-macro (symbol)
"Assign a name to the last keyboard macro defined.
One arg, a symbol, which is the name to define.
The symbol's function definition becomes the keyboard macro string.
Such a \"function\" cannot be called from Lisp, but it is a valid command
definition for the editor command loop."
(interactive "SName for last kbd macro: ")
(or last-kbd-macro
(error "No keyboard macro defined"))
(and (fboundp symbol)
(not (stringp (symbol-function symbol)))
(error "Function %s is already defined and not a keyboard macro."
symbol))
(fset symbol last-kbd-macro))
(defun insert-kbd-macro (macroname &optional keys)
"Insert in buffer the definition of kbd macro NAME, as Lisp code.
Second argument KEYS non-nil means also record the keys it is on.
(This is the prefix argument, when calling interactively.)
This Lisp code will, when executed, define the kbd macro with the
same definition it has now. If you say to record the keys,
the Lisp code will also rebind those keys to the macro.
Only global key bindings are recorded since executing this Lisp code
always makes global bindings.
To save a kbd macro, visit a file of Lisp code such as your ~/.emacs,
use this command, and then save the file."
(interactive "CInsert kbd macro (name): \nP")
(insert "(fset '")
(prin1 macroname (current-buffer))
(insert "\n ")
(prin1 (symbol-function macroname) (current-buffer))
(insert ")\n")
(if keys
(let ((keys (where-is-internal macroname nil)))
(while keys
(insert "(global-set-key ")
(prin1 (car keys) (current-buffer))
(insert " '")
(prin1 macroname (current-buffer))
(insert ")\n")
(setq keys (cdr keys))))))
(defun kbd-macro-query (flag)
"Query user during kbd macro execution.
With prefix argument, enters recursive edit,
reading keyboard commands even within a kbd macro.
You can give different commands each time the macro executes.
Without prefix argument, reads a character. Your options are:
Space -- execute the rest of the macro.
DEL -- skip the rest of the macro; start next repetition.
C-d -- skip rest of the macro and don't repeat it any more.
C-r -- enter a recursive edit, then on exit ask again for a character
C-l -- redisplay screen and ask again."
(interactive "P")
(or executing-macro
defining-kbd-macro
(error "Not defining or executing kbd macro"))
(if flag
(let (executing-macro defining-kbd-macro)
(recursive-edit))
(if (not executing-macro)
nil
(let ((loop t))
(while loop
(let ((char (let ((executing-macro nil)
(defining-kbd-macro nil))
(message "Proceed with macro? (Space, DEL, C-d, C-r or C-l) ")
(read-char))))
(cond ((= char ? )
(setq loop nil))
((= char ?\177)
(setq loop nil)
(setq executing-macro ""))
((= char ?\C-d)
(setq loop nil)
(setq executing-macro t))
((= char ?\C-l)
(recenter nil))
((= char ?\C-r)
(let (executing-macro defining-kbd-macro)
(recursive-edit))))))))))

38
lisp/mail/emacsbug.el Normal file
View File

@ -0,0 +1,38 @@
;; Command to report Emacs bugs to appropriate mailing list.
;; Not fully installed because it can work only on Internet hosts.
;; Copyright (C) 1985 Free Software Foundation, Inc.
;; Principal author K. Shane Hartman
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 1, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;; >> This should be an address which is accessible to your machine,
;; >> otherwise you can't use this file. It will only work on the
;; >> internet with this address.
(defvar bug-gnu-emacs "bug-gnu-emacs@prep.ai.mit.edu"
"Address of site maintaining mailing list for Gnu emacs bugs.")
(defun report-emacs-bug (topic)
"Report a bug in Gnu emacs.
Prompts for bug subject. Leaves you in a mail buffer."
(interactive "sBug Subject: ")
(mail nil bug-gnu-emacs topic)
(goto-char (point-max))
(insert "\nIn " (emacs-version) "\n\n")
(message (substitute-command-keys "Type \\[mail-send] to send bug report.")))

195
lisp/mail/mail-utils.el Normal file
View File

@ -0,0 +1,195 @@
;; Utility functions used both by rmail and rnews
;; Copyright (C) 1985 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 1, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
(provide 'mail-utils)
;; should be in loaddefs
(defvar mail-use-rfc822 nil
"*If non-nil, use a full, hairy RFC822 parser on mail addresses.
Otherwise, (the default) use a smaller, somewhat faster and
often-correct parser.")
(defun mail-string-delete (string start end)
"Returns a string containing all of STRING except the part
from START (inclusive) to END (exclusive)."
(if (null end) (substring string 0 start)
(concat (substring string 0 start)
(substring string end nil))))
(defun mail-strip-quoted-names (address)
"Delete comments and quoted strings in an address list ADDRESS.
Also delete leading/trailing whitespace and replace FOO <BAR> with just BAR.
Return a modified address list."
(if mail-use-rfc822
(progn (require 'rfc822)
(mapconcat 'identity (rfc822-addresses address) ", "))
(let (pos)
(string-match "\\`[ \t\n]*" address)
;; strip surrounding whitespace
(setq address (substring address
(match-end 0)
(string-match "[ \t\n]*\\'" address
(match-end 0))))
;; Detect nested comments.
(if (string-match "[ \t]*(\\([^)\"\\]\\|\\\\.\\|\\\\\n\\)*(" address)
;; Strip nested comments.
(save-excursion
(set-buffer (get-buffer-create " *temp*"))
(erase-buffer)
(insert address)
(set-syntax-table lisp-mode-syntax-table)
(goto-char 1)
(while (search-forward "(" nil t)
(forward-char -1)
(skip-chars-backward " \t")
(delete-region (point)
(save-excursion (forward-sexp 1) (point))))
(setq address (buffer-string))
(erase-buffer))
;; Strip non-nested comments an easier way.
(while (setq pos (string-match
;; This doesn't hack rfc822 nested comments
;; `(xyzzy (foo) whinge)' properly. Big deal.
"[ \t]*(\\([^)\"\\]\\|\\\\.\\|\\\\\n\\)*)"
address))
(setq address
(mail-string-delete address
pos (match-end 0)))))
;; strip `quoted' names (This is supposed to hack `"Foo Bar" <bar@host>')
(setq pos 0)
(while (setq pos (string-match
"[ \t]*\"\\([^\"\\]\\|\\\\.\\|\\\\\n\\)*\"[ \t\n]*"
address pos))
;; If the next thing is "@", we have "foo bar"@host. Leave it.
(if (and (> (length address) (match-end 0))
(= (aref address (match-end 0)) ?@))
(setq pos (match-end 0))
(setq address
(mail-string-delete address
pos (match-end 0)))))
;; Retain only part of address in <> delims, if there is such a thing.
(while (setq pos (string-match "\\(,\\|\\`\\)[^,]*<\\([^>,]*>\\)"
address))
(let ((junk-beg (match-end 1))
(junk-end (match-beginning 2))
(close (match-end 0)))
(setq address (mail-string-delete address (1- close) close))
(setq address (mail-string-delete address junk-beg junk-end))))
address)))
(or (and (boundp 'rmail-default-dont-reply-to-names)
(not (null rmail-default-dont-reply-to-names)))
(setq rmail-default-dont-reply-to-names "info-"))
; rmail-dont-reply-to-names is defined in loaddefs
(defun rmail-dont-reply-to (userids)
"Returns string of mail addresses USERIDS sans any recipients
that start with matches for rmail-dont-reply-to-names.
Usenet paths ending in an element that matches are removed also."
(if (null rmail-dont-reply-to-names)
(setq rmail-dont-reply-to-names
(concat (if rmail-default-dont-reply-to-names
(concat rmail-default-dont-reply-to-names "\\|")
"")
(concat (regexp-quote (user-original-login-name))
"\\>"))))
(let ((match (concat "\\(^\\|,\\)[ \t\n]*\\([^,\n]*!\\|\\)\\("
rmail-dont-reply-to-names
"\\)"))
(case-fold-search t)
pos epos)
(while (setq pos (string-match match userids))
(if (> pos 0) (setq pos (1+ pos)))
(setq epos
(if (string-match "[ \t\n,]+" userids (match-end 0))
(match-end 0)
(length userids)))
(setq userids
(mail-string-delete
userids pos epos)))
;; get rid of any trailing commas
(if (setq pos (string-match "[ ,\t\n]*\\'" userids))
(setq userids (substring userids 0 pos)))
;; remove leading spaces. they bother me.
(if (string-match "\\s *" userids)
(substring userids (match-end 0))
userids)))
(defun mail-fetch-field (field-name &optional last all)
"Return the value of the header field FIELD.
The buffer is expected to be narrowed to just the headers of the message.
If 2nd arg LAST is non-nil, use the last such field if there are several.
If 3rd arg ALL is non-nil, concatenate all such fields, with commas between."
(save-excursion
(goto-char (point-min))
(let ((case-fold-search t)
(name (concat "^" (regexp-quote field-name) "[ \t]*:[ \t]*")))
(goto-char (point-min))
(if all
(let ((value ""))
(while (re-search-forward name nil t)
(let ((opoint (point)))
(while (progn (forward-line 1)
(looking-at "[ \t]")))
(setq value (concat value
(if (string= value "") "" ", ")
(buffer-substring opoint (1- (point)))))))
(and (not (string= value "")) value))
(if (re-search-forward name nil t)
(progn
(if last (while (re-search-forward name nil t)))
(let ((opoint (point)))
(while (progn (forward-line 1)
(looking-at "[ \t]")))
(buffer-substring opoint (1- (point))))))))))
;; Parse a list of tokens separated by commas.
;; It runs from point to the end of the visible part of the buffer.
;; Whitespace before or after tokens is ignored,
;; but whitespace within tokens is kept.
(defun mail-parse-comma-list ()
(let (accumulated
beg)
(skip-chars-forward " ")
(while (not (eobp))
(setq beg (point))
(skip-chars-forward "^,")
(skip-chars-backward " ")
(setq accumulated
(cons (buffer-substring beg (point))
accumulated))
(skip-chars-forward "^,")
(skip-chars-forward ", "))
accumulated))
(defun mail-comma-list-regexp (labels)
(let (pos)
(setq pos (or (string-match "[^ \t]" labels) 0))
;; Remove leading and trailing whitespace.
(setq labels (substring labels pos (string-match "[ \t]*$" labels pos)))
;; Change each comma to \|, and flush surrounding whitespace.
(while (setq pos (string-match "[ \t]*,[ \t]*" labels))
(setq labels
(concat (substring labels 0 pos)
"\\|"
(substring labels (match-end 0))))))
labels)

105
lisp/mail/rmailedit.el Normal file
View File

@ -0,0 +1,105 @@
;; "RMAIL edit mode" Edit the current message.
;; Copyright (C) 1985 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 1, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
(require 'rmail)
(defvar rmail-edit-map nil)
(if rmail-edit-map
nil
(setq rmail-edit-map (nconc (make-sparse-keymap) text-mode-map))
(define-key rmail-edit-map "\C-c\C-c" 'rmail-cease-edit)
(define-key rmail-edit-map "\C-c\C-]" 'rmail-abort-edit))
;; Rmail Edit mode is suitable only for specially formatted data.
(put 'rmail-edit-mode 'mode-class 'special)
(defun rmail-edit-mode ()
"Major mode for editing the contents of an RMAIL message.
The editing commands are the same as in Text mode, together with two commands
to return to regular RMAIL:
* rmail-abort-edit cancels the changes
you have made and returns to RMAIL
* rmail-cease-edit makes them permanent.
\\{rmail-edit-map}"
(use-local-map rmail-edit-map)
(setq major-mode 'rmail-edit-mode)
(setq mode-name "RMAIL Edit")
(if (boundp 'mode-line-modified)
(setq mode-line-modified (default-value 'mode-line-modified))
(setq mode-line-format (default-value 'mode-line-format)))
(run-hooks 'text-mode-hook 'rmail-edit-mode-hook))
(defun rmail-edit-current-message ()
"Edit the contents of this message."
(interactive)
(rmail-edit-mode)
(make-local-variable 'rmail-old-text)
(setq rmail-old-text (buffer-substring (point-min) (point-max)))
(setq buffer-read-only nil)
(set-buffer-modified-p (buffer-modified-p))
;; Make mode line update.
(if (and (eq (key-binding "\C-c\C-c") 'rmail-cease-edit)
(eq (key-binding "\C-c\C-]") 'rmail-abort-edit))
(message "Editing: Type C-c C-c to return to Rmail, C-c C-] to abort")
(message (substitute-command-keys
"Editing: Type \\[rmail-cease-edit] to return to Rmail, \\[rmail-abort-edit] to abort"))))
(defun rmail-cease-edit ()
"Finish editing message; switch back to Rmail proper."
(interactive)
;; Make sure buffer ends with a newline.
(save-excursion
(goto-char (point-max))
(if (/= (preceding-char) ?\n)
(insert "\n"))
;; Adjust the marker that points to the end of this message.
(set-marker (aref rmail-message-vector (1+ rmail-current-message))
(point)))
(let ((old rmail-old-text))
;; Update the mode line.
(set-buffer-modified-p (buffer-modified-p))
(rmail-mode-1)
(if (and (= (length old) (- (point-max) (point-min)))
(string= old (buffer-substring (point-min) (point-max))))
()
(setq old nil)
(rmail-set-attribute "edited" t)
(if (boundp 'rmail-summary-vector)
(progn
(aset rmail-summary-vector (1- rmail-current-message) nil)
(save-excursion
(rmail-widen-to-current-msgbeg
(function (lambda ()
(forward-line 2)
(if (looking-at "Summary-line: ")
(let ((buffer-read-only nil))
(delete-region (point)
(progn (forward-line 1)
(point))))))))
(rmail-show-message))))))
(setq buffer-read-only t))
(defun rmail-abort-edit ()
"Abort edit of current message; restore original contents."
(interactive)
(delete-region (point-min) (point-max))
(insert rmail-old-text)
(rmail-cease-edit))

260
lisp/mail/rmailkwd.el Normal file
View File

@ -0,0 +1,260 @@
;; "RMAIL" mail reader for Emacs.
;; Copyright (C) 1985, 1988 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 1, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;; Global to all RMAIL buffers. It exists primarily for the sake of
;; completion. It is better to use strings with the label functions
;; and let them worry about making the label.
(defvar rmail-label-obarray (make-vector 47 0))
;; Named list of symbols representing valid message attributes in RMAIL.
(defconst rmail-attributes
(cons 'rmail-keywords
(mapcar '(lambda (s) (intern s rmail-label-obarray))
'("deleted" "answered" "filed" "forwarded" "unseen" "edited"))))
(defconst rmail-deleted-label (intern "deleted" rmail-label-obarray))
;; Named list of symbols representing valid message keywords in RMAIL.
(defvar rmail-keywords nil)
(defun rmail-add-label (string)
"Add LABEL to labels associated with current RMAIL message.
Completion is performed over known labels when reading."
(interactive (list (rmail-read-label "Add label")))
(rmail-set-label string t))
(defun rmail-kill-label (string)
"Remove LABEL from labels associated with current RMAIL message.
Completion is performed over known labels when reading."
(interactive (list (rmail-read-label "Remove label")))
(rmail-set-label string nil))
(defun rmail-read-label (prompt)
(if (not rmail-keywords) (rmail-parse-file-keywords))
(let ((result
(completing-read (concat prompt
(if rmail-last-label
(concat " (default "
(symbol-name rmail-last-label)
"): ")
": "))
rmail-label-obarray
nil
nil)))
(if (string= result "")
rmail-last-label
(setq rmail-last-label (rmail-make-label result t)))))
(defun rmail-set-label (l state &optional n)
(rmail-maybe-set-message-counters)
(if (not n) (setq n rmail-current-message))
(aset rmail-summary-vector (1- n) nil)
(let* ((attribute (rmail-attribute-p l))
(keyword (and (not attribute)
(or (rmail-keyword-p l)
(rmail-install-keyword l))))
(label (or attribute keyword)))
(if label
(let ((omax (- (buffer-size) (point-max)))
(omin (- (buffer-size) (point-min)))
(buffer-read-only nil)
(case-fold-search t))
(unwind-protect
(save-excursion
(widen)
(goto-char (rmail-msgbeg n))
(forward-line 1)
(if (not (looking-at "[01],"))
nil
(let ((start (1+ (point)))
(bound))
(narrow-to-region (point) (progn (end-of-line) (point)))
(setq bound (point-max))
(search-backward ",," nil t)
(if attribute
(setq bound (1+ (point)))
(setq start (1+ (point))))
(goto-char start)
; (while (re-search-forward "[ \t]*,[ \t]*" nil t)
; (replace-match ","))
; (goto-char start)
(if (re-search-forward
(concat ", " (rmail-quote-label-name label) ",")
bound
'move)
(if (not state) (replace-match ","))
(if state (insert " " (symbol-name label) ",")))
(if (eq label rmail-deleted-label)
(rmail-set-message-deleted-p n state)))))
(narrow-to-region (- (buffer-size) omin) (- (buffer-size) omax))
(if (= n rmail-current-message) (rmail-display-labels)))))))
;; Commented functions aren't used by RMAIL but might be nice for user
;; packages that do stuff with RMAIL. Note that rmail-message-labels-p
;; is in rmailsum now.
;(defun rmail-message-attribute-p (attribute &optional n)
; "Returns t if ATTRIBUTE on NTH or current message."
; (rmail-message-labels-p (rmail-make-label attribute t) n))
;(defun rmail-message-keyword-p (keyword &optional n)
; "Returns t if KEYWORD on NTH or current message."
; (rmail-message-labels-p (rmail-make-label keyword t) n t))
;(defun rmail-message-label-p (label &optional n)
; "Returns symbol if LABEL (attribute or keyword) on NTH or current message."
; (rmail-message-labels-p (rmail-make-label label t) n 'all))
;; Not used by RMAIL but might be nice for user package.
;(defun rmail-parse-message-labels (&optional n)
; "Returns labels associated with NTH or current RMAIL message.
;Results is a list of two lists. The first is the message attributes
;and the second is the message keywords. Labels are represented as symbols."
; (let ((omin (- (buffer-size) (point-min)))
; (omax (- (buffer-size) (point-max)))
; (result))
; (unwind-protect
; (save-excursion
; (let ((beg (rmail-msgbeg (or n rmail-current-message))))
; (widen)
; (goto-char beg)
; (forward-line 1)
; (if (looking-at "[01],")
; (save-restriction
; (narrow-to-region (point) (save-excursion (end-of-line) (point)))
; (rmail-nuke-whitespace)
; (goto-char (1+ (point-min)))
; (list (mail-parse-comma-list) (mail-parse-comma-list))))))
; (narrow-to-region (- (buffer-size) omin)
; (- (buffer-size) omax))
; nil)))
(defun rmail-attribute-p (s)
(let ((symbol (rmail-make-label s)))
(if (memq symbol (cdr rmail-attributes)) symbol)))
(defun rmail-keyword-p (s)
(let ((symbol (rmail-make-label s)))
(if (memq symbol (cdr (rmail-keywords))) symbol)))
(defun rmail-make-label (s &optional forcep)
(cond ((symbolp s) s)
(forcep (intern (downcase s) rmail-label-obarray))
(t (intern-soft (downcase s) rmail-label-obarray))))
(defun rmail-force-make-label (s)
(intern (downcase s) rmail-label-obarray))
(defun rmail-quote-label-name (label)
(regexp-quote (symbol-name (rmail-make-label label t))))
;; Motion on messages with keywords.
(defun rmail-previous-labeled-message (n label)
"Show previous message with LABEL. Defaults to last labels used.
With prefix argument N moves backward N messages with these labels."
(interactive "p\nsMove to previous msg with labels: ")
(rmail-next-labeled-message (- n) label))
(defun rmail-next-labeled-message (n labels)
"Show next message with LABEL. Defaults to last labels used.
With prefix argument N moves forward N messages with these labels."
(interactive "p\nsMove to next msg with labels: ")
(if (string= labels "")
(setq labels rmail-last-multi-labels))
(or labels
(error "No labels to find have been specified previously"))
(setq rmail-last-multi-labels labels)
(rmail-maybe-set-message-counters)
(let ((lastwin rmail-current-message)
(current rmail-current-message)
(regexp (concat ", ?\\("
(mail-comma-list-regexp labels)
"\\),")))
(save-restriction
(widen)
(while (and (> n 0) (< current rmail-total-messages))
(setq current (1+ current))
(if (rmail-message-labels-p current regexp)
(setq lastwin current n (1- n))))
(while (and (< n 0) (> current 1))
(setq current (1- current))
(if (rmail-message-labels-p current regexp)
(setq lastwin current n (1+ n)))))
(rmail-show-message lastwin)
(if (< n 0)
(message "No previous message with labels %s" labels))
(if (> n 0)
(message "No following message with labels %s" labels))))
;;; Manipulate the file's Labels option.
;; Return a list of symbols for all
;; the keywords (labels) recorded in this file's Labels option.
(defun rmail-keywords ()
(or rmail-keywords (rmail-parse-file-keywords)))
;; Set rmail-keywords to a list of symbols for all
;; the keywords (labels) recorded in this file's Labels option.
(defun rmail-parse-file-keywords ()
(save-restriction
(save-excursion
(widen)
(goto-char 1)
(setq rmail-keywords
(if (search-forward "\nLabels:" (rmail-msgbeg 1) t)
(progn
(narrow-to-region (point) (progn (end-of-line) (point)))
(goto-char (point-min))
(cons 'rmail-keywords
(mapcar 'rmail-force-make-label
(mail-parse-comma-list)))))))))
;; Add WORD to the list in the file's Labels option.
;; Any keyword used for the first time needs this done.
(defun rmail-install-keyword (word)
(let ((keyword (rmail-make-label word t))
(keywords (rmail-keywords)))
(if (not (or (rmail-attribute-p keyword)
(rmail-keyword-p keyword)))
(let ((omin (- (buffer-size) (point-min)))
(omax (- (buffer-size) (point-max))))
(unwind-protect
(save-excursion
(widen)
(goto-char 1)
(let ((case-fold-search t)
(buffer-read-only nil))
(or (search-forward "\nLabels:" nil t)
(progn
(end-of-line)
(insert "\nLabels:")))
(delete-region (point) (progn (end-of-line) (point)))
(setcdr keywords (cons keyword (cdr keywords)))
(while (setq keywords (cdr keywords))
(insert (symbol-name (car keywords)) ","))
(delete-char -1)))
(narrow-to-region (- (buffer-size) omin)
(- (buffer-size) omax)))))
keyword))

100
lisp/makesum.el Normal file
View File

@ -0,0 +1,100 @@
;; Generate key binding summary for Emacs
;; Copyright (C) 1985 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 1, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
(defun make-command-summary ()
"Make a summary of current key bindings in the buffer *Summary*.
Previous contents of that buffer are killed first."
(interactive)
(message "Making command summary...")
;; This puts a description of bindings in a buffer called *Help*.
(save-window-excursion
(describe-bindings))
(with-output-to-temp-buffer "*Summary*"
(save-excursion
(let ((cur-mode mode-name))
(set-buffer standard-output)
(erase-buffer)
(insert-buffer-substring "*Help*")
(goto-char (point-min))
(delete-region (point) (progn (forward-line 1) (point)))
(while (search-forward " " nil t)
(replace-match " "))
(goto-char (point-min))
(while (search-forward "-@ " nil t)
(replace-match "-SP"))
(goto-char (point-min))
(while (search-forward " .. ~ " nil t)
(replace-match "SP .. ~"))
(goto-char (point-min))
(while (search-forward "C-?" nil t)
(replace-match "DEL"))
(goto-char (point-min))
(while (search-forward "C-i" nil t)
(replace-match "TAB"))
(goto-char (point-min))
(if (re-search-forward "^Local Bindings:" nil t)
(progn
(forward-char -1)
(insert " for " cur-mode " Mode")
(while (search-forward "??\n" nil t)
(delete-region (point)
(progn
(forward-line -1)
(point))))))
(goto-char (point-min))
(insert "Emacs command summary, " (substring (current-time-string) 0 10)
".\n")
;; Delete "key binding" and underlining of dashes.
(delete-region (point) (progn (forward-line 2) (point)))
(forward-line 1) ;Skip blank line
(while (not (eobp))
(let ((beg (point)))
(or (re-search-forward "^$" nil t)
(goto-char (point-max)))
(double-column beg (point))
(forward-line 1)))
(goto-char (point-min)))))
(message "Making command summary...done"))
(defun double-column (start end)
(interactive "r")
(let (half cnt
line lines nlines
(from-end (- (point-max) end)))
(setq nlines (count-lines start end))
(if (<= nlines 1)
nil
(setq half (/ (1+ nlines) 2))
(goto-char start)
(save-excursion
(forward-line half)
(while (< half nlines)
(setq half (1+ half))
(setq line (buffer-substring (point) (save-excursion (end-of-line) (point))))
(setq lines (cons line lines))
(delete-region (point) (progn (forward-line 1) (point)))))
(setq lines (nreverse lines))
(while lines
(end-of-line)
(indent-to 41)
(insert (car lines))
(forward-line 1)
(setq lines (cdr lines))))
(goto-char (- (point-max) from-end))))

105
lisp/novice.el Normal file
View File

@ -0,0 +1,105 @@
;; Handling of disabled commands ("novice mode") for Emacs.
;; Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 1, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;; This function is called (by autoloading)
;; to handle any disabled command.
;; The command is found in this-command
;; and the keys are returned by (this-command-keys).
(defun disabled-command-hook (&rest ignore)
(let (char)
(save-window-excursion
(with-output-to-temp-buffer "*Help*"
(if (= (aref (this-command-keys) 0) ?\M-x)
(princ "You have invoked the disabled command ")
(princ "You have typed ")
(princ (key-description (this-command-keys)))
(princ ", invoking disabled command "))
(princ this-command)
(princ ":\n")
;; Print any special message saying why the command is disabled.
(if (stringp (get this-command 'disabled))
(princ (get this-command 'disabled)))
(princ (or (condition-case ()
(documentation this-command)
(error nil))
"<< not documented >>"))
;; Keep only the first paragraph of the documentation.
(save-excursion
(set-buffer "*Help*")
(goto-char (point-min))
(if (search-forward "\n\n" nil t)
(delete-region (1- (point)) (point-max))
(goto-char (point-max))))
(princ "\n\n")
(princ "You can now type
Space to try the command just this once,
but leave it disabled,
Y to try it and enable it (no questions if you use it again),
N to do nothing (command remains disabled)."))
(message "Type y, n or Space: ")
(let ((cursor-in-echo-area t))
(while (not (memq (setq char (downcase (read-char)))
'(? ?y ?n)))
(ding)
(message "Please type y, n or Space: "))))
(if (= char ?y)
(if (y-or-n-p "Enable command for future editing sessions also? ")
(enable-command this-command)
(put this-command 'disabled nil)))
(if (/= char ?n)
(call-interactively this-command))))
(defun enable-command (command)
"Allow COMMAND to be executed without special confirmation from now on.
The user's .emacs file is altered so that this will apply
to future sessions."
(interactive "CEnable command: ")
(put command 'disabled nil)
(save-excursion
(set-buffer (find-file-noselect (substitute-in-file-name "~/.emacs")))
(goto-char (point-min))
(if (search-forward (concat "(put '" (symbol-name command) " ") nil t)
(delete-region
(progn (beginning-of-line) (point))
(progn (forward-line 1) (point)))
;; Must have been disabled by default.
(goto-char (point-max))
(insert "\n(put '" (symbol-name command) " 'disabled nil)\n"))
(setq foo (buffer-modified-p))
(save-buffer)))
(defun disable-command (command)
"Require special confirmation to execute COMMAND from now on.
The user's .emacs file is altered so that this will apply
to future sessions."
(interactive "CDisable command: ")
(put command 'disabled t)
(save-excursion
(set-buffer (find-file-noselect (substitute-in-file-name "~/.emacs")))
(goto-char (point-min))
(if (search-forward (concat "(put '" (symbol-name command) " ") nil t)
(delete-region
(progn (beginning-of-line) (point))
(progn (forward-line 1) (point))))
(goto-char (point-max))
(insert "(put '" (symbol-name command) " 'disabled t)\n")
(save-buffer)))

87
lisp/play/dissociate.el Normal file
View File

@ -0,0 +1,87 @@
;; Scramble text amusingly for Emacs.
;; Copyright (C) 1985 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 1, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
(defun dissociated-press (&optional arg)
"Dissociate the text of the current buffer.
Output goes in buffer named *Dissociation*,
which is redisplayed each time text is added to it.
Every so often the user must say whether to continue.
If ARG is positive, require ARG chars of continuity.
If ARG is negative, require -ARG words of continuity.
Default is 2."
(interactive "P")
(setq arg (if arg (prefix-numeric-value arg) 2))
(let* ((inbuf (current-buffer))
(outbuf (get-buffer-create "*Dissociation*"))
(move-function (if (> arg 0) 'forward-char 'forward-word))
(move-amount (if (> arg 0) arg (- arg)))
(search-function (if (> arg 0) 'search-forward 'word-search-forward))
(last-query-point 0))
(switch-to-buffer outbuf)
(erase-buffer)
(while
(save-excursion
(goto-char last-query-point)
(vertical-motion (- (window-height) 4))
(or (= (point) (point-max))
(and (progn (goto-char (point-max))
(y-or-n-p "Continue dissociation? "))
(progn
(message "")
(recenter 1)
(setq last-query-point (point-max))
t))))
(let (start end)
(save-excursion
(set-buffer inbuf)
(setq start (point))
(if (eq move-function 'forward-char)
(progn
(setq end (+ start (+ move-amount (random 16))))
(if (> end (point-max))
(setq end (+ 1 move-amount (random 16))))
(goto-char end))
(funcall move-function
(+ move-amount (random 16))))
(setq end (point)))
(let ((opoint (point)))
(insert-buffer-substring inbuf start end)
(save-excursion
(goto-char opoint)
(end-of-line)
(and (> (current-column) fill-column)
(do-auto-fill)))))
(save-excursion
(set-buffer inbuf)
(if (eobp)
(goto-char (point-min))
(let ((overlap
(buffer-substring (prog1 (point)
(funcall move-function
(- move-amount)))
(point))))
(let (ranval)
(while (< (setq ranval (random)) 0))
(goto-char (1+ (% ranval (1- (point-max))))))
(or (funcall search-function overlap nil t)
(let ((opoint (point)))
(goto-char 1)
(funcall search-function overlap opoint t))))))
(sit-for 0))))

1166
lisp/play/gomoku.el Normal file
View File

File diff suppressed because it is too large Load Diff

109
lisp/play/spook.el Normal file
View File

@ -0,0 +1,109 @@
;; Spook phrase utility
;; Copyright (C) 1988 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 1, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
; Steve Strassmann (straz@media-lab.media.mit.edu) didn't write
; this, and even if he did, he really didn't mean for you to use it
; in an anarchistic way.
; May 1987
; To use this:
; Make sure you have the variable SPOOK-PHRASES-FILE pointing to
; a valid phrase file. Phrase files are in the same format as
; zippy's yow.lines (ITS-style LINS format).
; Strings are terminated by ascii 0 characters. Leading whitespace ignored.
; Everything up to the first \000 is a comment.
;
; Just before sending mail, do M-x spook.
; A number of phrases will be inserted into your buffer, to help
; give your message that extra bit of attractiveness for automated
; keyword scanners.
; Variables
(defvar spook-phrases-file (concat exec-directory "spook.lines")
"Keep your favorite phrases here.")
(defvar spook-phrase-default-count 15
"Default number of phrases to insert")
(defvar spook-vector nil
"Important phrases for NSA mail-watchers")
; Randomize the seed in the random number generator.
(random t)
; Call this with M-x spook.
(defun spook ()
"Adds that special touch of class to your outgoing mail."
(interactive)
(if (null spook-vector)
(setq spook-vector (snarf-spooks)))
(shuffle-vector spook-vector)
(let ((start (point)))
(insert ?\n)
(spook1 (min (- (length spook-vector) 1) spook-phrase-default-count))
(insert ?\n)
(fill-region-as-paragraph start (point) nil)))
(defun spook1 (arg)
"Inserts a spook phrase ARG times."
(cond ((zerop arg) t)
(t (insert (aref spook-vector arg))
(insert " ")
(spook1 (1- arg)))))
(defun snarf-spooks ()
"Reads in the phrase file"
(message "Checking authorization...")
(save-excursion
(let ((buf (generate-new-buffer "*spook*"))
(result '()))
(set-buffer buf)
(insert-file-contents (expand-file-name spook-phrases-file))
(search-forward "\0")
(while (progn (skip-chars-forward " \t\n\r\f") (not (eobp)))
(let ((beg (point)))
(search-forward "\0")
(setq result (cons (buffer-substring beg (1- (point)))
result))))
(kill-buffer buf)
(message "Checking authorization... Approved.")
(setq spook-vector (apply 'vector result)))))
(defun pick-random (n)
"Returns a random number from 0 to N-1 inclusive."
(% (logand 0777777 (random)) n))
; Thanks to Ian G Batten <BattenIG@CS.BHAM.AC.UK>
; [of the University of Birmingham Computer Science Department]
; for the iterative version of this shuffle.
;
(defun shuffle-vector (vector)
"Randomly permute the elements of VECTOR (all permutations equally likely)"
(let ((i 0)
j
temp
(len (length vector)))
(while (< i len)
(setq j (+ i (pick-random (- len i))))
(setq temp (aref vector i))
(aset vector i (aref vector j))
(aset vector j temp)
(setq i (1+ i))))
vector)

550
lisp/progmodes/icon.el Normal file
View File

@ -0,0 +1,550 @@
;; Note: use
;; (autoload 'icon-mode "icon" nil t)
;; (setq auto-mode-alist (cons '("\\.icn$" . icon-mode) auto-mode-alist))
;; if not permanently installed in your emacs
;; Icon code editing commands for Emacs
;; Derived from c-mode.el 15-Feb-89 Chris Smith convex!csmith
;; Copyright (C) 1989 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 1, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
(defvar icon-mode-abbrev-table nil
"Abbrev table in use in Icon-mode buffers.")
(define-abbrev-table 'icon-mode-abbrev-table ())
(defvar icon-mode-map ()
"Keymap used in Icon mode.")
(if icon-mode-map
()
(setq icon-mode-map (make-sparse-keymap))
(define-key icon-mode-map "{" 'electric-icon-brace)
(define-key icon-mode-map "}" 'electric-icon-brace)
(define-key icon-mode-map "\e\C-h" 'mark-icon-function)
(define-key icon-mode-map "\e\C-a" 'beginning-of-icon-defun)
(define-key icon-mode-map "\e\C-e" 'end-of-icon-defun)
(define-key icon-mode-map "\e\C-q" 'indent-icon-exp)
(define-key icon-mode-map "\177" 'backward-delete-char-untabify)
(define-key icon-mode-map "\t" 'icon-indent-command))
(defvar icon-mode-syntax-table nil
"Syntax table in use in Icon-mode buffers.")
(if icon-mode-syntax-table
()
(setq icon-mode-syntax-table (make-syntax-table))
(modify-syntax-entry ?\\ "\\" icon-mode-syntax-table)
(modify-syntax-entry ?# "<" icon-mode-syntax-table)
(modify-syntax-entry ?\n ">" icon-mode-syntax-table)
(modify-syntax-entry ?$ "." icon-mode-syntax-table)
(modify-syntax-entry ?/ "." icon-mode-syntax-table)
(modify-syntax-entry ?* "." icon-mode-syntax-table)
(modify-syntax-entry ?+ "." icon-mode-syntax-table)
(modify-syntax-entry ?- "." icon-mode-syntax-table)
(modify-syntax-entry ?= "." icon-mode-syntax-table)
(modify-syntax-entry ?% "." icon-mode-syntax-table)
(modify-syntax-entry ?< "." icon-mode-syntax-table)
(modify-syntax-entry ?> "." icon-mode-syntax-table)
(modify-syntax-entry ?& "." icon-mode-syntax-table)
(modify-syntax-entry ?| "." icon-mode-syntax-table)
(modify-syntax-entry ?\' "\"" icon-mode-syntax-table))
(defconst icon-indent-level 4
"*Indentation of Icon statements with respect to containing block.")
(defconst icon-brace-imaginary-offset 0
"*Imagined indentation of a Icon open brace that actually follows a statement.")
(defconst icon-brace-offset 0
"*Extra indentation for braces, compared with other text in same context.")
(defconst icon-continued-statement-offset 4
"*Extra indent for lines not starting new statements.")
(defconst icon-continued-brace-offset 0
"*Extra indent for substatements that start with open-braces.
This is in addition to icon-continued-statement-offset.")
(defconst icon-auto-newline nil
"*Non-nil means automatically newline before and after braces
inserted in Icon code.")
(defconst icon-tab-always-indent t
"*Non-nil means TAB in Icon mode should always reindent the current line,
regardless of where in the line point is when the TAB command is used.")
(defun icon-mode ()
"Major mode for editing Icon code.
Expression and list commands understand all Icon brackets.
Tab indents for Icon code.
Paragraphs are separated by blank lines only.
Delete converts tabs to spaces as it moves back.
\\{icon-mode-map}
Variables controlling indentation style:
icon-tab-always-indent
Non-nil means TAB in Icon mode should always reindent the current line,
regardless of where in the line point is when the TAB command is used.
icon-auto-newline
Non-nil means automatically newline before and after braces
inserted in Icon code.
icon-indent-level
Indentation of Icon statements within surrounding block.
The surrounding block's indentation is the indentation
of the line on which the open-brace appears.
icon-continued-statement-offset
Extra indentation given to a substatement, such as the
then-clause of an if or body of a while.
icon-continued-brace-offset
Extra indentation given to a brace that starts a substatement.
This is in addition to icon-continued-statement-offset.
icon-brace-offset
Extra indentation for line if it starts with an open brace.
icon-brace-imaginary-offset
An open brace following other text is treated as if it were
this far to the right of the start of its line.
Turning on Icon mode calls the value of the variable icon-mode-hook with no args,
if that value is non-nil."
(interactive)
(kill-all-local-variables)
(use-local-map icon-mode-map)
(setq major-mode 'icon-mode)
(setq mode-name "Icon")
(setq local-abbrev-table icon-mode-abbrev-table)
(set-syntax-table icon-mode-syntax-table)
(make-local-variable 'paragraph-start)
(setq paragraph-start (concat "^$\\|" page-delimiter))
(make-local-variable 'paragraph-separate)
(setq paragraph-separate paragraph-start)
(make-local-variable 'indent-line-function)
(setq indent-line-function 'icon-indent-line)
(make-local-variable 'require-final-newline)
(setq require-final-newline t)
(make-local-variable 'comment-start)
(setq comment-start "# ")
(make-local-variable 'comment-end)
(setq comment-end "")
(make-local-variable 'comment-column)
(setq comment-column 32)
(make-local-variable 'comment-start-skip)
(setq comment-start-skip "# *")
(make-local-variable 'comment-indent-hook)
(setq comment-indent-hook 'icon-comment-indent)
(run-hooks 'icon-mode-hook))
;; This is used by indent-for-comment
;; to decide how much to indent a comment in Icon code
;; based on its context.
(defun icon-comment-indent ()
(if (looking-at "^#")
0
(save-excursion
(skip-chars-backward " \t")
(max (if (bolp) 0 (1+ (current-column)))
comment-column))))
(defun electric-icon-brace (arg)
"Insert character and correct line's indentation."
(interactive "P")
(let (insertpos)
(if (and (not arg)
(eolp)
(or (save-excursion
(skip-chars-backward " \t")
(bolp))
(if icon-auto-newline
(progn (icon-indent-line) (newline) t)
nil)))
(progn
(insert last-command-char)
(icon-indent-line)
(if icon-auto-newline
(progn
(newline)
;; (newline) may have done auto-fill
(setq insertpos (- (point) 2))
(icon-indent-line)))
(save-excursion
(if insertpos (goto-char (1+ insertpos)))
(delete-char -1))))
(if insertpos
(save-excursion
(goto-char insertpos)
(self-insert-command (prefix-numeric-value arg)))
(self-insert-command (prefix-numeric-value arg)))))
(defun icon-indent-command (&optional whole-exp)
(interactive "P")
"Indent current line as Icon code, or in some cases insert a tab character.
If icon-tab-always-indent is non-nil (the default), always indent current line.
Otherwise, indent the current line only if point is at the left margin
or in the line's indentation; otherwise insert a tab.
A numeric argument, regardless of its value,
means indent rigidly all the lines of the expression starting after point
so that this line becomes properly indented.
The relative indentation among the lines of the expression are preserved."
(if whole-exp
;; If arg, always indent this line as Icon
;; and shift remaining lines of expression the same amount.
(let ((shift-amt (icon-indent-line))
beg end)
(save-excursion
(if icon-tab-always-indent
(beginning-of-line))
(setq beg (point))
(forward-sexp 1)
(setq end (point))
(goto-char beg)
(forward-line 1)
(setq beg (point)))
(if (> end beg)
(indent-code-rigidly beg end shift-amt "#")))
(if (and (not icon-tab-always-indent)
(save-excursion
(skip-chars-backward " \t")
(not (bolp))))
(insert-tab)
(icon-indent-line))))
(defun icon-indent-line ()
"Indent current line as Icon code.
Return the amount the indentation changed by."
(let ((indent (calculate-icon-indent nil))
beg shift-amt
(case-fold-search nil)
(pos (- (point-max) (point))))
(beginning-of-line)
(setq beg (point))
(cond ((eq indent nil)
(setq indent (current-indentation)))
((eq indent t)
(setq indent (calculate-icon-indent-within-comment)))
((looking-at "[ \t]*#")
(setq indent 0))
(t
(skip-chars-forward " \t")
(if (listp indent) (setq indent (car indent)))
(cond ((and (looking-at "else\\b")
(not (looking-at "else\\s_")))
(setq indent (save-excursion
(icon-backward-to-start-of-if)
(current-indentation))))
((or (= (following-char) ?})
(looking-at "end\\b"))
(setq indent (- indent icon-indent-level)))
((= (following-char) ?{)
(setq indent (+ indent icon-brace-offset))))))
(skip-chars-forward " \t")
(setq shift-amt (- indent (current-column)))
(if (zerop shift-amt)
(if (> (- (point-max) pos) (point))
(goto-char (- (point-max) pos)))
(delete-region beg (point))
(indent-to indent)
;; If initial point was within line's indentation,
;; position after the indentation. Else stay at same point in text.
(if (> (- (point-max) pos) (point))
(goto-char (- (point-max) pos))))
shift-amt))
(defun calculate-icon-indent (&optional parse-start)
"Return appropriate indentation for current line as Icon code.
In usual case returns an integer: the column to indent to.
Returns nil if line starts inside a string, t if in a comment."
(save-excursion
(beginning-of-line)
(let ((indent-point (point))
(case-fold-search nil)
state
containing-sexp
toplevel)
(if parse-start
(goto-char parse-start)
(setq toplevel (beginning-of-icon-defun)))
(while (< (point) indent-point)
(setq parse-start (point))
(setq state (parse-partial-sexp (point) indent-point 0))
(setq containing-sexp (car (cdr state))))
(cond ((or (nth 3 state) (nth 4 state))
;; return nil or t if should not change this line
(nth 4 state))
((and containing-sexp
(/= (char-after containing-sexp) ?{))
;; line is expression, not statement:
;; indent to just after the surrounding open.
(goto-char (1+ containing-sexp))
(current-column))
(t
(if toplevel
;; Outside any procedures.
(progn (icon-backward-to-noncomment (point-min))
(if (icon-is-continuation-line)
icon-continued-statement-offset 0))
;; Statement level.
(if (null containing-sexp)
(progn (beginning-of-icon-defun)
(setq containing-sexp (point))))
(goto-char indent-point)
;; Is it a continuation or a new statement?
;; Find previous non-comment character.
(icon-backward-to-noncomment containing-sexp)
;; Now we get the answer.
(if (icon-is-continuation-line)
;; This line is continuation of preceding line's statement;
;; indent icon-continued-statement-offset more than the
;; first line of the statement.
(progn
(icon-backward-to-start-of-continued-exp containing-sexp)
(+ icon-continued-statement-offset (current-column)
(if (save-excursion (goto-char indent-point)
(skip-chars-forward " \t")
(eq (following-char) ?{))
icon-continued-brace-offset 0)))
;; This line starts a new statement.
;; Position following last unclosed open.
(goto-char containing-sexp)
;; Is line first statement after an open-brace?
(or
;; If no, find that first statement and indent like it.
(save-excursion
(if (looking-at "procedure\\s ")
(forward-sexp 3)
(forward-char 1))
(while (progn (skip-chars-forward " \t\n")
(looking-at "#"))
;; Skip over comments following openbrace.
(forward-line 1))
;; The first following code counts
;; if it is before the line we want to indent.
(and (< (point) indent-point)
(current-column)))
;; If no previous statement,
;; indent it relative to line brace is on.
;; For open brace in column zero, don't let statement
;; start there too. If icon-indent-level is zero,
;; use icon-brace-offset + icon-continued-statement-offset
;; instead.
;; For open-braces not the first thing in a line,
;; add in icon-brace-imaginary-offset.
(+ (if (and (bolp) (zerop icon-indent-level))
(+ icon-brace-offset
icon-continued-statement-offset)
icon-indent-level)
;; Move back over whitespace before the openbrace.
;; If openbrace is not first nonwhite thing on the line,
;; add the icon-brace-imaginary-offset.
(progn (skip-chars-backward " \t")
(if (bolp) 0 icon-brace-imaginary-offset))
;; Get initial indentation of the line we are on.
(current-indentation))))))))))
;; List of words to check for as the last thing on a line.
;; If cdr is t, next line is a continuation of the same statement,
;; if cdr is nil, next line starts a new (possibly indented) statement.
(defconst icon-resword-alist
'(("by" . t) ("case" . t) ("create") ("do") ("dynamic" . t) ("else")
("every" . t) ("if" . t) ("global" . t) ("initial" . t)
("link" . t) ("local" . t) ("of") ("record" . t) ("repeat" . t)
("static" . t) ("then") ("to" . t) ("until" . t) ("while" . t)))
(defun icon-is-continuation-line ()
(let* ((ch (preceding-char))
(ch-syntax (char-syntax ch)))
(if (eq ch-syntax ?w)
(assoc (buffer-substring
(progn (forward-word -1) (point))
(progn (forward-word 1) (point)))
icon-resword-alist)
(not (memq ch '(0 ?\; ?\} ?\{ ?\) ?\] ?\" ?\' ?\n))))))
(defun icon-backward-to-noncomment (lim)
(let (opoint stop)
(while (not stop)
(skip-chars-backward " \t\n\f" lim)
(setq opoint (point))
(beginning-of-line)
(if (and (nth 5 (parse-partial-sexp (point) opoint))
(< lim (point)))
(search-backward "#")
(setq stop t)))))
(defun icon-backward-to-start-of-continued-exp (lim)
(if (memq (preceding-char) '(?\) ?\]))
(forward-sexp -1))
(beginning-of-line)
(skip-chars-forward " \t")
(cond
((<= (point) lim) (goto-char (1+ lim)))
((not (icon-is-continued-line)) 0)
((and (eq (char-syntax (following-char)) ?w)
(cdr
(assoc (buffer-substring (point)
(save-excursion (forward-word 1) (point)))
icon-resword-alist))) 0)
(t (end-of-line 0) (icon-backward-to-start-of-continued-exp lim))))
(defun icon-is-continued-line ()
(save-excursion
(end-of-line 0)
(icon-is-continuation-line)))
(defun icon-backward-to-start-of-if (&optional limit)
"Move to the start of the last ``unbalanced'' if."
(or limit (setq limit (save-excursion (beginning-of-icon-defun) (point))))
(let ((if-level 1)
(case-fold-search nil))
(while (not (zerop if-level))
(backward-sexp 1)
(cond ((looking-at "else\\b")
(setq if-level (1+ if-level)))
((looking-at "if\\b")
(setq if-level (1- if-level)))
((< (point) limit)
(setq if-level 0)
(goto-char limit))))))
(defun mark-icon-function ()
"Put mark at end of Icon function, point at beginning."
(interactive)
(push-mark (point))
(end-of-icon-defun)
(push-mark (point))
(beginning-of-line 0)
(beginning-of-icon-defun))
(defun beginning-of-icon-defun ()
"Go to the start of the enclosing procedure; return t if at top level."
(interactive)
(if (re-search-backward "^procedure\\s \\|^end[ \t\n]" (point-min) 'move)
(looking-at "e")
t))
(defun end-of-icon-defun ()
(interactive)
(if (not (bobp)) (forward-char -1))
(re-search-forward "\\(\\s \\|^\\)end\\(\\s \\|$\\)" (point-max) 'move)
(forward-word -1)
(forward-line 1))
(defun indent-icon-exp ()
"Indent each line of the Icon grouping following point."
(interactive)
(let ((indent-stack (list nil))
(contain-stack (list (point)))
(case-fold-search nil)
restart outer-loop-done inner-loop-done state ostate
this-indent last-sexp
at-else at-brace at-do
(opoint (point))
(next-depth 0))
(save-excursion
(forward-sexp 1))
(save-excursion
(setq outer-loop-done nil)
(while (and (not (eobp)) (not outer-loop-done))
(setq last-depth next-depth)
;; Compute how depth changes over this line
;; plus enough other lines to get to one that
;; does not end inside a comment or string.
;; Meanwhile, do appropriate indentation on comment lines.
(setq innerloop-done nil)
(while (and (not innerloop-done)
(not (and (eobp) (setq outer-loop-done t))))
(setq ostate state)
(setq state (parse-partial-sexp (point) (progn (end-of-line) (point))
nil nil state))
(setq next-depth (car state))
(if (and (car (cdr (cdr state)))
(>= (car (cdr (cdr state))) 0))
(setq last-sexp (car (cdr (cdr state)))))
(if (or (nth 4 ostate))
(icon-indent-line))
(if (or (nth 3 state))
(forward-line 1)
(setq innerloop-done t)))
(if (<= next-depth 0)
(setq outer-loop-done t))
(if outer-loop-done
nil
(if (/= last-depth next-depth)
(setq last-sexp nil))
(while (> last-depth next-depth)
(setq indent-stack (cdr indent-stack)
contain-stack (cdr contain-stack)
last-depth (1- last-depth)))
(while (< last-depth next-depth)
(setq indent-stack (cons nil indent-stack)
contain-stack (cons nil contain-stack)
last-depth (1+ last-depth)))
(if (null (car contain-stack))
(setcar contain-stack (or (car (cdr state))
(save-excursion (forward-sexp -1)
(point)))))
(forward-line 1)
(skip-chars-forward " \t")
(if (eolp)
nil
(if (and (car indent-stack)
(>= (car indent-stack) 0))
;; Line is on an existing nesting level.
;; Lines inside parens are handled specially.
(if (/= (char-after (car contain-stack)) ?{)
(setq this-indent (car indent-stack))
;; Line is at statement level.
;; Is it a new statement? Is it an else?
;; Find last non-comment character before this line
(save-excursion
(setq at-else (looking-at "else\\W"))
(setq at-brace (= (following-char) ?{))
(icon-backward-to-noncomment opoint)
(if (icon-is-continuation-line)
;; Preceding line did not end in comma or semi;
;; indent this line icon-continued-statement-offset
;; more than previous.
(progn
(icon-backward-to-start-of-continued-exp (car contain-stack))
(setq this-indent
(+ icon-continued-statement-offset (current-column)
(if at-brace icon-continued-brace-offset 0))))
;; Preceding line ended in comma or semi;
;; use the standard indent for this level.
(if at-else
(progn (icon-backward-to-start-of-if opoint)
(setq this-indent (current-indentation)))
(setq this-indent (car indent-stack))))))
;; Just started a new nesting level.
;; Compute the standard indent for this level.
(let ((val (calculate-icon-indent
(if (car indent-stack)
(- (car indent-stack))))))
(setcar indent-stack
(setq this-indent val))))
;; Adjust line indentation according to its contents
(if (or (= (following-char) ?})
(looking-at "end\\b"))
(setq this-indent (- this-indent icon-indent-level)))
(if (= (following-char) ?{)
(setq this-indent (+ this-indent icon-brace-offset)))
;; Put chosen indentation into effect.
(or (= (current-column) this-indent)
(progn
(delete-region (point) (progn (beginning-of-line) (point)))
(indent-to this-indent)))
;; Indent any comment following the text.
(or (looking-at comment-start-skip)
(if (re-search-forward comment-start-skip (save-excursion (end-of-line) (point)) t)
(progn (indent-for-comment) (beginning-of-line))))))))))

205
lisp/rect.el Normal file
View File

@ -0,0 +1,205 @@
;; Rectangle functions for GNU Emacs.
;; Copyright (C) 1985 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 1, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
(defun operate-on-rectangle (function start end coerce-tabs)
"Call FUNCTION for each line of rectangle with corners at START, END.
If COERCE-TABS is non-nil, convert multi-column characters
that span the starting or ending columns on any line
to multiple spaces before calling FUNCTION.
FUNCTION is called with three arguments:
position of start of segment of this line within the rectangle,
number of columns that belong to rectangle but are before that position,
number of columns that belong to rectangle but are after point.
Point is at the end of the segment of this line within the rectangle."
(let (startcol startlinepos endcol endlinepos)
(save-excursion
(goto-char start)
(setq startcol (current-column))
(beginning-of-line)
(setq startlinepos (point)))
(save-excursion
(goto-char end)
(setq endcol (current-column))
(forward-line 1)
(setq endlinepos (point-marker)))
(if (< endcol startcol)
(let ((tem startcol))
(setq startcol endcol endcol tem)))
(if (/= endcol startcol)
(save-excursion
(goto-char startlinepos)
(while (< (point) endlinepos)
(let (startpos begextra endextra)
(move-to-column startcol)
(and coerce-tabs
(> (current-column) startcol)
(rectangle-coerce-tab startcol))
(setq begextra (- (current-column) startcol))
(setq startpos (point))
(move-to-column endcol)
(if (> (current-column) endcol)
(if coerce-tabs
(rectangle-coerce-tab endcol)
(forward-char -1)))
(setq endextra (- endcol (current-column)))
(if (< begextra 0)
(setq endextra (+ endextra begextra)
begextra 0))
(funcall function startpos begextra endextra))
(forward-line 1))))
(- endcol startcol)))
(defun delete-rectangle-line (startdelpos ignore ignore)
(delete-region startdelpos (point)))
(defun delete-extract-rectangle-line (startdelpos begextra endextra)
(save-excursion
(extract-rectangle-line startdelpos begextra endextra))
(delete-region startdelpos (point)))
(defun extract-rectangle-line (startdelpos begextra endextra)
(let ((line (buffer-substring startdelpos (point)))
(end (point)))
(goto-char startdelpos)
(while (search-forward "\t" end t)
(let ((width (- (current-column)
(save-excursion (forward-char -1)
(current-column)))))
(setq line (concat (substring line 0 (- (point) end 1))
(spaces-string width)
(substring line (+ (length line) (- (point) end)))))))
(if (or (> begextra 0) (> endextra 0))
(setq line (concat (spaces-string begextra)
line
(spaces-string endextra))))
(setq lines (cons line lines))))
(defconst spaces-strings
'["" " " " " " " " " " " " " " " " "])
(defun spaces-string (n)
(if (<= n 8) (aref spaces-strings n)
(let ((val ""))
(while (> n 8)
(setq val (concat " " val)
n (- n 8)))
(concat val (aref spaces-strings n)))))
(defun delete-rectangle (start end)
"Delete (don't save) text in rectangle with point and mark as corners.
The same range of columns is deleted in each line
starting with the line where the region begins
and ending with the line where the region ends."
(interactive "r")
(operate-on-rectangle 'delete-rectangle-line start end t))
(defun delete-extract-rectangle (start end)
"Delete contents of rectangle and return it as a list of strings.
Arguments START and END are the corners of the rectangle.
The value is list of strings, one for each line of the rectangle."
(let (lines)
(operate-on-rectangle 'delete-extract-rectangle-line
start end t)
(nreverse lines)))
(defun extract-rectangle (start end)
"Return contents of rectangle with corners at START and END.
Value is list of strings, one for each line of the rectangle."
(let (lines)
(operate-on-rectangle 'extract-rectangle-line start end nil)
(nreverse lines)))
(defvar killed-rectangle nil
"Rectangle for yank-rectangle to insert.")
(defun kill-rectangle (start end)
"Delete rectangle with corners at point and mark; save as last killed one.
Calling from program, supply two args START and END, buffer positions.
But in programs you might prefer to use delete-extract-rectangle."
(interactive "r")
(setq killed-rectangle (delete-extract-rectangle start end)))
(defun yank-rectangle ()
"Yank the last killed rectangle with upper left corner at point."
(interactive)
(insert-rectangle killed-rectangle))
(defun insert-rectangle (rectangle)
"Insert text of RECTANGLE with upper left corner at point.
RECTANGLE's first line is inserted at point,
its second line is inserted at a point vertically under point, etc.
RECTANGLE should be a list of strings."
(let ((lines rectangle)
(insertcolumn (current-column))
(first t))
(while lines
(or first
(progn
(forward-line 1)
(or (bolp) (insert ?\n))
(move-to-column insertcolumn)
(if (> (current-column) insertcolumn)
(rectangle-coerce-tab insertcolumn))
(if (< (current-column) insertcolumn)
(indent-to insertcolumn))))
(setq first nil)
(insert (car lines))
(setq lines (cdr lines)))))
(defun open-rectangle (start end)
"Blank out rectangle with corners at point and mark, shifting text right.
The text previously in the region is not overwritten by the blanks,
but insted winds up to the right of the rectangle."
(interactive "r")
(operate-on-rectangle 'open-rectangle-line start end nil))
(defun open-rectangle-line (startpos begextra endextra)
(let ((column (+ (current-column) begextra endextra)))
(goto-char startpos)
(let ((ocol (current-column)))
(skip-chars-forward " \t")
(setq column (+ column (- (current-column) ocol))))
(delete-region (point)
(progn (skip-chars-backward " \t")
(point)))
(indent-to column)))
(defun clear-rectangle (start end)
"Blank out rectangle with corners at point and mark.
The text previously in the region is overwritten by the blanks.
When called from a program, requires two args which specify the corners."
(interactive "r")
(operate-on-rectangle 'clear-rectangle-line start end t))
(defun clear-rectangle-line (startpos begextra endextra)
(skip-chars-forward " \t")
(let ((column (+ (current-column) endextra)))
(delete-region (point)
(progn (goto-char startpos)
(skip-chars-backward " \t")
(point)))
(indent-to column)))
(defun rectangle-coerce-tab (column)
(let ((aftercol (current-column))
(indent-tabs-mode nil))
(delete-char -1)
(indent-to aftercol)
(backward-char (- aftercol column))))

51
lisp/tabify.el Normal file
View File

@ -0,0 +1,51 @@
;; Tab conversion commands for Emacs
;; Copyright (C) 1985 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 1, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
(defun untabify (start end)
"Convert all tabs in region to multiple spaces, preserving columns.
The variable tab-width controls the action."
(interactive "r")
(save-excursion
(save-restriction
(narrow-to-region start end)
(goto-char start)
(while (search-forward "\t" nil t) ; faster than re-search
(let ((start (point))
(column (current-column))
(indent-tabs-mode nil))
(skip-chars-backward "\t")
(delete-region start (point))
(indent-to column))))))
(defun tabify (start end)
"Convert multiple spaces in region to tabs when possible.
A group of spaces is partially replaced by tabs
when this can be done without changing the column they end at.
The variable tab-width controls the action."
(interactive "r")
(save-excursion
(save-restriction
(narrow-to-region start end)
(goto-char start)
(while (re-search-forward "[ \t][ \t][ \t]*" nil t)
(let ((column (current-column))
(indent-tabs-mode t))
(delete-region (match-beginning 0) (point))
(indent-to column))))))

203
lisp/textmodes/nroff-mode.el Normal file
View File

@ -0,0 +1,203 @@
;; GNU Emacs major mode for editing nroff source
;; Copyright (C) 1985, 1986 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 1, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
(defvar nroff-mode-abbrev-table nil
"Abbrev table used while in nroff mode.")
(defvar nroff-mode-map nil
"Major mode keymap for nroff-mode buffers")
(if (not nroff-mode-map)
(progn
(setq nroff-mode-map (make-sparse-keymap))
(define-key nroff-mode-map "\t" 'tab-to-tab-stop)
(define-key nroff-mode-map "\es" 'center-line)
(define-key nroff-mode-map "\e?" 'count-text-lines)
(define-key nroff-mode-map "\n" 'electric-nroff-newline)
(define-key nroff-mode-map "\en" 'forward-text-line)
(define-key nroff-mode-map "\ep" 'backward-text-line)))
(defun nroff-mode ()
"Major mode for editing text intended for nroff to format.
\\{nroff-mode-map}
Turning on Nroff mode runs text-mode-hook, then nroff-mode-hook.
Also, try nroff-electric-mode, for automatically inserting
closing requests for requests that are used in matched pairs."
(interactive)
(kill-all-local-variables)
(use-local-map nroff-mode-map)
(setq mode-name "Nroff")
(setq major-mode 'nroff-mode)
(set-syntax-table text-mode-syntax-table)
(setq local-abbrev-table nroff-mode-abbrev-table)
(make-local-variable 'nroff-electric-mode)
;; now define a bunch of variables for use by commands in this mode
(make-local-variable 'page-delimiter)
(setq page-delimiter "^\\.\\(bp\\|SK\\|OP\\)")
(make-local-variable 'paragraph-start)
(setq paragraph-start (concat "^[.']\\|" paragraph-start))
(make-local-variable 'paragraph-separate)
(setq paragraph-separate (concat "^[.']\\|" paragraph-separate))
;; comment syntax added by mit-erl!gildea 18 Apr 86
(make-local-variable 'comment-start)
(setq comment-start "\\\" ")
(make-local-variable 'comment-start-skip)
(setq comment-start-skip "\\\\\"[ \t]*")
(make-local-variable 'comment-column)
(setq comment-column 24)
(make-local-variable 'comment-indent-hook)
(setq comment-indent-hook 'nroff-comment-indent)
(run-hooks 'text-mode-hook 'nroff-mode-hook))
;;; Compute how much to indent a comment in nroff/troff source.
;;; By mit-erl!gildea April 86
(defun nroff-comment-indent ()
"Compute indent for an nroff/troff comment.
Puts a full-stop before comments on a line by themselves."
(let ((pt (point)))
(unwind-protect
(progn
(skip-chars-backward " \t")
(if (bolp)
(progn
(setq pt (1+ pt))
(insert ?.)
1)
(if (save-excursion
(backward-char 1)
(looking-at "^[.']"))
1
(max comment-column
(* 8 (/ (+ (current-column)
9) 8)))))) ; add 9 to ensure at least two blanks
(goto-char pt))))
(defun count-text-lines (start end &optional print)
"Count lines in region, except for nroff request lines.
All lines not starting with a period are counted up.
Interactively, print result in echo area.
Noninteractively, return number of non-request lines from START to END."
(interactive "r\np")
(if print
(message "Region has %d text lines" (count-text-lines start end))
(save-excursion
(save-restriction
(narrow-to-region start end)
(goto-char (point-min))
(- (buffer-size) (forward-text-line (buffer-size)))))))
(defun forward-text-line (&optional cnt)
"Go forward one nroff text line, skipping lines of nroff requests.
An argument is a repeat count; if negative, move backward."
(interactive "p")
(if (not cnt) (setq cnt 1))
(while (and (> cnt 0) (not (eobp)))
(forward-line 1)
(while (and (not (eobp)) (looking-at "[.']."))
(forward-line 1))
(setq cnt (- cnt 1)))
(while (and (< cnt 0) (not (bobp)))
(forward-line -1)
(while (and (not (bobp))
(looking-at "[.']."))
(forward-line -1))
(setq cnt (+ cnt 1)))
cnt)
(defun backward-text-line (&optional cnt)
"Go backward one nroff text line, skipping lines of nroff requests.
An argument is a repeat count; negative means move forward."
(interactive "p")
(forward-text-line (- cnt)))
(defconst nroff-brace-table
'((".(b" . ".)b")
(".(l" . ".)l")
(".(q" . ".)q")
(".(c" . ".)c")
(".(x" . ".)x")
(".(z" . ".)z")
(".(d" . ".)d")
(".(f" . ".)f")
(".LG" . ".NL")
(".SM" . ".NL")
(".LD" . ".DE")
(".CD" . ".DE")
(".BD" . ".DE")
(".DS" . ".DE")
(".DF" . ".DE")
(".FS" . ".FE")
(".KS" . ".KE")
(".KF" . ".KE")
(".LB" . ".LE")
(".AL" . ".LE")
(".BL" . ".LE")
(".DL" . ".LE")
(".ML" . ".LE")
(".RL" . ".LE")
(".VL" . ".LE")
(".RS" . ".RE")
(".TS" . ".TE")
(".EQ" . ".EN")
(".PS" . ".PE")
(".BS" . ".BE")
(".G1" . ".G2") ; grap
(".na" . ".ad b")
(".nf" . ".fi")
(".de" . "..")))
(defun electric-nroff-newline (arg)
"Insert newline for nroff mode; special if electric-nroff mode.
In electric-nroff-mode, if ending a line containing an nroff opening request,
automatically inserts the matching closing request after point."
(interactive "P")
(let ((completion (save-excursion
(beginning-of-line)
(and (null arg)
nroff-electric-mode
(<= (point) (- (point-max) 3))
(cdr (assoc (buffer-substring (point)
(+ 3 (point)))
nroff-brace-table)))))
(needs-nl (not (looking-at "[ \t]*$"))))
(if (null completion)
(newline (prefix-numeric-value arg))
(save-excursion
(insert "\n\n" completion)
(if needs-nl (insert "\n")))
(forward-char 1))))
(defun electric-nroff-mode (&optional arg)
"Toggle nroff-electric-newline minor mode
Nroff-electric-newline forces emacs to check for an nroff
request at the beginning of the line, and insert the
matching closing request if necessary.
This command toggles that mode (off->on, on->off),
with an argument, turns it on iff arg is positive, otherwise off."
(interactive "P")
(or (eq major-mode 'nroff-mode) (error "Must be in nroff mode"))
(or (assq 'nroff-electric-mode minor-mode-alist)
(setq minor-mode-alist (append minor-mode-alist
(list '(nroff-electric-mode
" Electric")))))
(setq nroff-electric-mode
(cond ((null arg) (null nroff-electric-mode))
(t (> (prefix-numeric-value arg) 0)))))

123
lisp/textmodes/page.el Normal file
View File

@ -0,0 +1,123 @@
;; Page motion commands for emacs.
;; Copyright (C) 1985 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 1, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
(defun forward-page (&optional count)
"Move forward to page boundary. With arg, repeat, or go back if negative.
A page boundary is any line whose beginning matches the regexp page-delimiter."
(interactive "p")
(or count (setq count 1))
(while (and (> count 0) (not (eobp)))
(if (re-search-forward page-delimiter nil t)
nil
(goto-char (point-max)))
(setq count (1- count)))
(while (and (< count 0) (not (bobp)))
(forward-char -1)
(if (re-search-backward page-delimiter nil t)
(goto-char (match-end 0))
(goto-char (point-min)))
(setq count (1+ count))))
(defun backward-page (&optional count)
"Move backward to page boundary. With arg, repeat, or go fwd if negative.
A page boundary is any line whose beginning matches the regexp page-delimiter."
(interactive "p")
(or count (setq count 1))
(forward-page (- count)))
(defun mark-page (&optional arg)
"Put mark at end of page, point at beginning.
A numeric arg specifies to move forward or backward by that many pages,
thus marking a page other than the one point was originally in."
(interactive "P")
(setq arg (if arg (prefix-numeric-value arg) 0))
(if (> arg 0)
(forward-page arg)
(if (< arg 0)
(forward-page (1- arg))))
(forward-page)
(push-mark nil t)
(forward-page -1))
(defun narrow-to-page (&optional arg)
"Make text outside current page invisible.
A numeric arg specifies to move forward or backward by that many pages,
thus showing a page other than the one point was originally in."
(interactive "P")
(setq arg (if arg (prefix-numeric-value arg) 0))
(save-excursion
(widen)
(if (> arg 0)
(forward-page arg)
(if (< arg 0)
(forward-page (1- arg))))
;; Find the end of the page.
(forward-page)
;; If we stopped due to end of buffer, stay there.
;; If we stopped after a page delimiter, put end of restriction
;; at the beginning of that line.
(if (save-excursion (beginning-of-line)
(looking-at page-delimiter))
(beginning-of-line))
(narrow-to-region (point)
(progn
;; Find the top of the page.
(forward-page -1)
;; If we found beginning of buffer, stay there.
;; If extra text follows page delimiter on same line,
;; include it.
;; Otherwise, show text starting with following line.
(if (and (eolp) (not (bobp)))
(forward-line 1))
(point)))))
(defun count-lines-page ()
"Report number of lines on current page, and how many are before or after point."
(interactive)
(save-excursion
(let ((opoint (point)) beg end
total before after)
(forward-page)
(beginning-of-line)
(or (looking-at page-delimiter)
(end-of-line))
(setq end (point))
(backward-page)
(setq beg (point))
(setq total (count-lines beg end)
before (count-lines beg opoint)
after (count-lines opoint end))
(message "Page has %d lines (%d + %d)" total before after))))
(defun what-page ()
"Print page and line number of point."
(interactive)
(save-restriction
(widen)
(save-excursion
(beginning-of-line)
(let ((count 1)
(opoint (point)))
(goto-char 1)
(while (re-search-forward page-delimiter opoint t)
(setq count (1+ count)))
(message "Page %d, line %d"
count
(1+ (count-lines (point) opoint)))))))

205
lisp/textmodes/paragraphs.el Normal file
View File

@ -0,0 +1,205 @@
;; Paragraph and sentence parsing.
;; Copyright (C) 1985 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 1, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
(defvar paragraph-ignore-fill-prefix nil
"Non-nil means the paragraph commands are not affected by fill-prefix.
This is desirable in modes where blank lines are the paragraph delimiters.")
(defun forward-paragraph (&optional arg)
"Move forward to end of paragraph.
With arg N, do it N times; negative arg -N means move forward N paragraphs.
A line which `paragraph-start' matches either separates paragraphs
\(if `paragraph-separate' matches it also) or is the first line of a paragraph.
A paragraph end is the beginning of a line which is not part of the paragraph
to which the end of the previous line belongs, or the end of the buffer."
(interactive "p")
(or arg (setq arg 1))
(let* ((fill-prefix-regexp
(and fill-prefix (not (equal fill-prefix ""))
(not paragraph-ignore-fill-prefix)
(regexp-quote fill-prefix)))
(paragraph-separate
(if fill-prefix-regexp
(concat paragraph-separate "\\|^"
fill-prefix-regexp "[ \t]*$")
paragraph-separate)))
(while (< arg 0)
(if (and (not (looking-at paragraph-separate))
(re-search-backward "^\n" (max (1- (point)) (point-min)) t))
nil
(forward-char -1) (beginning-of-line)
(while (and (not (bobp)) (looking-at paragraph-separate))
(forward-line -1))
(end-of-line)
;; Search back for line that starts or separates paragraphs.
(if (if fill-prefix-regexp
;; There is a fill prefix; it overrides paragraph-start.
(progn
(while (progn (beginning-of-line)
(and (not (bobp))
(not (looking-at paragraph-separate))
(looking-at fill-prefix-regexp)))
(forward-line -1))
(not (bobp)))
(re-search-backward paragraph-start nil t))
;; Found one.
(progn
(while (and (not (eobp)) (looking-at paragraph-separate))
(forward-line 1))
(if (eq (char-after (- (point) 2)) ?\n)
(forward-line -1)))
;; No starter or separator line => use buffer beg.
(goto-char (point-min))))
(setq arg (1+ arg)))
(while (> arg 0)
(beginning-of-line)
(while (prog1 (and (not (eobp))
(looking-at paragraph-separate))
(forward-line 1)))
(if fill-prefix-regexp
;; There is a fill prefix; it overrides paragraph-start.
(while (and (not (eobp))
(not (looking-at paragraph-separate))
(looking-at fill-prefix-regexp))
(forward-line 1))
(if (re-search-forward paragraph-start nil t)
(goto-char (match-beginning 0))
(goto-char (point-max))))
(setq arg (1- arg)))))
(defun backward-paragraph (&optional arg)
"Move backward to start of paragraph.
With arg N, do it N times; negative arg -N means move forward N paragraphs.
A paragraph start is the beginning of a line which is a first-line-of-paragraph
or which is ordinary text and follows a paragraph-separating line; except:
if the first real line of a paragraph is preceded by a blank line,
the paragraph starts at that blank line.
See forward-paragraph for more information."
(interactive "p")
(or arg (setq arg 1))
(forward-paragraph (- arg)))
(defun mark-paragraph ()
"Put point at beginning of this paragraph, mark at end.
The paragraph marked is the one that contains point or follows point."
(interactive)
(forward-paragraph 1)
(push-mark nil t)
(backward-paragraph 1))
(defun kill-paragraph (arg)
"Kill forward to end of paragraph.
With arg N, kill forward to Nth end of paragraph;
negative arg -N means kill backward to Nth start of paragraph."
(interactive "*p")
(kill-region (point) (progn (forward-paragraph arg) (point))))
(defun backward-kill-paragraph (arg)
"Kill back to start of paragraph.
With arg N, kill back to Nth start of paragraph;
negative arg -N means kill forward to Nth end of paragraph."
(interactive "*p")
(kill-region (point) (progn (backward-paragraph arg) (point))))
(defun transpose-paragraphs (arg)
"Interchange this (or next) paragraph with previous one."
(interactive "*p")
(transpose-subr 'forward-paragraph arg))
(defun start-of-paragraph-text ()
(let ((opoint (point)) npoint)
(forward-paragraph -1)
(setq npoint (point))
(skip-chars-forward " \t\n")
(if (>= (point) opoint)
(progn
(goto-char npoint)
(if (> npoint (point-min))
(start-of-paragraph-text))))))
(defun end-of-paragraph-text ()
(let ((opoint (point)))
(forward-paragraph 1)
(if (eq (preceding-char) ?\n) (forward-char -1))
(if (<= (point) opoint)
(progn
(forward-char 1)
(if (< (point) (point-max))
(end-of-paragraph-text))))))
(defun forward-sentence (&optional arg)
"Move forward to next sentence-end. With argument, repeat.
With negative argument, move backward repeatedly to sentence-beginning.
The variable `sentence-end' is a regular expression that matches ends
of sentences. Also, every paragraph boundary terminates sentences as
well."
(interactive "p")
(or arg (setq arg 1))
(while (< arg 0)
(let ((par-beg (save-excursion (start-of-paragraph-text) (point))))
(if (re-search-backward (concat sentence-end "[^ \t\n]") par-beg t)
(goto-char (1- (match-end 0)))
(goto-char par-beg)))
(setq arg (1+ arg)))
(while (> arg 0)
(let ((par-end (save-excursion (end-of-paragraph-text) (point))))
(if (re-search-forward sentence-end par-end t)
(skip-chars-backward " \t\n")
(goto-char par-end)))
(setq arg (1- arg))))
(defun backward-sentence (&optional arg)
"Move backward to start of sentence. With arg, do it arg times.
See forward-sentence for more information."
(interactive "p")
(or arg (setq arg 1))
(forward-sentence (- arg)))
(defun kill-sentence (&optional arg)
"Kill from point to end of sentence.
With arg, repeat; negative arg -N means kill back to Nth start of sentence."
(interactive "*p")
(let ((beg (point)))
(forward-sentence arg)
(kill-region beg (point))))
(defun backward-kill-sentence (&optional arg)
"Kill back from point to start of sentence.
With arg, repeat, or kill forward to Nth end of sentence if negative arg -N."
(interactive "*p")
(let ((beg (point)))
(backward-sentence arg)
(kill-region beg (point))))
(defun mark-end-of-sentence (arg)
"Put mark at end of sentence. Arg works as in forward-sentence."
(interactive "p")
(push-mark
(save-excursion
(forward-sentence arg)
(point))))
(defun transpose-sentences (arg)
"Interchange this (next) and previous sentence."
(interactive "*p")
(transpose-subr 'forward-sentence arg))

715
lisp/textmodes/refbib.el Normal file
View File

@ -0,0 +1,715 @@
;; Convert refer-style bibliographic entries to ones usable by latex bib
;; Copyright (C) 1989 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 1, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;; Use: from a buffer containing the refer-style bibliography,
;; M-x r2b-convert-buffer
;; Program will prompt for an output buffer name, and will log
;; warnings during the conversion process in the buffer *Log*.
; HISTORY
; 9/88, created
; modified 1/19/89, allow books with editor but no author;
; added %O ordering field;
; appended illegal multiple fields, instead of
; discarding;
; added rule, a tech report whose %R number
; contains "ISBN" is really a book
; added rule, anything with an editor is a book
; or a proceedings
; added 'manual type, for items with institution
; but no author or editor
; fixed bug so trailing blanks are trimmed
; added 'proceedings type
; used "organization" field for proceedings
; modified 2/16/89, updated help messages
; modified 2/23/89, include capitalize stop words in r2b stop words,
; fixed problems with contractions (e.g. it's),
; caught multiple stop words in a row
; modified 3/1/89, fixed capitialize-title for first words all caps
; modified 3/15/89, allow use of " to delimit fields
; modified 4/18/89, properly "quote" special characters on output
(provide 'refer-to-bibtex)
;**********************************************************
; User Parameters
(defvar r2b-trace-on nil "*trace conversion")
(defvar r2b-journal-abbrevs
'(
)
" Abbreviation list for journal names.
If the car of an element matches a journal name exactly, it is replaced by
the cadr when output. Braces must be included if replacement is a
{string}, but not if replacement is a bibtex abbreviation. The cadr
may be eliminated if is exactly the same as the car.
Because titles are capitalized before matching, the abbreviation
for the journal name should be listed as beginning with a capital
letter, even if it really doesn't.
For example, a value of '((\"Aij\" \"{Artificial Intelligence}\")
(\"Ijcai81\" \"ijcai7\")) would expand Aij to the text string
\"Artificial Intelligence\", but would replace Ijcai81 with the
BibTeX macro \"ijcai7\".")
(defvar r2b-booktitle-abbrevs
'(
)
" Abbreviation list for book and proceedings names. If the car of
an element matches a title or booktitle exactly, it is replaced by
the cadr when output. Braces must be included if replacement is
a {string}, but not if replacement is a bibtex abbreviation. The cadr
may be eliminated if is exactly the same as the car.
Because titles are capitalized before matching, the abbreviated title
should be listed as beginning with a capital letter, even if it doesn't.
For example, a value of '((\"Aij\" \"{Artificial Intelligence}\")
(\"Ijcai81\" \"ijcai7\")) would expand Aij to the text string
\"Artificial Intelligence\", but would replace Ijcai81 with the
BibTeX macro \"ijcai7\".")
(defvar r2b-proceedings-list
'()
" Assoc list of books or journals which are really conference proceedings,
but whose name and whose abbrev expansion (as defined in r2b-journal-abbrevs
and r2b-booktitle-abbrevs) does not contain the words 'conference' or
'proceedings'. (Those cases are handled automatically.)
The entry must match the given data exactly.
Because titles are capitalized before matching, the items in this list
should begin with a capital letter.
For example, suppose the title \"Ijcai81\" is used for the proceedings of
a conference, and it's expansion is the BibTeX macro \"ijcai7\". Then
r2b-proceedings-list should be '((\"Ijcai81\") ...). If instead its
expansion were \"Proceedings of the Seventh International Conference
on Artificial Intelligence\", then you would NOT need to include Ijcai81
in r2b-proceedings-list (although it wouldn't cause an error).")
(defvar r2b-additional-stop-words
"Some\\|What"
"Words other than the capitialize-title-stop-words
which are not to be used to build the citation key")
(defvar r2b-delimit-with-quote
t
"*If true, then use \" to delimit fields, otherwise use braces")
;**********************************************************
; Utility Functions
(defvar capitalize-title-stop-words
(concat
"the\\|and\\|of\\|is\\|a\\|an\\|of\\|for\\|in\\|to\\|in\\|on\\|at\\|"
"by\\|with\\|that\\|its")
"Words not to be capitialized in a title (unless they are the first
word in the title)")
(defvar capitalize-title-stop-regexp
(concat "\\(" capitalize-title-stop-words "\\)\\(\\b\\|'\\)"))
(defun capitalize-title-region (begin end)
"Like capitalize-region, but don't capitalize stop words, except the first"
(interactive "r")
(let ((case-fold-search nil) (orig-syntax-table (syntax-table)))
(unwind-protect
(save-restriction
(set-syntax-table text-mode-syntax-table)
(narrow-to-region begin end)
(goto-char (point-min))
(if (looking-at "[A-Z][a-z]*[A-Z]")
(forward-word 1)
(capitalize-word 1))
(while (re-search-forward "\\<" nil t)
(if (looking-at "[A-Z][a-z]*[A-Z]")
(forward-word 1)
(if (let ((case-fold-search t))
(looking-at capitalize-title-stop-regexp))
(downcase-word 1)
(capitalize-word 1)))
))
(set-syntax-table orig-syntax-table))))
(defun capitalize-title (s)
"Like capitalize, but don't capitalize stop words, except the first"
(save-excursion
(set-buffer (get-buffer-create "$$$Scratch$$$"))
(erase-buffer)
(insert s)
(capitalize-title-region (point-min) (point-max))
(buffer-string)))
;*********************************************************
(defun r2b-reset ()
"unbind defvars, for debugging"
(interactive)
(makunbound 'r2b-journal-abbrevs)
(makunbound 'r2b-booktitle-abbrevs)
(makunbound 'r2b-proceedings-list)
(makunbound 'capitalize-title-stop-words)
(makunbound 'capitalize-title-stop-regexp)
(makunbound 'r2b-additional-stop-words)
(makunbound 'r2b-stop-regexp)
)
(defvar r2b-stop-regexp
(concat "\\`\\(\\("
r2b-additional-stop-words "\\|" capitalize-title-stop-words
"\\)\\('\\w*\\)?\\W+\\)*\\([A-Z0-9]+\\)"))
(defun r2b-trace (&rest args)
(if r2b-trace-on
(progn
(apply (function message) args)
(sit-for 0)
)))
(defun r2b-match (exp)
"returns string matched in current buffer"
(buffer-substring (match-beginning exp) (match-end exp)))
(defvar r2b-out-buf-name "*Out*" "*output from refer-to-bibtex" )
(defvar r2b-log-name "*Log*" "*logs errors from refer-to-bibtex" )
(defvar r2b-in-buf nil)
(defvar r2b-out-buf nil)
(defvar r2b-log nil)
(defvar r2b-error-found nil)
(setq r2b-variables '(
r2b-error-found
r2bv-author
r2bv-primary-author
r2bv-date
r2bv-year
r2bv-decade
r2bv-month
r2bv-title
r2bv-title-first-word
r2bv-editor
r2bv-annote
r2bv-tr
r2bv-address
r2bv-institution
r2bv-keywords
r2bv-booktitle
r2bv-journal
r2bv-volume
r2bv-number
r2bv-pages
r2bv-booktitle
r2bv-kn
r2bv-publisher
r2bv-organization
r2bv-school
r2bv-type
r2bv-where
r2bv-note
r2bv-ordering
))
(defun r2b-clear-variables ()
"set all global vars used by r2b to nil"
(let ((vars r2b-variables))
(while vars
(set (car vars) nil)
(setq vars (cdr vars)))
))
(defun r2b-warning (&rest args)
(setq r2b-error-found t)
(princ (apply (function format) args) r2b-log)
(princ "\n" r2b-log)
(princ "\n" r2b-out-buf)
(princ "% " r2b-out-buf)
(princ (apply (function format) args) r2b-out-buf)
)
(defun r2b-get-field (var field &optional unique required capitalize)
"Set VAR to string value of FIELD, if any. If none, VAR is set to
nil. If multiple fields appear, then separate values with the
'\\nand\\t\\t', unless UNIQUE is non-nil, in which case log a warning
and just concatenate the values. Trim off leading blanks and tabs on
first line, and trailing blanks and tabs of every line. Log a warning
and set VAR to the empty string if REQUIRED is true. Capitalize as a
title if CAPITALIZE is true. Returns value of VAR."
(let (item val (not-past-end t))
(r2b-trace "snarfing %s" field)
(goto-char (point-min))
(while (and not-past-end
(re-search-forward
(concat "^" field "\\b[ \t]*\\(.*[^ \t\n]\\)[ \t]*") nil t))
(setq item (r2b-match 1))
(while (and (setq not-past-end (zerop (forward-line 1)))
(not (looking-at "[ \t]*$\\|%")))
(looking-at "\\(.*[^ \t\n]\\)[ \t]*$")
(setq item (concat item "\n" (r2b-match 1)))
)
(if (null val)
(setq val item)
(if unique
(progn
(r2b-warning "*Illegal multiple field %s %s" field item)
(setq val (concat val "\n" item))
)
(setq val (concat val "\n\t\tand " item))
)
)
)
(if (and val capitalize)
(setq val (capitalize-title val)))
(set var val)
(if (and (null val) required)
(r2b-require var))
))
(defun r2b-set-match (var n regexp string )
"set VAR to the Nth subpattern in REGEXP matched by STRING, or nil if none"
(set var
(if (and (stringp string) (string-match regexp string))
(substring string (match-beginning n) (match-end n))
nil)
)
)
(defvar r2b-month-abbrevs
'(("jan") ("feb") ("mar") ("apr") ("may") ("jun") ("jul") ("aug")
("sep") ("oct") ("nov") ("dec")))
(defun r2b-convert-month ()
"Try to convert r2bv-month to a standard 3 letter name"
(if r2bv-month
(let ((months r2b-month-abbrevs))
(if (string-match "[^0-9]" r2bv-month)
(progn
(while (and months (not (string-match (car (car months))
r2bv-month)))
(setq months (cdr months)))
(if months
(setq r2bv-month (car (car months)))))
(progn
(setq months (car (read-from-string r2bv-month)))
(if (and (numberp months)
(> months 0)
(< months 13))
(setq r2bv-month (car (nth months r2b-month-abbrevs)))
(progn
(r2b-warning "* Ridiculous month")
(setq r2bv-month nil))
))
))
)
)
(defun r2b-snarf-input ()
"parse buffer into global variables"
(let ((case-fold-search t))
(r2b-trace "snarfing...")
(sit-for 0)
(set-buffer r2b-in-buf)
(goto-char (point-min))
(princ " " r2b-log)
(princ (buffer-substring (point) (progn (end-of-line) (point))) r2b-log)
(terpri r2b-log)
(r2b-get-field 'r2bv-author "%A")
(r2b-get-field 'r2bv-editor "%E")
(cond
(r2bv-author
(r2b-set-match 'r2bv-primary-author 1
"\\b\\(\\w+\\)[ \t]*\\($\\|,\\)" r2bv-author)
)
(r2bv-editor
(r2b-set-match 'r2bv-primary-author 1
"\\b\\(\\w+\\)[ \t]*\\($\\|,\\)" r2bv-editor)
)
(t
(setq r2bv-primary-author "")
)
)
(r2b-get-field 'r2bv-date "%D" t t)
(r2b-set-match 'r2bv-year 0 "[12][0-9][0-9][0-9]" r2bv-date)
(and (null r2bv-year)
(r2b-set-match 'r2bv-year 1 "[^0-9]\\([0-9][0-9]\\)$" r2bv-date)
(setq r2bv-year (concat "19" r2bv-year)))
(r2b-set-match 'r2bv-decade 1 "..\\(..\\)" r2bv-year)
(r2b-set-match 'r2bv-month 0
"[0-9]+/\\|[a-zA-Z]+" r2bv-date)
(if (and (stringp r2bv-month) (string-match "\\(.*\\)/$" r2bv-month))
(setq r2bv-month (substring r2bv-month 0 (match-end 1))))
(r2b-convert-month)
(r2b-get-field 'r2bv-title "%T" t t t)
(r2b-set-match 'r2bv-title-first-word 4
r2b-stop-regexp
r2bv-title)
(r2b-get-field 'r2bv-annote "%X" t )
(r2b-get-field 'r2bv-tr "%R" t)
(r2b-get-field 'r2bv-address "%C" t)
(r2b-get-field 'r2bv-institution "%I" t)
(r2b-get-field 'r2bv-keywords "%K")
(r2b-get-field 'r2bv-booktitle "%B" t nil t)
(r2b-get-field 'r2bv-journal "%J" t nil t)
(r2b-get-field 'r2bv-volume "%V" t)
(r2b-get-field 'r2bv-number "%N" t)
(r2b-get-field 'r2bv-pages "%P" t)
(r2b-get-field 'r2bv-where "%W" t)
(r2b-get-field 'r2bv-ordering "%O" t)
)
)
(defun r2b-put-field (field data &optional abbrevs)
"print bibtex FIELD = {DATA} if DATA not null; precede
with a comma and newline; if ABBREVS list is given, then
try to replace the {DATA} with an abbreviation"
(if data
(let (match nodelim multi-line index)
(cond
((and abbrevs (setq match (assoc data abbrevs)))
(if (null (cdr match))
(setq data (car match))
(setq data (car (cdr match))))
(setq nodelim t))
((and (not (equal data ""))
(not (string-match "[^0-9]" data)))
(setq nodelim t))
(t
(setq index 0)
(while (string-match "[\\~^]" data index)
(setq data (concat (substring data 0 (match-beginning 0))
"\\verb+"
(substring data (match-beginning 0) (match-end 0))
"+"
(substring data (match-end 0))))
(setq index (+ (match-end 0) 7)))
(setq index 0)
(while (string-match "[$&%#_{}]" data index)
(setq data (concat (substring data 0 (match-beginning 0))
"\\"
(substring data (match-beginning 0))))
(setq index (+ (match-end 0) 1)))
(setq index 0)
(if r2b-delimit-with-quote
(while (string-match "\"" data index)
(setq data (concat (substring data 0 (match-beginning 0))
"{\"}"
(substring data (match-end 0))))
(setq index (+ (match-end 0) 2))))
))
(princ ", \n ")
(princ field)
(princ " =\t")
(if (not nodelim)
(if r2b-delimit-with-quote
(princ "\"")
(princ "{")))
(string-match ".*" data)
(if (> (match-end 0) 59)
(princ "\n"))
(princ data)
(if (not nodelim)
(if r2b-delimit-with-quote
(princ "\"")
(princ "}")))
)
))
(defun r2b-require (vars)
"If any of VARS is null, set to empty string and log error"
(cond
((null vars))
((listp vars) (r2b-require (car vars)) (r2b-require (cdr vars)))
(t
(if (null (symbol-value vars))
(progn
(r2b-warning "*Missing value for field %s" vars)
(set vars "")
)))
)
)
(defmacro r2b-moveq (new old)
"set NEW to OLD and set OLD to nil"
(list 'progn (list 'setq new old) (list 'setq old 'nil)))
(defun r2b-isa-proceedings (name)
"return t if NAME is the name of proceedings"
(and
name
(or
(string-match "proceedings\\|conference" name)
(assoc name r2b-proceedings-list)
(let ((match (assoc name r2b-booktitle-abbrevs)))
(and match
(string-match "proceedings\\|conference" (car (cdr match)))))
)))
(defun r2b-isa-university (name)
"return t if NAME is a university or similar organization,
but not a publisher"
(and
name
(string-match "university" name)
(not (string-match "press" name))
))
(defun r2b-barf-output ()
"generate bibtex based on global variables"
(let ((standard-output r2b-out-buf) (case-fold-search t) match)
(r2b-trace "...barfing")
(sit-for 0)
(set-buffer r2b-out-buf)
(setq r2bv-kn (concat r2bv-primary-author r2bv-decade
r2bv-title-first-word))
(setq r2bv-entry-kind
(cond
((r2b-isa-proceedings r2bv-journal)
(r2b-moveq r2bv-booktitle r2bv-journal)
(if (r2b-isa-university r2bv-institution)
(r2b-moveq r2bv-organization r2bv-institution)
(r2b-moveq r2bv-publisher r2bv-institution))
(r2b-moveq r2bv-note r2bv-tr)
(r2b-require 'r2bv-author)
'inproceedings)
((r2b-isa-proceedings r2bv-booktitle)
(if (r2b-isa-university r2bv-institution)
(r2b-moveq r2bv-organization r2bv-institution)
(r2b-moveq r2bv-publisher r2bv-institution))
(r2b-moveq r2bv-note r2bv-tr)
(r2b-require 'r2bv-author)
'inproceedings)
((and r2bv-tr (string-match "phd" r2bv-tr))
(r2b-moveq r2bv-school r2bv-institution)
(r2b-require 'r2bv-school )
(r2b-require 'r2bv-author)
'phdthesis)
((and r2bv-tr (string-match "master" r2bv-tr))
(r2b-moveq r2bv-school r2bv-institution)
(r2b-require 'r2bv-school )
(r2b-require 'r2bv-author)
'mastersthesis)
((and r2bv-tr (string-match "draft\\|unpublish" r2bv-tr))
(r2b-moveq r2bv-note r2bv-institution)
(r2b-require 'r2bv-author)
'unpublished)
(r2bv-journal
(r2b-require 'r2bv-author)
'article)
(r2bv-booktitle
(r2b-moveq r2bv-publisher r2bv-institution)
(r2b-moveq r2bv-note r2bv-tr)
(r2b-require 'r2bv-publisher)
(r2b-require 'r2bv-author)
'incollection)
((and r2bv-author
(null r2bv-editor)
(string-match "\\`personal communication\\'" r2bv-title))
'misc)
((r2b-isa-proceedings r2bv-title)
(if (r2b-isa-university r2bv-institution)
(r2b-moveq r2bv-organization r2bv-institution)
(r2b-moveq r2bv-publisher r2bv-institution))
(r2b-moveq r2bv-note r2bv-tr)
'proceedings)
((or r2bv-editor
(and r2bv-author
(or
(null r2bv-tr)
(string-match "\\bisbn\\b" r2bv-tr))))
(r2b-moveq r2bv-publisher r2bv-institution)
(r2b-moveq r2bv-note r2bv-tr)
(r2b-require 'r2bv-publisher)
(if (null r2bv-editor)
(r2b-require 'r2bv-author))
'book)
(r2bv-tr
(r2b-require 'r2bv-institution)
(if (string-match
"\\`\\(\\(.\\|\n\\)+\\)[ \t\n]+\\([^ \t\n]\\)+\\'"
r2bv-tr)
(progn
(setq r2bv-type (substring r2bv-tr 0 (match-end 1)))
(setq r2bv-number (substring r2bv-tr
(match-beginning 3)))
(setq r2bv-tr nil))
(r2b-moveq r2bv-number r2bv-tr))
(r2b-require 'r2bv-author)
'techreport)
(r2bv-institution
(r2b-moveq r2bv-organization r2bv-institution)
'manual)
(t
'misc)
))
(r2b-require '( r2bv-year))
(if r2b-error-found
(princ "\n% Warning -- Errors During Conversion Next Entry\n"))
(princ "\n@")
(princ r2bv-entry-kind)
(princ "( ")
(princ r2bv-kn)
(r2b-put-field "author" r2bv-author )
(r2b-put-field "title" r2bv-title r2b-booktitle-abbrevs)
(r2b-put-field "year" r2bv-year )
(r2b-put-field "month" r2bv-month r2b-month-abbrevs)
(r2b-put-field "journal" r2bv-journal r2b-journal-abbrevs)
(r2b-put-field "volume" r2bv-volume)
(r2b-put-field "type" r2bv-type)
(r2b-put-field "number" r2bv-number)
(r2b-put-field "booktitle" r2bv-booktitle r2b-booktitle-abbrevs)
(r2b-put-field "editor" r2bv-editor)
(r2b-put-field "publisher" r2bv-publisher)
(r2b-put-field "institution" r2bv-institution)
(r2b-put-field "organization" r2bv-organization)
(r2b-put-field "school" r2bv-school)
(r2b-put-field "pages" r2bv-pages)
(r2b-put-field "address" r2bv-address)
(r2b-put-field "note" r2bv-note)
(r2b-put-field "keywords" r2bv-keywords)
(r2b-put-field "where" r2bv-where)
(r2b-put-field "ordering" r2bv-ordering)
(r2b-put-field "annote" r2bv-annote)
(princ " )\n")
)
)
(defun r2b-convert-record (output-name)
"transform current bib entry and append to buffer OUTPUT;
do M-x r2b-help for more info"
(interactive
(list (read-string "Output to buffer: " r2b-out-buf-name)))
(let (rec-end rec-begin not-done)
(setq r2b-out-buf-name output-name)
(setq r2b-out-buf (get-buffer-create output-name))
(setq r2b-in-buf (current-buffer))
(set-buffer r2b-out-buf)
(goto-char (point-max))
(setq r2b-log (get-buffer-create r2b-log-name))
(set-buffer r2b-log)
(goto-char (point-max))
(set-buffer r2b-in-buf)
(setq not-done (re-search-forward "[^ \t\n]" nil t))
(if not-done
(progn
(re-search-backward "^[ \t]*$" nil 2)
(re-search-forward "^%")
(beginning-of-line nil)
(setq rec-begin (point))
(re-search-forward "^[ \t]*$" nil 2)
(setq rec-end (point))
(narrow-to-region rec-begin rec-end)
(r2b-clear-variables)
(r2b-snarf-input)
(r2b-barf-output)
(set-buffer r2b-in-buf)
(widen)
(goto-char rec-end)
t)
nil
)
))
(defun r2b-convert-buffer (output-name)
"transform current buffer and append to buffer OUTPUT;
do M-x r2b-help for more info"
(interactive
(list (read-string "Output to buffer: " r2b-out-buf-name)))
(save-excursion
(setq r2b-log (get-buffer-create r2b-log-name))
(set-buffer r2b-log)
(erase-buffer))
(widen)
(goto-char (point-min))
(message "Working, please be patient...")
(sit-for 0)
(while (r2b-convert-record output-name) t)
(message "Done, results in %s, errors in %s"
r2b-out-buf-name r2b-log-name)
)
(defvar r2b-load-quietly nil "*Don't print help message when loaded")
(defvar r2b-help-message
" Refer to Bibtex Bibliography Conversion
A refer-style database is of the form:
%A Joe Blow
%T Great Thoughts I've Thought
%D 1977
etc.
This utility converts these kind of databases to bibtex form, for
users of TeX and LaTex. Instructions:
1. Visit the file containing the refer-style database.
2. The command
M-x r2b-convert-buffer
converts the entire buffer, appending it's output by default in a
buffer named *Out*, and logging progress and errors in a buffer
named *Log*. The original file is never modified.
Note that results are appended to *Out*, so if that buffer
buffer already exists and contains material you don't want to
save, you should kill it first.
3. Switch to the buffer *Out* and save it as a named file.
4. To convert a single refer-style entry, simply position the cursor
at the entry and enter
M-x r2b-convert-record
Again output is appended to *Out* and errors are logged in *Log*.
This utility is very robust and pretty smart about determining the
type of the entry. It includes facilities for expanding refer macros
to text, or substituting bibtex macros. Do M-x describe-variable on
r2b-journal-abbrevs
r2b-booktitle-abbrevs
r2b-proceedings-list
for information on these features.
If you don't want to see this help message when you load this utility,
then include the following line in your .emacs file:
(setq r2b-load-quietly t)
To see this message again, perform
M-x r2b-help")
(defun r2b-help ()
"print help message"
(interactive)
(with-output-to-temp-buffer "*Help*"
(princ r2b-help-message)))
(if (not r2b-load-quietly)
(r2b-help))
(message "r2b loaded")

132
lisp/textmodes/spell.el Normal file
View File

@ -0,0 +1,132 @@
;; Spelling correction interface for Emacs.
;; Copyright (C) 1985 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 1, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
(defvar spell-command "spell"
"*Command to run the spell program.")
(defvar spell-filter nil
"*Filter function to process text before passing it to spell program.
This function might remove text-processor commands.
nil means don't alter the text before checking it.")
(defun spell-buffer ()
"Check spelling of every word in the buffer.
For each incorrect word, you are asked for the correct spelling
and then put into a query-replace to fix some or all occurrences.
If you do not want to change a word, just give the same word
as its \"correct\" spelling; then the query replace is skipped."
(interactive)
(spell-region (point-min) (point-max) "buffer"))
(defun spell-word ()
"Check spelling of word at or before point.
If it is not correct, ask user for the correct spelling
and query-replace the entire buffer to substitute it."
(interactive)
(let (beg end spell-filter)
(save-excursion
(if (not (looking-at "\\<"))
(forward-word -1))
(setq beg (point))
(forward-word 1)
(setq end (point)))
(spell-region beg end (buffer-substring beg end))))
(defun spell-region (start end &optional description)
"Like spell-buffer but applies only to region.
Used in a program, applies from START to END.
DESCRIPTION is an optional string naming the unit being checked:
for example, \"word\"."
(interactive "r")
(let ((filter spell-filter)
(buf (get-buffer-create " *temp*")))
(save-excursion
(set-buffer buf)
(widen)
(erase-buffer))
(message "Checking spelling of %s..." (or description "region"))
(if (and (null filter) (= ?\n (char-after (1- end))))
(if (string= "spell" spell-command)
(call-process-region start end "spell" nil buf)
(call-process-region start end shell-file-name
nil buf nil "-c" spell-command))
(let ((oldbuf (current-buffer)))
(save-excursion
(set-buffer buf)
(insert-buffer-substring oldbuf start end)
(or (bolp) (insert ?\n))
(if filter (funcall filter))
(if (string= "spell" spell-command)
(call-process-region (point-min) (point-max) "spell" t buf)
(call-process-region (point-min) (point-max) shell-file-name
t buf nil "-c" spell-command)))))
(message "Checking spelling of %s...%s"
(or description "region")
(if (save-excursion
(set-buffer buf)
(> (buffer-size) 0))
"not correct"
"correct"))
(let (word newword
(case-fold-search t)
(case-replace t))
(while (save-excursion
(set-buffer buf)
(> (buffer-size) 0))
(save-excursion
(set-buffer buf)
(goto-char (point-min))
(setq word (downcase
(buffer-substring (point)
(progn (end-of-line) (point)))))
(forward-char 1)
(delete-region (point-min) (point))
(setq newword
(read-input (concat "`" word
"' not recognized; edit a replacement: ")
word))
(flush-lines (concat "^" (regexp-quote word) "$")))
(if (not (equal word newword))
(progn
(goto-char (point-min))
(query-replace-regexp (concat "\\b" (regexp-quote word) "\\b")
newword)))))))
(defun spell-string (string)
"Check spelling of string supplied as argument."
(interactive "sSpell string: ")
(let ((buf (get-buffer-create " *temp*")))
(save-excursion
(set-buffer buf)
(widen)
(erase-buffer)
(insert string "\n")
(if (string= "spell" spell-command)
(call-process-region (point-min) (point-max) "spell"
t t)
(call-process-region (point-min) (point-max) shell-file-name
t t nil "-c" spell-command))
(if (= 0 (buffer-size))
(message "%s is correct" string)
(goto-char (point-min))
(while (search-forward "\n" nil t)
(replace-match " "))
(message "%sincorrect" (buffer-substring 1 (point-max)))))))

147
lisp/textmodes/text-mode.el Normal file
View File

@ -0,0 +1,147 @@
;; Text mode, and its ideosyncratic commands.
;; Copyright (C) 1985 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 1, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
(defvar text-mode-syntax-table nil
"Syntax table used while in text mode.")
(defvar text-mode-abbrev-table nil
"Abbrev table used while in text mode.")
(define-abbrev-table 'text-mode-abbrev-table ())
(if text-mode-syntax-table
()
(setq text-mode-syntax-table (make-syntax-table))
(modify-syntax-entry ?\" ". " text-mode-syntax-table)
(modify-syntax-entry ?\\ ". " text-mode-syntax-table)
(modify-syntax-entry ?' "w " text-mode-syntax-table))
(defvar text-mode-map nil
"Keymap for Text mode.
Many other modes, such as Mail mode, Outline mode and Indented Text mode,
inherit all the commands defined in this map.")
(if text-mode-map
()
(setq text-mode-map (make-sparse-keymap))
(define-key text-mode-map "\t" 'tab-to-tab-stop)
(define-key text-mode-map "\es" 'center-line)
(define-key text-mode-map "\eS" 'center-paragraph))
;(defun non-saved-text-mode ()
; "Like text-mode, but delete auto save file when file is saved for real."
; (text-mode)
; (make-local-variable 'delete-auto-save-files)
; (setq delete-auto-save-files t))
(defun text-mode ()
"Major mode for editing text intended for humans to read. Special commands:\\{text-mode-map}
Turning on text-mode calls the value of the variable `text-mode-hook',
if that value is non-nil."
(interactive)
(kill-all-local-variables)
(use-local-map text-mode-map)
(setq mode-name "Text")
(setq major-mode 'text-mode)
(setq local-abbrev-table text-mode-abbrev-table)
(set-syntax-table text-mode-syntax-table)
(run-hooks 'text-mode-hook))
(defvar indented-text-mode-map ()
"Keymap for Indented Text mode.
All the commands defined in Text mode are inherited unless overridden.")
(if indented-text-mode-map
()
(setq indented-text-mode-map (nconc (make-sparse-keymap) text-mode-map))
(define-key indented-text-mode-map "\t" 'indent-relative))
(defun indented-text-mode ()
"Major mode for editing indented text intended for humans to read.\\{indented-text-mode-map}
Turning on indented-text-mode calls the value of the variable `text-mode-hook',
if that value is non-nil."
(interactive)
(kill-all-local-variables)
(use-local-map text-mode-map)
(define-abbrev-table 'text-mode-abbrev-table ())
(setq local-abbrev-table text-mode-abbrev-table)
(set-syntax-table text-mode-syntax-table)
(make-local-variable 'indent-line-function)
(setq indent-line-function 'indent-relative-maybe)
(use-local-map indented-text-mode-map)
(setq mode-name "Indented Text")
(setq major-mode 'indented-text-mode)
(run-hooks 'text-mode-hook))
(defun change-log-mode ()
"Major mode for editing ChangeLog files. See M-x add-change-log-entry.
Almost the same as Indented Text mode, but prevents numeric backups
and sets `left-margin' to 8 and `fill-column' to 74."
(interactive)
(indented-text-mode)
(setq left-margin 8)
(setq fill-column 74)
(make-local-variable 'version-control)
(setq version-control 'never)
(run-hooks 'change-log-mode-hook))
(defun center-paragraph ()
"Center each nonblank line in the paragraph at or after point.
See center-line for more info."
(interactive)
(save-excursion
(forward-paragraph)
(or (bolp) (newline 1))
(let ((end (point)))
(backward-paragraph)
(center-region (point) end))))
(defun center-region (from to)
"Center each nonblank line starting in the region.
See center-line for more info."
(interactive "r")
(if (> from to)
(let ((tem to))
(setq to from from tem)))
(save-excursion
(save-restriction
(narrow-to-region from to)
(goto-char from)
(while (not (eobp))
(or (save-excursion (skip-chars-forward " \t") (eolp))
(center-line))
(forward-line 1)))))
(defun center-line ()
"Center the line point is on, within the width specified by `fill-column'.
This means adjusting the indentation so that it equals
the distance between the end of the text and `fill-column'."
(interactive)
(save-excursion
(let (line-length)
(beginning-of-line)
(delete-horizontal-space)
(end-of-line)
(delete-horizontal-space)
(setq line-length (current-column))
(beginning-of-line)
(indent-to
(+ left-margin
(/ (- fill-column left-margin line-length) 2))))))

46
lisp/textmodes/underline.el Normal file
View File

@ -0,0 +1,46 @@
;; Insert or remove underlining (done by overstriking) in Emacs.
;; Copyright (C) 1985 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 1, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
(defun underline-region (start end)
"Underline all nonblank characters in the region.
Works by overstriking underscores.
Called from program, takes two arguments START and END
which specify the range to operate on."
(interactive "r")
(save-excursion
(let ((end1 (make-marker)))
(move-marker end1 (max start end))
(goto-char (min start end))
(while (< (point) end1)
(or (looking-at "[_\^@- ]")
(insert "_"))
(forward-char 1)))))
(defun ununderline-region (start end)
"Remove all underlining (overstruck underscores) in the region.
Called from program, takes two arguments START and END
which specify the range to operate on."
(interactive "r")
(save-excursion
(let ((end1 (make-marker)))
(move-marker end1 (max start end))
(goto-char (min start end))
(while (re-search-forward "_\\|_" end1 t)
(delete-char -2)))))

124
lisp/userlock.el Normal file
View File

@ -0,0 +1,124 @@
;; Copyright (C) 1985, 1986 Free Software Foundation, inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 1, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;; This file is autloaded to handle certain conditions
;; detected by the file-locking code within Emacs.
;; The two entry points are `ask-user-about-lock' and
;; `ask-user-about-supersession-threat'.
(put 'file-locked 'error-conditions '(file-locked file-error error))
(defun ask-user-about-lock (fn opponent)
"Ask user what to do when he wants to edit FILE but it is locked by USER.
This function has a choice of three things to do:
do (signal 'buffer-file-locked (list FILE USER))
to refrain from editing the file
return t (grab the lock on the file)
return nil (edit the file even though it is locked).
You can rewrite it to use any criterion you like to choose which one to do."
(discard-input)
(save-window-excursion
(let (answer)
(while (null answer)
(message "%s is locking %s: action (s, q, p, ?)? " opponent fn)
(let ((tem (let ((inhibit-quit t)
(cursor-in-echo-area t))
(prog1 (downcase (read-char))
(setq quit-flag nil)))))
(if (= tem help-char)
(ask-user-about-lock-help)
(setq answer (assoc tem '((?s . t)
(?q . yield)
(?\C-g . yield)
(?p . nil)
(?? . help))))
(cond ((null answer)
(beep)
(message "Please type q, s, or p; or ? for help")
(sit-for 3))
((eq (cdr answer) 'help)
(ask-user-about-lock-help)
(setq answer nil))
((eq (cdr answer) 'yield)
(signal 'file-locked (list "File is locked" fn opponent)))))))
(cdr answer))))
(defun ask-user-about-lock-help ()
(with-output-to-temp-buffer "*Help*"
(princ "It has been detected that you want to modify a file that someone else has
already started modifying in EMACS.
You can <s>teal the file; The other user becomes the
intruder if (s)he ever unmodifies the file and then changes it again.
You can <p>roceed; you edit at your own (and the other user's) risk.
You can <q>uit; don't modify this file.")))
(put
'file-supersession 'error-conditions '(file-supersession file-error error))
(defun ask-user-about-supersession-threat (fn)
"Ask a user who is about to modify an obsolete buffer what to do.
This function has two choices: it can return, in which case the modification
of the buffer will proceed, or it can (signal 'file-supersession (file)),
in which case the proposed buffer modification will not be made.
You can rewrite this to use any criterion you like to choose which one to do.
The buffer in question is current when this function is called."
(discard-input)
(save-window-excursion
(let (answer)
(while (null answer)
(message "File has changed on disk; really want to edit the buffer? (y, n or C-h) ")
(let ((tem (downcase (let ((cursor-in-echo-area t))
(read-char)))))
(setq answer
(if (= tem help-char)
'help
(cdr (assoc tem '((?n . yield)
(?\C-g . yield)
(?y . proceed)
(?? . help))))))
(cond ((null answer)
(beep)
(message "Please type y or n; or ? for help")
(sit-for 3))
((eq answer 'help)
(ask-user-about-supersession-help)
(setq answer nil))
((eq answer 'yield)
(signal 'file-supersession
(list "File changed on disk" fn))))))
(message
"File on disk now will become a backup file if you save these changes.")
(setq buffer-backed-up nil))))
(defun ask-user-about-supersession-help ()
(with-output-to-temp-buffer "*Help*"
(princ "You want to modify a buffer whose disk file has changed
since you last read it in or saved it with this buffer.
If you say `y' to go ahead and modify this buffer,
you risk ruining the work of whoever rewrote the file.
If you say `n', the change you started to make will be aborted.
Usually, you should type `n' and then `M-x revert-buffer',
to get the latest version of the file, then make the change again.")))

99
lisp/vms-patch.el Normal file
View File

@ -0,0 +1,99 @@
;; Override parts of files.el for VMS.
;; 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.
;;; Functions that need redefinition
;;; VMS file names are upper case, but buffer names are more
;;; convenient in lower case.
(defun create-file-buffer (filename)
"Create a suitably named buffer for visiting FILENAME, and return it.
FILENAME (sans directory) is used unchanged if that name is free;
otherwise a string <2> or <3> or ... is appended to get an unused name."
(generate-new-buffer (downcase (file-name-nondirectory filename))))
;;; Given a string FN, return a similar name which is a legal VMS filename.
;;; This is used to avoid invalid auto save file names.
(defun make-legal-file-name (fn)
(setq fn (copy-sequence fn))
(let ((dot nil) (indx 0) (len (length fn)) chr)
(while (< indx len)
(setq chr (aref fn indx))
(cond
((eq chr ?.) (if dot (aset fn indx ?_) (setq dot t)))
((not (or (and (>= chr ?a) (<= chr ?z)) (and (>= chr ?A) (<= chr ?Z))
(and (>= chr ?0) (<= chr ?9))
(eq chr ?$) (eq chr ?_) (and (eq chr ?-) (> indx 0))))
(aset fn indx ?_)))
(setq indx (1+ indx))))
fn)
;;; Auto save filesnames start with _$ and end with $.
(defun make-auto-save-file-name ()
"Return file name to use for auto-saves of current buffer.
Does not consider auto-save-visited-file-name; that is checked
before calling this function.
This is a separate function so your .emacs file or site-init.el can redefine it.
See also auto-save-file-name-p."
(if buffer-file-name
(concat (file-name-directory buffer-file-name)
"_$"
(file-name-nondirectory buffer-file-name)
"$")
(expand-file-name (concat "_$_" (make-legal-file-name (buffer-name)) "$"))))
(defun auto-save-file-name-p (filename)
"Return t if FILENAME can be yielded by make-auto-save-file-name.
FILENAME should lack slashes.
This is a separate function so your .emacs file or site-init.el can redefine it."
(string-match "^_\\$.*\\$" filename))
(defun vms-suspend-resume-hook ()
"When resuming suspended Emacs, check for file to be found.
If the logical name `EMACS_FILE_NAME' is defined, `find-file' that file."
(let ((file (vms-system-info "LOGICAL" "EMACS_FILE_NAME")))
(if file (find-file file))))
(setq suspend-resume-hook 'vms-suspend-resume-hook)
(defun vms-suspend-hook ()
"Don't allow suspending if logical name `DONT_SUSPEND_EMACS' is defined."
(if (vms-system-info "LOGICAL" "DONT_SUSPEND_EMACS")
(error "Can't suspend this emacs"))
nil)
(setq suspend-hook 'vms-suspend-hook)
(defun vms-read-directory (dirname switches buffer)
(save-excursion
(set-buffer buffer)
(subprocess-command-to-buffer
(concat "DIRECTORY " switches " " dirname)
buffer)
(goto-char (point-min))
;; Remove all the trailing blanks.
(while (search-forward " \n")
(forward-char -1)
(delete-horizontal-space))
(goto-char (point-min))))
(setq dired-listing-switches
"/SIZE/DATE/OWNER/WIDTH=(FILENAME=32,SIZE=5)")

98
lisp/window.el Normal file
View File

@ -0,0 +1,98 @@
;; GNU Emacs window commands aside from those written in C.
;; Copyright (C) 1985, 1989 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 1, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
(defun count-windows (&optional minibuf)
"Returns the number of visible windows.
Optional arg NO-MINI non-nil means don't count the minibuffer
even if it is active."
(let ((count 0))
(walk-windows (function (lambda ()
(setq count (+ count 1))))
minibuf)
count))
(defun balance-windows ()
"Makes all visible windows the same size (approximately)."
(interactive)
(let ((count 0))
(walk-windows (function (lambda (w)
(setq count (+ count 1))))
'nomini)
(let ((size (/ (screen-height) count)))
(walk-windows (function (lambda (w)
(select-window w)
(enlarge-window (- size (window-height)))))
'nomini))))
(defun split-window-vertically (&optional arg)
"Split current window into two windows, one above the other.
This window becomes the uppermost of the two, and gets
ARG lines. No arg means split equally."
(interactive "P")
(let ((old-w (selected-window))
new-w bottom)
(setq new-w (split-window nil (and arg (prefix-numeric-value arg))))
(save-excursion
(set-buffer (window-buffer))
(goto-char (window-start))
(vertical-motion (window-height))
(set-window-start new-w (point))
(if (> (point) (window-point new-w))
(set-window-point new-w (point)))
(vertical-motion -1)
(setq bottom (point)))
(if (<= bottom (point))
(set-window-point old-w (1- bottom)))))
(defun split-window-horizontally (&optional arg)
"Split current window into two windows side by side.
This window becomes the leftmost of the two, and gets
ARG columns. No arg means split equally."
(interactive "P")
(split-window nil (and arg (prefix-numeric-value arg)) t))
(defun enlarge-window-horizontally (arg)
"Make current window ARG columns wider."
(interactive "p")
(enlarge-window arg t))
(defun shrink-window-horizontally (arg)
"Make current window ARG columns narrower."
(interactive "p")
(shrink-window arg t))
(defun window-config-to-register (name)
"Save the current window configuration in register REG (a letter).
It can be later retrieved using \\[M-x register-to-window-config]."
(interactive "cSave window configuration in register: ")
(set-register name (current-window-configuration)))
(defun register-to-window-config (name)
"Restore (make current) the window configuration in register REG (a letter).
Use with a register previously set with \\[window-config-to-register]."
(interactive "cRestore window configuration from register: ")
(set-window-configuration (get-register name)))
(define-key ctl-x-map "2" 'split-window-vertically)
(define-key ctl-x-map "5" 'split-window-horizontally)
(define-key ctl-x-map "6" 'window-config-to-register)
(define-key ctl-x-map "7" 'register-to-window-config)
(define-key ctl-x-map "}" 'enlarge-window-horizontally)
(define-key ctl-x-map "{" 'shrink-window-horizontally)