mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-09 15:50:40 -08:00
Code Issues Projects Releases Wiki Activity

*** empty log message ***

Browse source
This commit is contained in:
Jim Blandy 1992-08-12 12:57:12 +00:00
parent 7e1dae733a
commit 9e2b097b26
6 changed files with 435 additions and 501 deletions
Download patch file Download diff file Expand all files Collapse all files

2
configure1.in
View file

@ -325,7 +325,7 @@ case "${window_system}" in
"" ) "" )
echo " No window system specifed. Looking for X Windows." echo " No window system specifed. Looking for X Windows."
window_system=none window_system=none
if [ -r /usr/lib/libX11.a -a -d /usr/include/X11 ]; then if [ -r /usr/lib/libX11.a -o -d /usr/include/X11 ]; then
window_system=x11 window_system=x11
fi fi
;; ;;

226
lib-src/timer.c
View file

@ -1,155 +1,221 @@
/*
* timer.c --- daemon to provide a tagged interval timer service
*
* This little daemon runs forever waiting for signals. SIGIO (or SIGUSR1)
* causes it to read an event spec from stdin; that is, a date followed by
* colon followed by an event label. SIGALRM causes it to check its queue
* for events attached to the current second; if one is found, its label
* is written to stdout. SIGTERM causes it to terminate, printing a list
* of pending events.
*
* This program is intended to be used with the lisp package called timer.el.
* It was written anonymously in 1990. This version was documented and
* rewritten for portability by esr@snark,thyrsus.com, Aug 7 1992.
*/
#include <stdio.h> #include <stdio.h>
#include <signal.h> #include <signal.h>
#include <fcntl.h> /* FASYNC */ #include <fcntl.h> /* FASYNC */
#ifdef USG /* FASYNC for SysV */
#include <sys/file.h>
#endif
#include <sys/time.h> /* itimer */
#include <sys/types.h> /* time_t */ #include <sys/types.h> /* time_t */
#include "../src/config.h"
#ifdef USG
#undef SIGIO
#define SIGIO SIGUSR1
#endif
extern int errno; extern int errno;
extern char *sys_errlist[], *malloc(); extern char *sys_errlist[], *malloc();
extern time_t time(); extern time_t time();
#define MAXEVENTS 256 #define MAXEVENTS 256
#define FS 1 /* field seperator for input */
struct event { /*
* The field separator for input. This character shouldn't be legal in a date,
* and should be printable so event strings are readable by people. Was
* originally ';', then got changed to bogus `\001'.
*/
#define FS '@'
struct event
{
char *token; char *token;
time_t reply_at; time_t reply_at;
} *events[MAXEVENTS]; }
events[MAXEVENTS];
int slot; /* The next open place in the events array */
int mevent = 0; /* 1+ the highest event number */
char *pname; /* programme name for error messages */ char *pname; /* programme name for error messages */
/* Accepts a string of two fields seperated by a ';' /* Accepts a string of two fields seperated by FS.
* First field is string for getdate, saying when to wake-up. * First field is string for getdate, saying when to wake-up.
* Second field is a token to identify the request. * Second field is a token to identify the request.
*/ */
struct event * void schedule(str)
schedule(str)
char *str; char *str;
{ {
extern time_t getdate(); extern time_t getdate();
extern char *strcpy(); extern char *strcpy();
time_t now; time_t now;
register char *p; register char *p;
static struct event e; static struct event *ep;
for(p = str; *p && *p != FS; p++); #ifdef DEBUG
if (!*p) { (void) fprintf(stderr, "Timer sees: %s", str);
#endif /* DEBUG */
/* check entry format */
for(p = str; *p && *p != FS; p++)
continue;
if (!*p)
{
(void)fprintf(stderr, "%s: bad input format: %s", pname, str); (void)fprintf(stderr, "%s: bad input format: %s", pname, str);
return((struct event *)NULL); return;
} }
*p++ = 0; *p++ = 0;
if ((e.reply_at = get_date(str, NULL)) - time(&now) < 0) { /* allocate an event slot */
(void)fprintf(stderr, "%s: bad time spec: %s%c%s", pname, str, FS, p); for(ep = events; ep < events + MAXEVENTS; ep++)
return((struct event *)NULL); if (ep->token == (char *)NULL)
} break;
if (ep == events + MAXEVENTS)
(void) fprintf(stderr, "%s: too many events: %s", pname, str);
if ((e.token = malloc((unsigned)strlen(p) + 1)) == NULL) { /* don't allow users to schedule events in past time */
else if ((ep->reply_at = get_date(str, NULL)) - time(&now) < 0)
(void)fprintf(stderr, "%s: bad time spec: %s%c%s", pname, str, FS, p);
/* save the event description */
else if ((ep->token = malloc((unsigned)strlen(p) + 1)) == NULL)
(void)fprintf(stderr, "%s: malloc %s: %s%c%s", (void)fprintf(stderr, "%s: malloc %s: %s%c%s",
pname, sys_errlist[errno], str, FS, p); pname, sys_errlist[errno], str, FS, p);
return((struct event *)NULL); else
} {
(void)strcpy(e.token,p); (void)strcpy(ep->token, p);
return(&e); #ifdef DEBUG
(void) fprintf(stderr,
"New event: %ld: %s", ep->reply_at, ep->token);
#endif /* DEBUG */
}
} }
void void
notify() notify()
{ {
time_t now, tdiff; time_t now, tdiff, waitfor = -1;
register int i, newmax = 0; register struct event *ep;
/* I prefer using the interval timer rather than alarm(); the latter
could be substituted if portability requires it. */
struct itimerval itimer;
now = time((time_t *)NULL); now = time((time_t *)NULL);
slot = mevent;
itimer.it_interval.tv_sec = itimer.it_interval.tv_usec = 0;
itimer.it_value.tv_usec = 0;
itimer.it_value.tv_sec = -1;
for(i=0; i < mevent; i++) { for(ep = events; ep < events + MAXEVENTS; ep++)
while (events[i] && events[i]->reply_at <= now) { if (ep->token)
(void)fputs(events[i]->token, stdout); {
free(events[i]->token); /* any events ready to fire? */
free((char *)events[i]); if (ep->reply_at <= now)
events[i] = 0; {
#ifdef DEBUG
(void) fprintf(stderr,
"Event %d firing: %ld @ %s",
(ep - events), ep->reply_at, ep->token);
#endif /* DEBUG */
(void)fputs(ep->token, stdout);
free(ep->token);
ep->token = (char *)NULL;
}
else
{
#ifdef DEBUG
(void) fprintf(stderr,
"Event %d still waiting: %ld @ %s",
(ep - events), ep->reply_at, ep->token);
#endif /* DEBUG */
/* next timeout should be the soonest of any remaining */
if ((tdiff = ep->reply_at - now) < waitfor || waitfor < 0)
waitfor = (long)tdiff;
}
} }
if (events[i]) {
newmax = i+1;
if ((tdiff = events[i]->reply_at - now) < (time_t)itimer.it_value.tv_sec
|| itimer.it_value.tv_sec < 0)
/* next timeout */
itimer.it_value.tv_sec = (long)tdiff;
} else {
/* Keep slot as the lowest unused events element */
if (i < slot) slot = i;
}
}
/* if the array is full to mevent, slot should be the next available spot */
if (slot > (mevent = newmax)) slot = mevent;
/* If there's no more events, SIGIO should be next wake-up */ /* If there's no more events, SIGIO should be next wake-up */
if (mevent) (void)setitimer(ITIMER_REAL, &itimer, (struct itimerval *)NULL); if (waitfor != -1)
{
#ifdef DEBUG
(void) fprintf(stderr,
"Setting %d-second alarm\n", waitfor);
#endif /* DEBUG */
(void)alarm(waitfor);
}
} }
void void
getevent() getevent()
{ {
extern char *fgets(); extern char *fgets();
struct event *ep; struct event *ep;
char buf[256]; char buf[BUFSIZ];
/* in principle the itimer should be disabled on entry to this function, /* in principle the itimer should be disabled on entry to this function,
but it really doesn't make any important difference if it isn't */ but it really doesn't make any important difference if it isn't */
if (fgets(buf, sizeof(buf), stdin) == NULL) exit(0); if (fgets(buf, sizeof(buf), stdin) == NULL)
exit(0);
if (slot == MAXEVENTS) /* register the event */
(void)fprintf(stderr, "%s: too many events: %s", pname, buf); schedule(buf);
else { /* Who knows what this interrupted, or if it said "now"? */
if ((events[slot] = (struct event *)malloc((sizeof(struct event))))
== NULL)
(void)fprintf(stderr,"%s: malloc %s: %s", pname, sys_errlist[errno],buf);
else {
if ((ep = schedule(buf)) == NULL)
free((char *)events[slot]), events[slot] = 0;
else {
memcpy((char *)events[slot],(char *)ep,sizeof(struct event));
if (slot == mevent) mevent++;
} /* schedule */
} /* malloc */
} /* limit events */
/* timing, timing. Who knows what this interrupted, or if it said "now"? */
notify(); notify();
} }
void
sigcatch(sig)
/* dispatch on incoming signal, then restore it */
{
struct event *ep;
switch(sig)
{
case SIGALRM:
#ifdef DEBUG
(void) fprintf(stderr, "Alarm signal received\n");
#endif /* DEBUG */
notify();
break;
case SIGIO:
getevent();
break;
case SIGTERM:
(void) fprintf(stderr, "Events still queued:\n");
for (ep = events; ep < events + MAXEVENTS; ep++)
if (ep->token)
(void) fprintf(stderr, "%d = %ld @ %s",
ep - events, ep->reply_at, ep->token);
exit(0);
break;
}
/* required on older UNIXes; harmless on newer ones */
(void) signal(sig, sigcatch);
}
/*ARGSUSED*/ /*ARGSUSED*/
int int
main(argc, argv) main(argc, argv)
int argc; int argc;
char **argv; char **argv;
{ {
for (pname = argv[0] + strlen(argv[0]); *pname != '/' && pname != argv[0]; for (pname = argv[0] + strlen(argv[0]); *pname != '/' && pname != argv[0];
pname--); pname--);
if (*pname == '/') pname++; if (*pname == '/') pname++;
(void)signal(SIGIO, getevent); (void)signal(SIGIO, sigcatch);
(void)signal(SIGALRM, notify); (void)signal(SIGALRM, sigcatch);
(void)signal(SIGTERM, sigcatch);
#ifndef USG
(void)fcntl(0, F_SETFL, FASYNC); (void)fcntl(0, F_SETFL, FASYNC);
#endif /* USG */
while (1) pause(); while (1) pause();
} }
/* timer.c ends here */

463
lisp/diary-lib.el
View file

@ -1,9 +1,9 @@
;;; diary.el --- diary functions. ;;; diary.el --- diary functions.
;; Copyright (C) 1989, 1990 Free Software Foundation, Inc. ;; Copyright (C) 1989, 1990, 1992 Free Software Foundation, Inc.
;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
;; Keyword: calendar ;; Keywords: diary, calendar
;; This file is part of GNU Emacs. ;; This file is part of GNU Emacs.
@ -76,11 +76,33 @@ calendar."
(autoload 'check-calendar-holidays "holidays" (autoload 'check-calendar-holidays "holidays"
"Check the list of holidays for any that occur on DATE. "Check the list of holidays for any that occur on DATE.
The value returned is a list of strings of relevant holiday descriptions. The value returned is a list of strings of relevant holiday descriptions.
The holidays are those in the list calendar-holidays.") The holidays are those in the list calendar-holidays."
t)
(autoload 'calendar-holiday-list "holidays" (autoload 'calendar-holiday-list "holidays"
"Form the list of holidays that occur on dates in the calendar window. "Form the list of holidays that occur on dates in the calendar window.
The holidays are those in the list calendar-holidays.") The holidays are those in the list calendar-holidays."
t)
(autoload 'diary-french-date "cal-french"
"French calendar equivalent of date diary entry."
t)
(autoload 'diary-mayan-date "cal-mayan"
"Mayan calendar equivalent of date diary entry."
t)
(autoload 'diary-phases-of-moon "lunar" "Moon phases diary entry." t)
(autoload 'diary-sunrise-sunset "solar"
"Local time of sunrise and sunset as a diary entry."
t)
(autoload 'diary-sabbath-candles "solar"
"Local time of candle lighting diary entry--applies if date is a Friday.
No diary entry if there is no sunset on that date."
t)
(defvar diary-syntax-table (defvar diary-syntax-table
(standard-syntax-table) (standard-syntax-table)
@ -100,7 +122,7 @@ Makes all diary entries in the diary file invisible (using selective display),
Returns a list of all relevant diary entries found, if any, in order by date. Returns a list of all relevant diary entries found, if any, in order by date.
The list entries have the form ((month day year) string). If the variable The list entries have the form ((month day year) string). If the variable
`diary-list-include-blanks' is t, this list will include a dummy diary entry `diary-list-include-blanks' is t, this list will include a dummy diary entry
\(consisting of the empty string\) for a date with no diary entries. (consisting of the empty string) for a date with no diary entries.
After the list is prepared, the hooks `nongregorian-diary-listing-hook', After the list is prepared, the hooks `nongregorian-diary-listing-hook',
`list-diary-entries-hook', and `diary-display-hook' are run. These hooks `list-diary-entries-hook', and `diary-display-hook' are run. These hooks
@ -273,8 +295,7 @@ changing the variable `diary-include-string'."
(message msg) (message msg)
(set-buffer (get-buffer-create holiday-buffer)) (set-buffer (get-buffer-create holiday-buffer))
(setq buffer-read-only nil) (setq buffer-read-only nil)
(setq mode-line-format (calendar-set-mode-line date-string)
(format "--------------------------%s%%-" date-string))
(erase-buffer) (erase-buffer)
(insert (mapconcat 'identity holiday-list "\n")) (insert (mapconcat 'identity holiday-list "\n"))
(goto-char (point-min)) (goto-char (point-min))
@ -282,11 +303,8 @@ changing the variable `diary-include-string'."
(setq buffer-read-only t) (setq buffer-read-only t)
(display-buffer holiday-buffer) (display-buffer holiday-buffer)
(message "No diary entries for %s" date-string)) (message "No diary entries for %s" date-string))
(setq mode-line-format (calendar-set-mode-line
(format "%%*--%sDiary %s %s%s%s%%-" (concat "Diary for " date-string
(if holiday-list "" "---------------")
(if holiday-list "for" "entries for")
date-string
(if holiday-list ": " "") (if holiday-list ": " "")
(mapconcat 'identity holiday-list "; "))) (mapconcat 'identity holiday-list "; ")))
(display-buffer (get-file-buffer d-file)) (display-buffer (get-file-buffer d-file))
@ -307,8 +325,7 @@ This function is provided for optional use as the `list-diary-entries-hook'."
(message msg) (message msg)
(set-buffer (get-buffer-create holiday-buffer)) (set-buffer (get-buffer-create holiday-buffer))
(setq buffer-read-only nil) (setq buffer-read-only nil)
(setq mode-line-format (calendar-set-mode-line date-string)
(format "--------------------------%s%%-" date-string))
(erase-buffer) (erase-buffer)
(insert (mapconcat 'identity holiday-list "\n")) (insert (mapconcat 'identity holiday-list "\n"))
(goto-char (point-min)) (goto-char (point-min))
@ -327,7 +344,7 @@ This function is provided for optional use as the `list-diary-entries-hook'."
(set-buffer (get-buffer-create fancy-diary-buffer)) (set-buffer (get-buffer-create fancy-diary-buffer))
(setq buffer-read-only nil) (setq buffer-read-only nil)
(make-local-variable 'mode-line-format) (make-local-variable 'mode-line-format)
(setq mode-line-format "---------------------------Diary Entries%-") (calendar-set-mode-line "Diary Entries")
(erase-buffer) (erase-buffer)
(let ((entry-list diary-entries-list) (let ((entry-list diary-entries-list)
(holiday-list) (holiday-list)
@ -386,38 +403,44 @@ This function is provided for optional use as the `list-diary-entries-hook'."
(message "Preparing diary...done")))) (message "Preparing diary...done"))))
(defun print-diary-entries () (defun print-diary-entries ()
"Print a hard copy of the entries visible in the diary window. "Print a hard copy of the diary display.
The hooks given by the variable `print-diary-entries-hook' are called after
the temporary buffer of visible diary entries is prepared; it is the hooks If the simple diary display is being used, prepare a temp buffer with the
that do the actual printing and kill the buffer." visible lines of the diary buffer, add a heading line composed from the mode
line, print the temp buffer, and destroy it.
If the fancy diary display is being used, just print the buffer.
The hooks given by the variable `print-diary-entries-hook' are called to do
the actual printing."
(interactive) (interactive)
(let ((diary-buffer (get-file-buffer (substitute-in-file-name diary-file)))) (if (bufferp (get-buffer fancy-diary-buffer))
(save-excursion
(set-buffer (get-buffer fancy-diary-buffer))
(run-hooks 'print-diary-entries-hook))
(let ((diary-buffer
(get-file-buffer (substitute-in-file-name diary-file))))
(if diary-buffer (if diary-buffer
(let ((temp-buffer (get-buffer-create "*Printable Diary Entries*"))) (let ((temp-buffer (get-buffer-create "*Printable Diary Entries*"))
(heading))
(save-excursion (save-excursion
(set-buffer diary-buffer) (set-buffer diary-buffer)
(setq heading
(if (not (stringp mode-line-format))
"All Diary Entries"
(string-match "^-*\\([^-].*[^-]\\)-*$" mode-line-format)
(substring mode-line-format
(match-beginning 1) (match-end 1))))
(copy-to-buffer temp-buffer (point-min) (point-max)) (copy-to-buffer temp-buffer (point-min) (point-max))
(set-buffer temp-buffer) (set-buffer temp-buffer)
(while (re-search-forward "\^M.*$" nil t) (while (re-search-forward "\^M.*$" nil t)
(replace-match "")) (replace-match ""))
(run-hooks 'print-diary-entries-hook)))
(error "You don't have a diary buffer!"))))
(defun add-diary-heading ()
"Add a heading to the diary entries for printing.
The heading is formed from the mode line of the diary buffer. This function
is used in the default value of the variable `print-diary-entry-hooks'."
(save-excursion
(let ((heading))
(set-buffer diary-buffer)
(setq heading mode-line-format)
(string-match "%\\*-*\\([^-].*\\)%-$" heading)
(setq heading
(substring heading (match-beginning 1) (match-end 1)))
(set-buffer temp-buffer)
(goto-char (point-min)) (goto-char (point-min))
(insert heading "\n" (insert heading "\n"
(make-string (length heading) ?=) "\n")))) (make-string (length heading) ?=) "\n")
(run-hooks 'print-diary-entries-hook)
(kill-buffer temp-buffer)))
(error "You don't have a diary buffer!")))))
(defun show-all-diary-entries () (defun show-all-diary-entries ()
"Show all of the diary entries in the diary-file. "Show all of the diary entries in the diary-file.
@ -438,8 +461,7 @@ is created."
(subst-char-in-region (point-min) (point-max) ?\^M ?\n t) (subst-char-in-region (point-min) (point-max) ?\^M ?\n t)
(setq selective-display nil) (setq selective-display nil)
(make-local-variable 'mode-line-format) (make-local-variable 'mode-line-format)
(setq mode-line-format (setq mode-line-format default-mode-line-format)
"%*---------------------------All Diary Entries%-")
(display-buffer (current-buffer)) (display-buffer (current-buffer))
(set-buffer-modified-p diary-modified)))) (set-buffer-modified-p diary-modified))))
(error "Your diary file is not readable!")) (error "Your diary file is not readable!"))
@ -718,6 +740,10 @@ A value of 0 in any position of the pattern is a wild-card."
(mark-visible-calendar-date (list month i year))) (mark-visible-calendar-date (list month i year)))
(mark-visible-calendar-date (list month p-day year))))) (mark-visible-calendar-date (list month p-day year)))))
(defun sort-diary-entries ()
"Sort the list of diary entries by time of day."
(setq diary-entries-list (sort diary-entries-list 'diary-entry-compare)))
(defun diary-entry-compare (e1 e2) (defun diary-entry-compare (e1 e2)
"Returns t if E1 is earlier than E2." "Returns t if E1 is earlier than E2."
(or (calendar-date-compare e1 e2) (or (calendar-date-compare e1 e2)
@ -757,7 +783,7 @@ and XX:XXam or XX:XXpm."
(defun list-hebrew-diary-entries () (defun list-hebrew-diary-entries ()
"Add any Hebrew date entries from the diary-file to diary-entries-list. "Add any Hebrew date entries from the diary-file to diary-entries-list.
Hebrew date diary entries must be prefaced by a hebrew-diary-entry-symbol Hebrew date diary entries must be prefaced by a hebrew-diary-entry-symbol
\(normally an `H'\). The same diary-date-forms govern the style of the Hebrew (normally an `H'). The same diary-date-forms govern the style of the Hebrew
calendar entries, except that the Hebrew month names must be spelled in full. calendar entries, except that the Hebrew month names must be spelled in full.
The Hebrew months are numbered from 1 to 13 with Nisan being 1, 12 being The Hebrew months are numbered from 1 to 13 with Nisan being 1, 12 being
Adar I and 13 being Adar II; you must use `Adar I' if you want Adar of a Adar I and 13 being Adar II; you must use `Adar I' if you want Adar of a
@ -841,7 +867,7 @@ nongregorian-diary-listing-hook."
"Mark days in the calendar window that have Hebrew date diary entries. "Mark days in the calendar window that have Hebrew date diary entries.
Each entry in diary-file (or included files) visible in the calendar window Each entry in diary-file (or included files) visible in the calendar window
is marked. Hebrew date entries are prefaced by a hebrew-diary-entry-symbol is marked. Hebrew date entries are prefaced by a hebrew-diary-entry-symbol
\(normally an `H'\). The same diary-date-forms govern the style of the Hebrew (normally an `H'). The same diary-date-forms govern the style of the Hebrew
calendar entries, except that the Hebrew month names must be spelled in full. calendar entries, except that the Hebrew month names must be spelled in full.
The Hebrew months are numbered from 1 to 13 with Nisan being 1, 12 being The Hebrew months are numbered from 1 to 13 with Nisan being 1, 12 being
Adar I and 13 being Adar II; you must use `Adar I' if you want Adar of a Adar I and 13 being Adar II; you must use `Adar I' if you want Adar of a
@ -1104,6 +1130,28 @@ A number of built-in functions are available for this type of diary entry:
made every day. Note that since there is no text, it made every day. Note that since there is no text, it
makes sense only if the fancy diary display is used. makes sense only if the fancy diary display is used.
%%(diary-astro-day-number) Diary entries giving the corresponding
astronomical (Julian) day number will be made every day.
Note that since there is no text, it makes sense only if the
fancy diary display is used.
%%(diary-julian-date) Diary entries giving the corresponding
Julian date will be made every day. Note that since
there is no text, it makes sense only if the fancy diary
display is used.
%%(diary-sunrise-sunset)
Diary entries giving the local times of sunrise and sunset
will be made every day. Note that since there is no text,
it makes sense only if the fancy diary display is used.
Floating point required.
%%(diary-phases-of-moon)
Diary entries giving the times of the phases of the moon
will be when appropriate. Note that since there is no text,
it makes sense only if the fancy diary display is used.
Floating point required.
%%(diary-yahrzeit MONTH DAY YEAR) text %%(diary-yahrzeit MONTH DAY YEAR) text
Text is assumed to be the name of the person; the date is Text is assumed to be the name of the person; the date is
the date of death on the *civil* calendar. The diary entry the date of death on the *civil* calendar. The diary entry
@ -1111,6 +1159,12 @@ A number of built-in functions are available for this type of diary entry:
day before. (If `european-calendar-style' is t, the order day before. (If `european-calendar-style' is t, the order
of the parameters should be changed to DAY, MONTH, YEAR.) of the parameters should be changed to DAY, MONTH, YEAR.)
%%(diary-sunrise-sunset)
Diary entries giving the local times of Sabbath candle
lighting will be made every day. Note that since there is
no text, it makes sense only if the fancy diary display is
used. Floating point required.
%%(diary-rosh-hodesh) %%(diary-rosh-hodesh)
Diary entries will be made on the dates of Rosh Hodesh on Diary entries will be made on the dates of Rosh Hodesh on
the Hebrew calendar. Note that since there is no text, it the Hebrew calendar. Note that since there is no text, it
@ -1288,48 +1342,35 @@ ending of that number (that is, `st', `nd', `rd' or `th', as appropriate."
(defun diary-islamic-date () (defun diary-islamic-date ()
"Islamic calendar equivalent of date diary entry." "Islamic calendar equivalent of date diary entry."
(let* ((calendar-date-display-form (let* ((i-date (calendar-islamic-from-absolute
(if european-calendar-style
'(day " " monthname " " year)
'(monthname " " day ", " year)))
(i-date (calendar-islamic-from-absolute
(calendar-absolute-from-gregorian date))) (calendar-absolute-from-gregorian date)))
(calendar-month-name-array calendar-islamic-month-name-array)) (calendar-month-name-array calendar-islamic-month-name-array))
(if (>= (extract-calendar-year i-date) 1) (if (>= (extract-calendar-year i-date) 1)
(format "Islamic date: %s" (calendar-date-string i-date))))) (format "Islamic date: %s" (calendar-date-string i-date nil t)))))
(defun diary-hebrew-date () (defun diary-hebrew-date ()
"Hebrew calendar equivalent of date diary entry." "Hebrew calendar equivalent of date diary entry."
(let* ((calendar-date-display-form (let* ((h-date (calendar-hebrew-from-absolute
(if european-calendar-style
'(day " " monthname " " year)
'(monthname " " day ", " year)))
(h-date (calendar-hebrew-from-absolute
(calendar-absolute-from-gregorian date))) (calendar-absolute-from-gregorian date)))
(calendar-month-name-array (calendar-month-name-array
(if (hebrew-calendar-leap-year-p (if (hebrew-calendar-leap-year-p
(extract-calendar-year h-date)) (extract-calendar-year h-date))
calendar-hebrew-month-name-array-leap-year calendar-hebrew-month-name-array-leap-year
calendar-hebrew-month-name-array-common-year))) calendar-hebrew-month-name-array-common-year)))
(format "Hebrew date: %s" (calendar-date-string h-date)))) (format "Hebrew date: %s" (calendar-date-string h-date nil t))))
(defun diary-french-date () (defun diary-julian-date ()
"French calendar equivalent of date diary entry." "Julian calendar equivalent of date diary entry."
(let* ((french-date (calendar-french-from-absolute (format "Julian date: %s"
(calendar-date-string
(calendar-julian-from-absolute
(calendar-absolute-from-gregorian date))) (calendar-absolute-from-gregorian date)))
(y (extract-calendar-year french-date)) nil t))
(m (extract-calendar-month french-date))
(d (extract-calendar-day french-date))) (defun diary-astro-day-number ()
(if (> y 0) "Astronomical (Julian) day number diary entry."
(if (= m 13) (format "Astronomical (Julian) day number %d"
(format "Jour %s de l'Annee %d de la Revolution" (+ 1721425 (calendar-absolute-from-gregorian date))))
(aref french-calendar-special-days-array (1- d))
y)
(format "Decade %s, %s de %s de l'Annee %d de la Revolution"
(make-string (1+ (/ (1- d) 10)) ?I)
(aref french-calendar-day-name-array (% (1- d) 10))
(aref french-calendar-month-name-array (1- m))
y)))))
(defun diary-omer () (defun diary-omer ()
"Omer count diary entry--entry applies if date is within 50 days after "Omer count diary entry--entry applies if date is within 50 days after
@ -1412,7 +1453,7 @@ before, or the Saturday before."
(if (= h-yesterday 30) (if (= h-yesterday 30)
(format "%s (second day)" this-month) (format "%s (second day)" this-month)
this-month))) this-month)))
(if (= (mod d 7) 6);; Saturday--check for Shabbat Mevarhim (if (= (% d 7) 6);; Saturday--check for Shabbat Mevarhim
(cond ((and (> h-day 22) (/= h-month 6) (= 29 last-day)) (cond ((and (> h-day 22) (/= h-month 6) (= 29 last-day))
(format "Mevarhim Rosh Hodesh %s (%s)" (format "Mevarhim Rosh Hodesh %s (%s)"
(aref h-month-names (aref h-month-names
@ -1428,7 +1469,7 @@ before, or the Saturday before."
"tomorrow" "tomorrow"
(aref calendar-day-name-array (- 29 h-day))) (aref calendar-day-name-array (- 29 h-day)))
(aref calendar-day-name-array (aref calendar-day-name-array
(mod (- 30 h-day) 7))))) (% (- 30 h-day) 7)))))
(if (and (= h-day 29) (/= h-month 6)) (if (and (= h-day 29) (/= h-month 6))
(format "Erev Rosh Hodesh %s" (format "Erev Rosh Hodesh %s"
(aref h-month-names (aref h-month-names
@ -1525,25 +1566,25 @@ start on Tuesday.")
(defconst hebrew-calendar-year-Monday-complete-Thursday (defconst hebrew-calendar-year-Monday-complete-Thursday
[51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 (nil . 34) (34.35) (35.36) 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 (nil . 34) (34 . 35) (35 . 36)
(36.37) (37.38) ([38 39].39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]] (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
"The structure of the parashiot in a Hebrew year that starts on Monday, "The structure of the parashiot in a Hebrew year that starts on Monday,
is `complete' (Heshvan and Kislev each have 30 days), and has Passover is `complete' (Heshvan and Kislev each have 30 days), and has Passover
start on Thursday.") start on Thursday.")
(defconst hebrew-calendar-year-Tuesday-regular-Thursday (defconst hebrew-calendar-year-Tuesday-regular-Thursday
[51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 (nil . 34) (34.35) (35.36) 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 (nil . 34) (34 . 35) (35 . 36)
(36.37) (37.38) ([38 39].39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]] (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
"The structure of the parashiot in a Hebrew year that starts on Tuesday, "The structure of the parashiot in a Hebrew year that starts on Tuesday,
is `regular' (Heshvan has 29 days and Kislev has 30 days), and has Passover is `regular' (Heshvan has 29 days and Kislev has 30 days), and has Passover
start on Thursday.") start on Thursday.")
(defconst hebrew-calendar-year-Thursday-regular-Saturday (defconst hebrew-calendar-year-Thursday-regular-Saturday
[52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] 23
23 24 nil (nil . 25) (25.[26 27]) ([26 27].[28 29]) ([28 29].30) (30.31) 24 nil (nil . 25) (25 . [26 27]) ([26 27] . [28 29]) ([28 29] . 30)
([31 32].32) 33 34 35 36 37 38 39 40 [41 42] (30 . 31) ([31 32] . 32) 33 34 35 36 37 38 39 40 [41 42] 43 44 45 46 47 48
43 44 45 46 47 48 49 50] 49 50]
"The structure of the parashiot in a Hebrew year that starts on Thursday, "The structure of the parashiot in a Hebrew year that starts on Thursday,
is `regular' (Heshvan has 29 days and Kislev has 30 days), and has Passover is `regular' (Heshvan has 29 days and Kislev has 30 days), and has Passover
start on Saturday.") start on Saturday.")
@ -1568,34 +1609,34 @@ start on Tuesday.")
(defconst hebrew-calendar-year-Saturday-complete-Thursday (defconst hebrew-calendar-year-Saturday-complete-Thursday
[nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
23 24 25 26 27 nil 28 29 30 31 32 33 (nil . 34) (34.35) (35.36) (36.37) 23 24 25 26 27 nil 28 29 30 31 32 33 (nil . 34) (34 . 35) (35 . 36)
(37.38) ([38 39].39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]] (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
"The structure of the parashiot in a Hebrew year that starts on Saturday, "The structure of the parashiot in a Hebrew year that starts on Saturday,
is `complete' (Heshvan and Kislev each have 30 days), and has Passover is `complete' (Heshvan and Kislev each have 30 days), and has Passover
start on Thursday.") start on Thursday.")
(defconst hebrew-calendar-year-Monday-incomplete-Thursday (defconst hebrew-calendar-year-Monday-incomplete-Thursday
[51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
23 24 25 26 27 nil 28 29 30 31 32 33 (nil . 34) (34.35) (35.36) (36.37) 23 24 25 26 27 nil 28 29 30 31 32 33 (nil . 34) (34 . 35) (35 . 36)
(37.38) ([38 39].39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]] (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
"The structure of the parashiot in a Hebrew year that starts on Monday, "The structure of the parashiot in a Hebrew year that starts on Monday,
is `incomplete' (Heshvan and Kislev each have 29 days), and has Passover is `incomplete' (Heshvan and Kislev each have 29 days), and has Passover
start on Thursday.") start on Thursday.")
(defconst hebrew-calendar-year-Monday-complete-Saturday (defconst hebrew-calendar-year-Monday-complete-Saturday
[51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
23 24 25 26 27 nil (nil . 28) (28.29) (29.30) (30.31) (31.32) (32.33) 23 24 25 26 27 nil (nil . 28) (28 . 29) (29 . 30) (30 . 31) (31 . 32)
(33.34) (34.35) (35.36) (36.37) (37.38) (38.39) (39.40) (40.41) ([41 42].42) (32 . 33) (33 . 34) (34 . 35) (35 . 36) (36 . 37) (37 . 38) (38 . 39)
43 44 45 46 47 48 49 50] (39 . 40) (40 . 41) ([41 42] . 42) 43 44 45 46 47 48 49 50]
"The structure of the parashiot in a Hebrew year that starts on Monday, "The structure of the parashiot in a Hebrew year that starts on Monday,
is `complete' (Heshvan and Kislev each have 30 days), and has Passover is `complete' (Heshvan and Kislev each have 30 days), and has Passover
start on Saturday.") start on Saturday.")
(defconst hebrew-calendar-year-Tuesday-regular-Saturday (defconst hebrew-calendar-year-Tuesday-regular-Saturday
[51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
23 24 25 26 27 nil (nil . 28) (28.29) (29.30) (30.31) (31.32) (32.33) 23 24 25 26 27 nil (nil . 28) (28 . 29) (29 . 30) (30 . 31) (31 . 32)
(33.34) (34.35) (35.36) (36.37) (37.38) (38.39) (39.40) (40.41) ([41 42].42) (32 . 33) (33 . 34) (34 . 35) (35 . 36) (36 . 37) (37 . 38) (38 . 39)
43 44 45 46 47 48 49 50] (39 . 40) (40 . 41) ([41 42] . 42) 43 44 45 46 47 48 49 50]
"The structure of the parashiot in a Hebrew year that starts on Tuesday, "The structure of the parashiot in a Hebrew year that starts on Tuesday,
is `regular' (Heshvan has 29 days and Kislev has 30 days), and has Passover is `regular' (Heshvan has 29 days and Kislev has 30 days), and has Passover
start on Saturday.") start on Saturday.")
@ -1627,7 +1668,7 @@ start on Tuesday.")
(defun list-islamic-diary-entries () (defun list-islamic-diary-entries ()
"Add any Islamic date entries from the diary-file to diary-entries-list. "Add any Islamic date entries from the diary-file to diary-entries-list.
Islamic date diary entries must be prefaced by an islamic-diary-entry-symbol Islamic date diary entries must be prefaced by an islamic-diary-entry-symbol
\(normally an `I'\). The same diary-date-forms govern the style of the Islamic (normally an `I'). The same diary-date-forms govern the style of the Islamic
calendar entries, except that the Islamic month names must be spelled in full. calendar entries, except that the Islamic month names must be spelled in full.
The Islamic months are numbered from 1 to 12 with Muharram being 1 and 12 being The Islamic months are numbered from 1 to 12 with Muharram being 1 and 12 being
Dhu al-Hijjah. If an Islamic date diary entry begins with a Dhu al-Hijjah. If an Islamic date diary entry begins with a
@ -1710,7 +1751,7 @@ nongregorian-diary-listing-hook."
"Mark days in the calendar window that have Islamic date diary entries. "Mark days in the calendar window that have Islamic date diary entries.
Each entry in diary-file (or included files) visible in the calendar window Each entry in diary-file (or included files) visible in the calendar window
is marked. Islamic date entries are prefaced by a islamic-diary-entry-symbol is marked. Islamic date entries are prefaced by a islamic-diary-entry-symbol
\(normally an `I'\). The same diary-date-forms govern the style of the Islamic (normally an `I'). The same diary-date-forms govern the style of the Islamic
calendar entries, except that the Islamic month names must be spelled in full. calendar entries, except that the Islamic month names must be spelled in full.
The Islamic months are numbered from 1 to 12 with Muharram being 1 and 12 being The Islamic months are numbered from 1 to 12 with Muharram being 1 and 12 being
Dhu al-Hijjah. Islamic date diary entries that begin with a Dhu al-Hijjah. Islamic date diary entries that begin with a
@ -1870,246 +1911,6 @@ MONTH/DAY/YEAR. A value of 0 in any position is a wild-card."
(mark-visible-calendar-date (mark-visible-calendar-date
(calendar-gregorian-from-absolute date))))))))) (calendar-gregorian-from-absolute date)))))))))
(defun make-diary-entry (string &optional nonmarking file)
"Insert a diary entry STRING which may be NONMARKING in FILE.
If omitted, NONMARKING defaults to nil and FILE defaults to diary-file."
(find-file-other-window
(substitute-in-file-name (if file file diary-file)))
(goto-char (point-max))
(insert
(if (bolp) "" "\n")
(if nonmarking diary-nonmarking-symbol "")
string " "))
(defun insert-diary-entry (arg)
"Insert a diary entry for the date indicated by point.
Prefix arg will make the entry nonmarking."
(interactive "P")
(let* ((calendar-date-display-form
(if european-calendar-style
'(day " " monthname " " year)
'(monthname " " day ", " year))))
(make-diary-entry
(calendar-date-string
(or (calendar-cursor-to-date)
(error "Cursor is not on a date!"))
t)
arg)))
(defun insert-weekly-diary-entry (arg)
"Insert a weekly diary entry for the day of the week indicated by point.
Prefix arg will make the entry nonmarking."
(interactive "P")
(make-diary-entry
(calendar-day-name
(or (calendar-cursor-to-date)
(error "Cursor is not on a date!")))
arg))
(defun insert-monthly-diary-entry (arg)
"Insert a monthly diary entry for the day of the month indicated by point.
Prefix arg will make the entry nonmarking."
(interactive "P")
(let* ((calendar-date-display-form
(if european-calendar-style
'(day " * ")
'("* " day))))
(make-diary-entry
(calendar-date-string
(or (calendar-cursor-to-date)
(error "Cursor is not on a date!"))
t)
arg)))
(defun insert-yearly-diary-entry (arg)
"Insert an annual diary entry for the day of the year indicated by point.
Prefix arg will make the entry nonmarking."
(interactive "P")
(let* ((calendar-date-display-form
(if european-calendar-style
'(day " " monthname)
'(monthname " " day))))
(make-diary-entry
(calendar-date-string
(or (calendar-cursor-to-date)
(error "Cursor is not on a date!"))
t)
arg)))
(defun insert-anniversary-diary-entry (arg)
"Insert an anniversary diary entry for the date given by point.
Prefix arg will make the entry nonmarking."
(interactive "P")
(let* ((calendar-date-display-form
(if european-calendar-style
'(day " " month " " year)
'(month " " day " " year))))
(make-diary-entry
(format "%s(diary-anniversary %s)"
sexp-diary-entry-symbol
(calendar-date-string
(or (calendar-cursor-to-date)
(error "Cursor is not on a date!"))))
arg)))
(defun insert-block-diary-entry (arg)
"Insert a block diary entry for the days between the point and marked date.
Prefix arg will make the entry nonmarking."
(interactive "P")
(let* ((calendar-date-display-form
(if european-calendar-style
'(day " " month " " year)
'(month " " day " " year)))
(cursor (or (calendar-cursor-to-date)
(error "Cursor is not on a date!")))
(mark (or (car calendar-mark-ring)
(error "No mark set in this buffer")))
(start)
(end))
(if (< (calendar-absolute-from-gregorian mark)
(calendar-absolute-from-gregorian cursor))
(setq start mark
end cursor)
(setq start cursor
end mark))
(make-diary-entry
(format "%s(diary-block %s %s)"
sexp-diary-entry-symbol
(calendar-date-string start)
(calendar-date-string end))
arg)))
(defun insert-cyclic-diary-entry (arg)
"Insert a cyclic diary entry starting at the date given by point.
Prefix arg will make the entry nonmarking."
(interactive "P")
(let* ((calendar-date-display-form
(if european-calendar-style
'(day " " month " " year)
'(month " " day " " year))))
(make-diary-entry
(format "%s(diary-cyclic %d %s)"
sexp-diary-entry-symbol
(calendar-read "Repeat every how many days: "
'(lambda (x) (> x 0)))
(calendar-date-string
(or (calendar-cursor-to-date)
(error "Cursor is not on a date!"))))
arg)))
(defun insert-hebrew-diary-entry (arg)
"Insert a diary entry for the Hebrew date corresponding to the date
indicated by point. Prefix arg will make the entry nonmarking."
(interactive "P")
(let* ((calendar-date-display-form
(if european-calendar-style
'(day " " monthname " " year)
'(monthname " " day ", " year)))
(calendar-month-name-array
calendar-hebrew-month-name-array-leap-year))
(make-diary-entry
(concat
hebrew-diary-entry-symbol
(calendar-date-string
(calendar-hebrew-from-absolute
(calendar-absolute-from-gregorian
(or (calendar-cursor-to-date)
(error "Cursor is not on a date!"))))))
arg)))
(defun insert-monthly-hebrew-diary-entry (arg)
"Insert a monthly diary entry for the day of the Hebrew month corresponding
to the date indicated by point. Prefix arg will make the entry nonmarking."
(interactive "P")
(let* ((calendar-date-display-form
(if european-calendar-style '(day " * ") '("* " day )))
(calendar-month-name-array
calendar-hebrew-month-name-array-leap-year))
(make-diary-entry
(concat
hebrew-diary-entry-symbol
(calendar-date-string
(calendar-hebrew-from-absolute
(calendar-absolute-from-gregorian
(or (calendar-cursor-to-date)
(error "Cursor is not on a date!"))))))
arg)))
(defun insert-yearly-hebrew-diary-entry (arg)
"Insert an annual diary entry for the day of the Hebrew year corresponding
to the date indicated by point. Prefix arg will make the entry nonmarking."
(interactive "P")
(let* ((calendar-date-display-form
(if european-calendar-style
'(day " " monthname)
'(monthname " " day)))
(calendar-month-name-array
calendar-hebrew-month-name-array-leap-year))
(make-diary-entry
(concat
hebrew-diary-entry-symbol
(calendar-date-string
(calendar-hebrew-from-absolute
(calendar-absolute-from-gregorian
(or (calendar-cursor-to-date)
(error "Cursor is not on a date!"))))))
arg)))
(defun insert-islamic-diary-entry (arg)
"Insert a diary entry for the Islamic date corresponding to the date
indicated by point. Prefix arg will make the entry nonmarking."
(interactive "P")
(let* ((calendar-date-display-form
(if european-calendar-style
'(day " " monthname " " year)
'(monthname " " day ", " year)))
(calendar-month-name-array calendar-islamic-month-name-array))
(make-diary-entry
(concat
islamic-diary-entry-symbol
(calendar-date-string
(calendar-islamic-from-absolute
(calendar-absolute-from-gregorian
(or (calendar-cursor-to-date)
(error "Cursor is not on a date!"))))))
arg)))
(defun insert-monthly-islamic-diary-entry (arg)
"Insert a monthly diary entry for the day of the Islamic month corresponding
to the date indicated by point. Prefix arg will make the entry nonmarking."
(interactive "P")
(let* ((calendar-date-display-form
(if european-calendar-style '(day " * ") '("* " day )))
(calendar-month-name-array calendar-islamic-month-name-array))
(make-diary-entry
(concat
islamic-diary-entry-symbol
(calendar-date-string
(calendar-islamic-from-absolute
(calendar-absolute-from-gregorian
(or (calendar-cursor-to-date)
(error "Cursor is not on a date!"))))))
arg)))
(defun insert-yearly-islamic-diary-entry (arg)
"Insert an annual diary entry for the day of the Islamic year corresponding
to the date indicated by point. Prefix arg will make the entry nonmarking."
(interactive "P")
(let* ((calendar-date-display-form
(if european-calendar-style
'(day " " monthname)
'(monthname " " day)))
(calendar-month-name-array calendar-islamic-month-name-array))
(make-diary-entry
(concat
islamic-diary-entry-symbol
(calendar-date-string
(calendar-islamic-from-absolute
(calendar-absolute-from-gregorian
(or (calendar-cursor-to-date)
(error "Cursor is not on a date!"))))))
arg)))
(provide 'diary) (provide 'diary)
;;; diary.el ends here ;;; diary.el ends here

131
lisp/emacs-lisp/bytecomp.el
View file

@ -8,7 +8,9 @@
;; Subsequently modified by RMS. ;; Subsequently modified by RMS.
(defconst byte-compile-version "FSF 2.1") ;;; This version incorporates changes up to version 2.08 of the
;;; Zawinski-Furuseth compiler.
(defconst byte-compile-version "FSF 2.08")
;; This file is part of GNU Emacs. ;; This file is part of GNU Emacs.
@ -95,9 +97,13 @@
;;; generic emacs 18. ;;; generic emacs 18.
;;; byte-compile-single-version Normally the byte-compiler will consult the ;;; byte-compile-single-version Normally the byte-compiler will consult the
;;; above two variables at runtime, but if this ;;; above two variables at runtime, but if this
;;; variable is true when the compiler itself is ;;; is true before the compiler itself is loaded/
;;; compiled, then the runtime checks will not be ;;; compiled, then the runtime checks will not be
;;; made, and compilation will be slightly faster. ;;; made, and compilation will be slightly faster.
;;; To use this, start up a fresh emacs, set this
;;; to t, reload the compiler's .el files, and
;;; recompile. Don't do this in an emacs that has
;;; already had the compiler loaded.
;;; byte-compile-overwrite-file If nil, delete old .elc files before saving. ;;; byte-compile-overwrite-file If nil, delete old .elc files before saving.
;;; New Features: ;;; New Features:
@ -242,19 +248,17 @@ If it is 'byte, then only byte-level optimizations will be logged.")
of `message.'") of `message.'")
(defconst byte-compile-warning-types '(redefine callargs free-vars unresolved)) (defconst byte-compile-warning-types '(redefine callargs free-vars unresolved))
(defvar byte-compile-warnings (not noninteractive) (defvar byte-compile-warnings t
"*List of warnings that the byte-compiler should issue (t for all). "*List of warnings that the byte-compiler should issue (t for all).
Valid elements of this list are: Elements of the list may be be:
`free-vars' (references to variables not in the
current lexical scope) free-vars references to variables not in the current lexical scope.
`unresolved' (calls to unknown functions) unresolved calls to unknown functions.
`callargs' (lambda calls with args that don't callargs lambda calls with args that don't match the definition.
match the lambda's definition) redefine function cell redefined from a macro to a lambda or vice
`redefine' (function cell redefined from versa, or redefined to take a different number of arguments.
a macro to a lambda or vice versa,
or redefined to take other args) See also the macro byte-compiler-options.")
This variable defaults to nil in -batch mode, which is
slightly faster.")
(defvar byte-compile-generate-call-tree nil (defvar byte-compile-generate-call-tree nil
"*Non-nil means collect call-graph information when compiling. "*Non-nil means collect call-graph information when compiling.
@ -388,7 +392,7 @@ Each element is (INDEX . VALUE)")
(byte-defop 24 -1 byte-varbind "for binding a variable") (byte-defop 24 -1 byte-varbind "for binding a variable")
(byte-defop 32 0 byte-call "for calling a function") (byte-defop 32 0 byte-call "for calling a function")
(byte-defop 40 0 byte-unbind "for unbinding special bindings") (byte-defop 40 0 byte-unbind "for unbinding special bindings")
;; codes 41-47 are consumed by the preceeding opcodes ;; codes 8-47 are consumed by the preceeding opcodes
;; unused: 48-55 ;; unused: 48-55
@ -684,7 +688,7 @@ otherwise pop it")
(defconst byte-compile-last-warned-form nil) (defconst byte-compile-last-warned-form nil)
(defun byte-compile-log-1 (string) (defun byte-compile-log-1 (string &optional fill)
(cond (noninteractive (cond (noninteractive
(if (or byte-compile-current-file (if (or byte-compile-current-file
(and byte-compile-last-warned-form (and byte-compile-last-warned-form
@ -719,7 +723,12 @@ otherwise pop it")
(insert " in buffer " (insert " in buffer "
(buffer-name byte-compile-current-file)))) (buffer-name byte-compile-current-file))))
(insert ":\n"))) (insert ":\n")))
(insert " " string "\n")))) (insert " " string "\n")
(if (and fill (not (string-match "\n" string)))
(let ((fill-prefix " ")
(fill-column 78))
(fill-paragraph nil)))
)))
(setq byte-compile-current-file nil (setq byte-compile-current-file nil
byte-compile-last-warned-form byte-compile-current-form)) byte-compile-last-warned-form byte-compile-current-form))
@ -727,7 +736,7 @@ otherwise pop it")
(setq format (apply 'format format args)) (setq format (apply 'format format args))
(if byte-compile-error-on-warn (if byte-compile-error-on-warn
(error "%s" format) ; byte-compile-file catches and logs it (error "%s" format) ; byte-compile-file catches and logs it
(byte-compile-log-1 (concat "** " format)) (byte-compile-log-1 (concat "** " format) t)
;;; It is useless to flash warnings too fast to be read. ;;; It is useless to flash warnings too fast to be read.
;;; Besides, they will all be shown at the end. ;;; Besides, they will all be shown at the end.
;;; (or noninteractive ; already written on stdout. ;;; (or noninteractive ; already written on stdout.
@ -737,10 +746,11 @@ otherwise pop it")
;;; This function should be used to report errors that have halted ;;; This function should be used to report errors that have halted
;;; compilation of the current file. ;;; compilation of the current file.
(defun byte-compile-report-error (error-info) (defun byte-compile-report-error (error-info)
(setq format (format (if (cdr error-info) "%s (%s)" "%s") (byte-compile-log-1
(concat "!! "
(format (if (cdr error-info) "%s (%s)" "%s")
(get (car error-info) 'error-message) (get (car error-info) 'error-message)
(prin1-to-string (cdr error-info)))) (prin1-to-string (cdr error-info))))))
(byte-compile-log-1 (concat "!! " format)))
;;; Used by make-obsolete. ;;; Used by make-obsolete.
(defun byte-compile-obsolete (form) (defun byte-compile-obsolete (form)
@ -1036,26 +1046,49 @@ This is if a `.elc' file exists but is older than the `.el' file.
If the `.elc' file does not exist, normally the `.el' file is *not* compiled. If the `.elc' file does not exist, normally the `.el' file is *not* compiled.
But a prefix argument (optional second arg) means ask user, But a prefix argument (optional second arg) means ask user,
for each such `.el' file, whether to compile it." for each such `.el' file, whether to compile it. Prefix argument 0 means
don't ask and compile the file anyway."
(interactive "DByte recompile directory: \nP") (interactive "DByte recompile directory: \nP")
(save-some-buffers) (save-some-buffers)
(set-buffer-modified-p (buffer-modified-p)) ;Update the mode line. (set-buffer-modified-p (buffer-modified-p)) ;Update the mode line.
(setq directory (expand-file-name directory)) (let ((directories (list (expand-file-name directory)))
(let ((files (directory-files directory nil emacs-lisp-file-regexp)) (file-count 0)
(count 0) (dir-count 0)
last-dir)
(displaying-byte-compile-warnings
(while directories
(setq directory (car directories))
(message "Checking %s..." directory)
(let ((files (directory-files directory))
source dest) source dest)
(while files (while files
(if (and (not (auto-save-file-name-p (car files)))
(setq source (expand-file-name (car files) directory)) (setq source (expand-file-name (car files) directory))
(if (and (not (member (car files) '("." ".." "RCS" "CVS")))
(file-directory-p source))
(if (or (null arg)
(eq arg 0)
(y-or-n-p (concat "Check " source "? ")))
(setq directories
(nconc directories (list source))))
(if (and (string-match emacs-lisp-file-regexp source)
(not (auto-save-file-name-p source))
(setq dest (byte-compile-dest-file source)) (setq dest (byte-compile-dest-file source))
(if (file-exists-p dest) (if (file-exists-p dest)
(file-newer-than-file-p source dest) (file-newer-than-file-p source dest)
(and arg (y-or-n-p (concat "Compile " source "? "))))) (and arg
(or (zerop arg)
(y-or-n-p (concat "Compile " source "? "))))))
(progn (byte-compile-file source) (progn (byte-compile-file source)
(setq count (1+ count)))) (setq file-count (1+ file-count))
(setq files (cdr files))) (if (not (eq last-dir directory))
(message "Done (Total of %d file%s compiled)" (setq last-dir directory
count (if (= count 1) "" "s")))) dir-count (1+ dir-count)))
)))
(setq files (cdr files))))
(setq directories (cdr directories))))
(message "Done (Total of %d file%s compiled%s)"
file-count (if (= file-count 1) "" "s")
(if (> dir-count 1) (format " in %d directories" dir-count) ""))))
;;;###autoload ;;;###autoload
(defun byte-compile-file (filename &optional load) (defun byte-compile-file (filename &optional load)
@ -1276,7 +1309,8 @@ With argument, insert value in current buffer after the form."
(stringp (nth 3 form))) (stringp (nth 3 form)))
(byte-compile-output-docform '("\n(" 3 ")") form) (byte-compile-output-docform '("\n(" 3 ")") form)
(let ((print-escape-newlines t) (let ((print-escape-newlines t)
(print-readably t)) (print-readably t) ; print #[] for bytecode, 'x for (quote x)
(print-gensym nil)) ; this is too dangerous for now
(princ "\n" outbuffer) (princ "\n" outbuffer)
(prin1 form outbuffer) (prin1 form outbuffer)
nil))) nil)))
@ -1289,7 +1323,8 @@ With argument, insert value in current buffer after the form."
(insert (car info)) (insert (car info))
(let ((docl (nthcdr (nth 1 info) form)) (let ((docl (nthcdr (nth 1 info) form))
(print-escape-newlines t) (print-escape-newlines t)
(print-readably t)) (print-readably t) ; print #[] for bytecode, 'x for (quote x)
(print-gensym nil)) ; this is too dangerous for now
(prin1 (car form) outbuffer) (prin1 (car form) outbuffer)
(while (setq form (cdr form)) (while (setq form (cdr form))
(insert " ") (insert " ")
@ -1813,6 +1848,8 @@ If FORM is a lambda or a macro, byte-compile it as a function."
((symbolp (car form)) ((symbolp (car form))
(let* ((fn (car form)) (let* ((fn (car form))
(handler (get fn 'byte-compile))) (handler (get fn 'byte-compile)))
(if (memq fn '(t nil))
(byte-compile-warn "%s called as a function" fn))
(if (and handler (if (and handler
(or (byte-compile-version-cond (or (byte-compile-version-cond
byte-compile-compatibility) byte-compile-compatibility)
@ -1846,6 +1883,12 @@ If FORM is a lambda or a macro, byte-compile it as a function."
"Variable reference to %s %s") "Variable reference to %s %s")
(if (symbolp var) "constant" "nonvariable") (if (symbolp var) "constant" "nonvariable")
(prin1-to-string var)) (prin1-to-string var))
(if (get var 'byte-obsolete-variable)
(let ((ob (get var 'byte-obsolete-variable)))
(byte-compile-warn "%s is an obsolete variable; %s" var
(if (stringp ob)
ob
(format "use %s instead." ob)))))
(if (memq 'free-vars byte-compile-warnings) (if (memq 'free-vars byte-compile-warnings)
(if (eq base-op 'byte-varbind) (if (eq base-op 'byte-varbind)
(setq byte-compile-bound-variables (setq byte-compile-bound-variables
@ -1933,6 +1976,9 @@ If FORM is a lambda or a macro, byte-compile it as a function."
;; be used when byte-compile-compatibility is true. ;; be used when byte-compile-compatibility is true.
(if (and (byte-compile-single-version) (if (and (byte-compile-single-version)
(not byte-compile-compatibility)) (not byte-compile-compatibility))
;; #### instead of doing nothing, this should do some remprops,
;; #### to protect against the case where a single-version compiler
;; #### is loaded into a world that has contained a multi-version one.
nil nil
(list 'progn (list 'progn
(list 'put (list 'put
@ -2020,7 +2066,7 @@ If FORM is a lambda or a macro, byte-compile it as a function."
(byte-defop-compiler get 2) (byte-defop-compiler get 2)
(byte-defop-compiler nth 2) (byte-defop-compiler nth 2)
(byte-defop-compiler substring 2-3) (byte-defop-compiler substring 2-3)
(byte-defop-compiler (move-marker byte-set-marker) 2-3) (byte-defop-compiler19 (move-marker byte-set-marker) 2-3)
(byte-defop-compiler19 set-marker 2-3) (byte-defop-compiler19 set-marker 2-3)
(byte-defop-compiler19 match-beginning 1) (byte-defop-compiler19 match-beginning 1)
(byte-defop-compiler19 match-end 1) (byte-defop-compiler19 match-end 1)
@ -2028,21 +2074,21 @@ If FORM is a lambda or a macro, byte-compile it as a function."
(byte-defop-compiler19 downcase 1) (byte-defop-compiler19 downcase 1)
(byte-defop-compiler19 string= 2) (byte-defop-compiler19 string= 2)
(byte-defop-compiler19 string< 2) (byte-defop-compiler19 string< 2)
(byte-defop-compiler (string-equal byte-string=) 2) (byte-defop-compiler19 (string-equal byte-string=) 2)
(byte-defop-compiler (string-lessp byte-string<) 2) (byte-defop-compiler19 (string-lessp byte-string<) 2)
(byte-defop-compiler19 equal 2) (byte-defop-compiler19 equal 2)
(byte-defop-compiler19 nthcdr 2) (byte-defop-compiler19 nthcdr 2)
(byte-defop-compiler19 elt 2) (byte-defop-compiler19 elt 2)
(byte-defop-compiler19 member 2) (byte-defop-compiler19 member 2)
(byte-defop-compiler19 assq 2) (byte-defop-compiler19 assq 2)
(byte-defop-compiler (rplaca byte-setcar) 2) (byte-defop-compiler19 (rplaca byte-setcar) 2)
(byte-defop-compiler (rplacd byte-setcdr) 2) (byte-defop-compiler19 (rplacd byte-setcdr) 2)
(byte-defop-compiler19 setcar 2) (byte-defop-compiler19 setcar 2)
(byte-defop-compiler19 setcdr 2) (byte-defop-compiler19 setcdr 2)
(byte-defop-compiler19 buffer-substring 2) (byte-defop-compiler19 buffer-substring 2)
(byte-defop-compiler19 delete-region 2) (byte-defop-compiler19 delete-region 2)
(byte-defop-compiler19 narrow-to-region 2) (byte-defop-compiler19 narrow-to-region 2)
(byte-defop-compiler (mod byte-rem) 2) (byte-defop-compiler19 (mod byte-rem) 2)
(byte-defop-compiler19 (% byte-rem) 2) (byte-defop-compiler19 (% byte-rem) 2)
(byte-defop-compiler aset 3) (byte-defop-compiler aset 3)
@ -2903,6 +2949,13 @@ For example, invoke \"emacs -batch -f batch-byte-compile $emacs/ ~/*.el\""
(make-obsolete 'buffer-flush-undo 'buffer-disable-undo) (make-obsolete 'buffer-flush-undo 'buffer-disable-undo)
(make-obsolete 'baud-rate "use the baud-rate variable instead") (make-obsolete 'baud-rate "use the baud-rate variable instead")
(make-obsolete-variable 'auto-fill-hook 'auto-fill-function)
(make-obsolete-variable 'blink-paren-hook 'blink-paren-function)
(make-obsolete-variable 'lisp-indent-hook 'lisp-indent-function)
(make-obsolete-variable 'temp-buffer-show-hook
'temp-buffer-show-function)
(make-obsolete-variable 'inhibit-local-variables
"use enable-local-variables (with the reversed sense.)")
(provide 'byte-compile) (provide 'byte-compile)

25
lisp/frame.el
View file

@ -31,7 +31,7 @@ function, which should take an alist of parameters as its argument.")
;;; The default value for this must ask for a minibuffer. There must ;;; The default value for this must ask for a minibuffer. There must
;;; always exist a frame with a minibuffer, and after we delete the ;;; always exist a frame with a minibuffer, and after we delete the
;;; terminal frame, this will be the only frame. ;;; terminal frame, this will be the only frame.
(defvar initial-frame-alist '((minibuffer . nil)) (defvar initial-frame-alist '((minibuffer . t))
"Alist of values used when creating the initial emacs text frame. "Alist of values used when creating the initial emacs text frame.
These may be set in your init file, like this: These may be set in your init file, like this:
(setq initial-frame-alist '((top . 1) (left . 1) (width . 80) (height . 55))) (setq initial-frame-alist '((top . 1) (left . 1) (width . 80) (height . 55)))
@ -286,8 +286,27 @@ If FRAME is omitted, describe the currently selected frame."
;;;; Aliases for backward compatibility with Emacs 18. ;;;; Aliases for backward compatibility with Emacs 18.
(fset 'screen-height 'frame-height) (fset 'screen-height 'frame-height)
(fset 'screen-width 'frame-width) (fset 'screen-width 'frame-width)
(fset 'set-screen-width 'set-frame-width)
(fset 'set-screen-height 'set-frame-height) (defun set-screen-width (cols &optional pretend)
"Obsolete function to change the size of the screen to COLS columns.\n\
Optional second arg non-nil means that redisplay should use COLS columns\n\
but that the idea of the actual width of the frame should not be changed.\n\
This function is provided only for compatibility with Emacs 18; new code\n\
should use set-frame-width instead."
(set-frame-width (selected-frame) cols pretend))
(defun set-screen-height (lines &optional pretend)
"Obsolete function to change the height of the screen to LINES lines.\n\
Optional second arg non-nil means that redisplay should use LINES lines\n\
but that the idea of the actual height of the screen should not be changed.\n\
This function is provided only for compatibility with Emacs 18; new code\n\
should use set-frame-width instead."
(set-frame-height (selected-frame) lines pretend))
(make-obsolete 'screen-height 'frame-height)
(make-obsolete 'screen-width 'frame-width)
(make-obsolete 'set-screen-width 'set-frame-width)
(make-obsolete 'set-screen-height 'set-frame-height)
;;;; Key bindings ;;;; Key bindings

5
lisp/term/x-win.el
View file

@ -437,11 +437,6 @@ This returns ARGS with the arguments that have been processed removed."
(x-open-connection (or x-display-name (x-open-connection (or x-display-name
(setq x-display-name (getenv "DISPLAY")))) (setq x-display-name (getenv "DISPLAY"))))
;;; xterm.c depends on using interrupt-driven input, but we don't want
;;; the fcntls to apply to the terminal, so we do this after opening
;;; the display.
(set-input-mode t nil t)
(setq frame-creation-function 'x-create-frame) (setq frame-creation-function 'x-create-frame)
(setq suspend-hook (setq suspend-hook
'(lambda () '(lambda ()