mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2025-02-01 20:06:00 +00:00
entered into RCS
This commit is contained in:
Jim Blandy
parent
9f34a2a0c8
commit
7e1dae733a
@ -86,9 +86,23 @@ If NEW is a string, that is the `use instead' message."
|
||||
(put fn 'byte-compile 'byte-compile-obsolete)))
|
||||
fn)
|
||||
|
||||
(defun make-obsolete-variable (var new)
|
||||
"Make the byte-compiler warn that VARIABLE is obsolete,
|
||||
and NEW should be used instead. If NEW is a string, then that is the
|
||||
`use instead' message."
|
||||
(interactive
|
||||
(list
|
||||
(let ((str (completing-read "Make variable obsolete: " obarray 'boundp t)))
|
||||
(if (equal str "") (error ""))
|
||||
(intern str))
|
||||
(car (read-from-string (read-string "Obsoletion replacement: ")))))
|
||||
(put var 'byte-obsolete-variable new)
|
||||
var)
|
||||
|
||||
(put 'dont-compile 'lisp-indent-hook 0)
|
||||
(defmacro dont-compile (&rest body)
|
||||
"Like `progn', but the body always runs interpreted (not compiled)."
|
||||
"Like `progn', but the body always runs interpreted (not compiled).
|
||||
If you think you need this, you're probably making a mistake somewhere."
|
||||
(list 'eval (list 'quote (if (cdr body) (cons 'progn body) (car body)))))
|
||||
|
||||
|
||||
|
||||
@ -107,29 +107,37 @@
|
||||
|
||||
;;; Code:
|
||||
|
||||
;;;###autoload
|
||||
(defvar appt-issue-message t
|
||||
"*Non-nil means check for appointments in the diary buffer.
|
||||
To be detected, the diary entry must have the time
|
||||
as the first thing on a line.")
|
||||
|
||||
;;;###autoload
|
||||
(defvar appt-message-warning-time 10
|
||||
"*Time in minutes before an appointment that the warning begins.")
|
||||
|
||||
;;;###autoload
|
||||
(defvar appt-audible t
|
||||
"*Non-nil means beep to indicate appointment.")
|
||||
|
||||
;;;###autoload
|
||||
(defvar appt-visible t
|
||||
"*Non-nil means display appointment message in echo area.")
|
||||
|
||||
;;;###autoload
|
||||
(defvar appt-display-mode-line t
|
||||
"*Non-nil means display minutes to appointment and time on the mode line.")
|
||||
|
||||
;;;###autoload
|
||||
(defvar appt-msg-window t
|
||||
"*Non-nil means display appointment message in another window.")
|
||||
|
||||
;;;###autoload
|
||||
(defvar appt-display-duration 5
|
||||
"*The number of seconds an appointment message is displayed.")
|
||||
|
||||
;;;###autoload
|
||||
(defvar appt-display-diary t
|
||||
"*Non-nil means to display the next days diary on the screen.
|
||||
This will occur at midnight when the appointment list is updated.")
|
||||
|
||||
223
lisp/calendar/cal-french.el
Normal file
223
lisp/calendar/cal-french.el
Normal file
@ -0,0 +1,223 @@
|
||||
;;; cal-french.el --- calendar functions for the French Revolutionary calendar.
|
||||
|
||||
;; Copyright (C) 1988, 1989, 1992 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
|
||||
;; Keywords: French Revolutionary calendar, calendar, diary
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY. No author or distributor
|
||||
;; accepts responsibility to anyone for the consequences of using it
|
||||
;; or for whether it serves any particular purpose or works at all,
|
||||
;; unless he says so in writing. Refer to the GNU Emacs General Public
|
||||
;; License for full details.
|
||||
|
||||
;; Everyone is granted permission to copy, modify and redistribute
|
||||
;; GNU Emacs, but only under the conditions described in the
|
||||
;; GNU Emacs General Public License. A copy of this license is
|
||||
;; supposed to have been given to you along with GNU Emacs so you
|
||||
;; can know your rights and responsibilities. It should be in a
|
||||
;; file named COPYING. Among other things, the copyright notice
|
||||
;; and this notice must be preserved on all copies.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; This collection of functions implements the features of calendar.el and
|
||||
;; diary.el that deal with the French Revolutionary calendar.
|
||||
|
||||
;; Technical details of the French Revolutionary calendrical calculations can
|
||||
;; be found in ``Calendrical Calculations, Part II: Three Historical
|
||||
;; Calendars'' by E. M. Reingold, N. Dershowitz, and S. M. Clamen,
|
||||
;; Report Number UIUCDCS-R-92-1743, Department of Computer Science,
|
||||
;; University of Illinois, April, 1992.
|
||||
|
||||
;; Comments, corrections, and improvements should be sent to
|
||||
;; Edward M. Reingold Department of Computer Science
|
||||
;; (217) 333-6733 University of Illinois at Urbana-Champaign
|
||||
;; reingold@cs.uiuc.edu 1304 West Springfield Avenue
|
||||
;; Urbana, Illinois 61801
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'calendar)
|
||||
|
||||
(defconst french-calendar-month-name-array
|
||||
["Vende'miaire" "Brumaire" "Frimaire" "Nivo^se" "Pluvio^se" "Vento^se"
|
||||
"Germinal" "Flore'al" "Prairial" "Messidor" "Thermidor" "Fructidor"])
|
||||
|
||||
(defconst french-calendar-day-name-array
|
||||
["Primidi" "Duodi" "Tridi" "Quartidi" "Quintidi" "Sextidi" "Septidi"
|
||||
"Octidi" "Nonidi" "Decadi"])
|
||||
|
||||
(defconst french-calendar-special-days-array
|
||||
["de la Vertu" "du Genie" "du Labour" "de la Raison" "de la Recompense"
|
||||
"de la Revolution"])
|
||||
|
||||
(defun french-calendar-leap-year-p (year)
|
||||
"True if YEAR is a leap year on the French Revolutionary calendar.
|
||||
For Gregorian years 1793 to 1805, the years of actual operation of the
|
||||
calendar, uses historical practice based on equinoxes is followed (years 3, 7,
|
||||
and 11 were leap years; 15 and 20 would have been leap years). For later
|
||||
years uses the proposed rule of Romme (never adopted)--leap years fall every
|
||||
four years except century years not divisible 400 and century years that are
|
||||
multiples of 4000."
|
||||
(or (memq year '(3 7 11));; Actual practice--based on equinoxes
|
||||
(memq year '(15 20)) ;; Anticipated practice--based on equinoxes
|
||||
(and (> year 20) ;; Romme's proposal--never adopted
|
||||
(zerop (% year 4))
|
||||
(not (memq (% year 400) '(100 200 300)))
|
||||
(not (zerop (% year 4000))))))
|
||||
|
||||
(defun french-calendar-last-day-of-month (month year)
|
||||
"Last day of MONTH, YEAR on the French Revolutionary calendar.
|
||||
The 13th month is not really a month, but the 5 (6 in leap years) day period of
|
||||
`sansculottides' at the end of the year."
|
||||
(if (< month 13)
|
||||
30
|
||||
(if (french-calendar-leap-year-p year)
|
||||
6
|
||||
5)))
|
||||
|
||||
(defun calendar-absolute-from-french (date)
|
||||
"Absolute date of French Revolutionary DATE.
|
||||
The absolute date is the number of days elapsed since the (imaginary)
|
||||
Gregorian date Sunday, December 31, 1 BC."
|
||||
(let ((month (extract-calendar-month date))
|
||||
(day (extract-calendar-day date))
|
||||
(year (extract-calendar-year date)))
|
||||
(+ (* 365 (1- year));; Days in prior years
|
||||
;; Leap days in prior years
|
||||
(if (< year 20)
|
||||
(/ year 4);; Actual and anticipated practice (years 3, 7, 11, 15)
|
||||
;; Romme's proposed rule (using the Principle of Inclusion/Exclusion)
|
||||
(+ (/ (1- year) 4);; Luckily, there were 4 leap years before year 20
|
||||
(- (/ (1- year) 100))
|
||||
(/ (1- year) 400)
|
||||
(- (/ (1- year) 4000))))
|
||||
(* 30 (1- month));; Days in prior months this year
|
||||
day;; Days so far this month
|
||||
654414)));; Days before start of calendar (September 22, 1792).
|
||||
|
||||
(defun calendar-french-from-absolute (date)
|
||||
"Compute the French Revolutionary date (month day year) corresponding to
|
||||
absolute DATE. The absolute date is the number of days elapsed since the
|
||||
(imaginary) Gregorian date Sunday, December 31, 1 BC."
|
||||
(if (< date 654415)
|
||||
(list 0 0 0);; pre-French Revolutionary date
|
||||
(let* ((approx (/ (- date 654414) 366));; Approximation from below.
|
||||
(year ;; Search forward from the approximation.
|
||||
(+ approx
|
||||
(calendar-sum y approx
|
||||
(>= date (calendar-absolute-from-french (list 1 1 (1+ y))))
|
||||
1)))
|
||||
(month ;; Search forward from Vendemiaire.
|
||||
(1+ (calendar-sum m 1
|
||||
(> date
|
||||
(calendar-absolute-from-french
|
||||
(list m
|
||||
(french-calendar-last-day-of-month m year)
|
||||
year)))
|
||||
1)))
|
||||
(day ;; Calculate the day by subtraction.
|
||||
(- date
|
||||
(1- (calendar-absolute-from-french (list month 1 year))))))
|
||||
(list month day year))))
|
||||
|
||||
(defun calendar-print-french-date ()
|
||||
"Show the French Revolutionary calendar equivalent of the date under the
|
||||
cursor."
|
||||
(interactive)
|
||||
(let* ((french-date (calendar-french-from-absolute
|
||||
(calendar-absolute-from-gregorian
|
||||
(or (calendar-cursor-to-date)
|
||||
(error "Cursor is not on a date!")))))
|
||||
(y (extract-calendar-year french-date))
|
||||
(m (extract-calendar-month french-date))
|
||||
(d (extract-calendar-day french-date)))
|
||||
(if (< y 1)
|
||||
(message "Date is pre-French Revolution")
|
||||
(if (= m 13)
|
||||
(message "Jour %s de l'Anne'e %d de la Revolution"
|
||||
(aref french-calendar-special-days-array (1- d))
|
||||
y)
|
||||
(message "Decade %s, %s de %s de l'Anne'e %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 calendar-goto-french-date (date &optional noecho)
|
||||
"Move cursor to French Revolutionary DATE.
|
||||
Echo French Revolutionary date unless NOECHO is t."
|
||||
(interactive
|
||||
(let* ((year (calendar-read
|
||||
"Anne'e de la Revolution (>0): "
|
||||
'(lambda (x) (> x 0))
|
||||
(int-to-string
|
||||
(extract-calendar-year
|
||||
(calendar-french-from-absolute
|
||||
(calendar-absolute-from-gregorian
|
||||
(calendar-current-date)))))))
|
||||
(month-list
|
||||
(mapcar 'list
|
||||
(append french-calendar-month-name-array
|
||||
(if (french-calendar-leap-year-p year)
|
||||
(mapcar
|
||||
'(lambda (x) (concat "Jour " x))
|
||||
french-calendar-special-days-array)
|
||||
(cdr;; we don't want rev. day in a non-leap yr.
|
||||
(nreverse
|
||||
(mapcar
|
||||
'(lambda (x) (concat "Jour " x))
|
||||
french-calendar-special-days-array)))))))
|
||||
(completion-ignore-case t)
|
||||
(month (cdr (assoc
|
||||
(capitalize
|
||||
(completing-read
|
||||
"Mois ou Sansculottide: "
|
||||
month-list
|
||||
nil t))
|
||||
(calendar-make-alist
|
||||
month-list
|
||||
1
|
||||
'(lambda (x) (capitalize (car x)))))))
|
||||
(decade (if (> month 12)
|
||||
1
|
||||
(calendar-read
|
||||
"De'cade (1-3): "
|
||||
'(lambda (x) (memq x '(1 2 3))))))
|
||||
(day (if (> month 12)
|
||||
(- month 12)
|
||||
(calendar-read
|
||||
"Jour (1-10)): "
|
||||
'(lambda (x) (and (<= 1 x) (<= x 10))))))
|
||||
(month (if (> month 12) 13 month))
|
||||
(day (+ day (* 10 (1- decade)))))
|
||||
(list (list month day year))))
|
||||
(calendar-goto-date (calendar-gregorian-from-absolute
|
||||
(calendar-absolute-from-french date)))
|
||||
(or noecho (calendar-print-french-date)))
|
||||
|
||||
(defun diary-french-date ()
|
||||
"French calendar equivalent of date diary entry."
|
||||
(let* ((french-date (calendar-french-from-absolute
|
||||
(calendar-absolute-from-gregorian date)))
|
||||
(y (extract-calendar-year french-date))
|
||||
(m (extract-calendar-month french-date))
|
||||
(d (extract-calendar-day french-date)))
|
||||
(if (> y 0)
|
||||
(if (= m 13)
|
||||
(format "Jour %s de l'Anne'e %d de la Revolution"
|
||||
(aref french-calendar-special-days-array (1- d))
|
||||
y)
|
||||
(format "Decade %s, %s de %s de l'Anne'e %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)))))
|
||||
|
||||
(provide 'cal-french)
|
||||
|
||||
;;; cal-french.el ends here
|
||||
409
lisp/calendar/cal-mayan.el
Normal file
409
lisp/calendar/cal-mayan.el
Normal file
@ -0,0 +1,409 @@
|
||||
;;; cal-mayan.el --- calendar functions for the Mayan calendars.
|
||||
|
||||
;; Copyright (C) 1992 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Stewart M. Clamen <clamen@cs.cmu.edu>
|
||||
;; Edward M. Reingold <reingold@cs.uiuc.edu>
|
||||
;; Keywords: Mayan calendar, Maya, calendar, diary
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY. No author or distributor
|
||||
;; accepts responsibility to anyone for the consequences of using it
|
||||
;; or for whether it serves any particular purpose or works at all,
|
||||
;; unless he says so in writing. Refer to the GNU Emacs General Public
|
||||
;; License for full details.
|
||||
|
||||
;; Everyone is granted permission to copy, modify and redistribute
|
||||
;; GNU Emacs, but only under the conditions described in the
|
||||
;; GNU Emacs General Public License. A copy of this license is
|
||||
;; supposed to have been given to you along with GNU Emacs so you
|
||||
;; can know your rights and responsibilities. It should be in a
|
||||
;; file named COPYING. Among other things, the copyright notice
|
||||
;; and this notice must be preserved on all copies.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; This collection of functions implements the features of calendar.el and
|
||||
;; diary.el that deal with the Mayan calendar. It was written jointly by
|
||||
|
||||
;; Stewart M. Clamen School of Computer Science
|
||||
;; clamen@cs.cmu.edu Carnegie Mellon University
|
||||
;; 5000 Forbes Avenue
|
||||
;; Pittsburgh, PA 15213
|
||||
|
||||
;; and
|
||||
|
||||
;; Edward M. Reingold Department of Computer Science
|
||||
;; (217) 333-6733 University of Illinois at Urbana-Champaign
|
||||
;; reingold@cs.uiuc.edu 1304 West Springfield Avenue
|
||||
;; Urbana, Illinois 61801
|
||||
|
||||
;; Comments, improvements, and bug reports should be sent to Reingold.
|
||||
|
||||
;; Technical details of the Mayan calendrical calculations can be found in
|
||||
;; ``Calendrical Calculations, Part II: Three Historical Calendars''
|
||||
;; by E. M. Reingold, N. Dershowitz, and S. M. Clamen,
|
||||
;; Report Number UIUCDCS-R-92-1743, Department of Computer Science,
|
||||
;; University of Illinois, April, 1992.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'calendar)
|
||||
|
||||
(defun mayan-mod (m n)
|
||||
"Returns M mod N; value is *always* non-negative when N>0."
|
||||
(let ((v (% m n)))
|
||||
(if (and (> 0 v) (> n 0))
|
||||
(+ v n)
|
||||
v)))
|
||||
|
||||
(defun mayan-adjusted-mod (m n)
|
||||
"Non-negative remainder of M/N with N instead of 0."
|
||||
(1+ (mayan-mod (1- m) n)))
|
||||
|
||||
(defconst calendar-mayan-days-before-absolute-zero 1137140
|
||||
"Number of days of the Mayan calendar epoch before absolute day 0 (that is,
|
||||
Dec 31, 0 (Gregorian)), according to the Goodman-Martinez-Thompson
|
||||
correlation. This correlation is not universally accepted, as it still a
|
||||
subject of astro-archeological research. Using 1232041 will give you the
|
||||
correlation used by Spinden.")
|
||||
|
||||
(defconst calendar-mayan-haab-at-epoch '(8 . 18)
|
||||
"Mayan haab date at the epoch.")
|
||||
|
||||
(defconst calendar-mayan-haab-month-name-array
|
||||
["Pop" "Uo" "Zip" "Zotz" "Tzec" "Xul" "Yaxkin" "Mol" "Chen" "Yax"
|
||||
"Zac" "Ceh" "Mac" "Kankin" "Muan" "Pax" "Kayab" "Cumku"])
|
||||
|
||||
(defconst calendar-mayan-tzolkin-at-epoch '(4 . 20)
|
||||
"Mayan tzolkin date at the epoch.")
|
||||
|
||||
(defconst calendar-mayan-tzolkin-names-array
|
||||
["Imix" "Ik" "Akbal" "Kan" "Chicchan" "Cimi" "Manik" "Lamat" "Muluc" "Oc"
|
||||
"Chuen" "Eb" "Ben" "Ix" "Men" "Cib" "Caban" "Etznab" "Cauac" "Ahau"])
|
||||
|
||||
(defun calendar-mayan-long-count-from-absolute (date)
|
||||
"Compute the Mayan long count corresponding to the absolute DATE."
|
||||
(let ((long-count (+ date calendar-mayan-days-before-absolute-zero)))
|
||||
(let* ((baktun (/ long-count 144000))
|
||||
(remainder (% long-count 144000))
|
||||
(katun (/ remainder 7200))
|
||||
(remainder (% remainder 7200))
|
||||
(tun (/ remainder 360))
|
||||
(remainder (% remainder 360))
|
||||
(uinal (/ remainder 20))
|
||||
(kin (% remainder 20)))
|
||||
(list baktun katun tun uinal kin))))
|
||||
|
||||
(defun calendar-mayan-long-count-to-string (mayan-long-count)
|
||||
"Convert MAYAN-LONG-COUNT into traditional written form."
|
||||
(apply 'format (cons "%s.%s.%s.%s.%s" mayan-long-count)))
|
||||
|
||||
(defun calendar-string-to-mayan-long-count (str)
|
||||
"Given STR, a string of format \"%d.%d.%d.%d.%d\", return list of nums."
|
||||
(let ((rlc nil)
|
||||
(c (length str))
|
||||
(cc 0))
|
||||
(condition-case condition
|
||||
(progn
|
||||
(while (< cc c)
|
||||
(let ((datum (read-from-string str cc)))
|
||||
(if (not (integerp (car datum)))
|
||||
(signal 'invalid-read-syntax (car datum))
|
||||
(setq rlc (cons (car datum) rlc))
|
||||
(setq cc (cdr datum)))))
|
||||
(if (not (= (length rlc) 5)) (signal 'invalid-read-syntax nil)))
|
||||
(invalid-read-syntax nil))
|
||||
(reverse rlc)))
|
||||
|
||||
(defun calendar-mayan-haab-from-absolute (date)
|
||||
"Convert absolute DATE into a Mayan haab date (a pair)."
|
||||
(let* ((long-count (+ date calendar-mayan-days-before-absolute-zero))
|
||||
(day-of-haab
|
||||
(% (+ long-count
|
||||
(car calendar-mayan-haab-at-epoch)
|
||||
(* 20 (1- (cdr calendar-mayan-haab-at-epoch))))
|
||||
365))
|
||||
(day (% day-of-haab 20))
|
||||
(month (1+ (/ day-of-haab 20))))
|
||||
(cons day month)))
|
||||
|
||||
(defun calendar-mayan-haab-difference (date1 date2)
|
||||
"Number of days from Mayan haab date DATE1 to the next occurrence of Mayan
|
||||
haab date DATE2."
|
||||
(mayan-mod (+ (* 20 (- (cdr date2) (cdr date1)))
|
||||
(- (car date2) (car date1)))
|
||||
365))
|
||||
|
||||
(defun calendar-mayan-haab-on-or-before (haab-date date)
|
||||
"Absolute date of latest HAAB-DATE on or before absolute DATE."
|
||||
(- date
|
||||
(mod (- date
|
||||
(calendar-mayan-haab-difference
|
||||
(calendar-mayan-haab-from-absolute 0) haab-date))
|
||||
365)))
|
||||
|
||||
(defun calendar-next-haab-date (haab-date &optional noecho)
|
||||
"Move cursor to next instance of Mayan HAAB-DATE.
|
||||
Echo Mayan date if NOECHO is t."
|
||||
(interactive (list (calendar-read-mayan-haab-date)))
|
||||
(calendar-goto-date
|
||||
(calendar-gregorian-from-absolute
|
||||
(calendar-mayan-haab-on-or-before
|
||||
haab-date
|
||||
(+ 365
|
||||
(calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
|
||||
(or noecho (calendar-print-mayan-date)))
|
||||
|
||||
(defun calendar-previous-haab-date (haab-date &optional noecho)
|
||||
"Move cursor to previous instance of Mayan HAAB-DATE.
|
||||
Echo Mayan date if NOECHO is t."
|
||||
(interactive (list (calendar-read-mayan-haab-date)))
|
||||
(calendar-goto-date
|
||||
(calendar-gregorian-from-absolute
|
||||
(calendar-mayan-haab-on-or-before
|
||||
haab-date
|
||||
(1- (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
|
||||
(or noecho (calendar-print-mayan-date)))
|
||||
|
||||
(defun calendar-mayan-haab-to-string (haab)
|
||||
"Convert Mayan haab date (a pair) into its traditional written form."
|
||||
(let ((month (cdr haab))
|
||||
(day (car haab)))
|
||||
;; 19th month consists of 5 special days
|
||||
(if (= month 19)
|
||||
(format "%d Uayeb" day)
|
||||
(format "%d %s"
|
||||
day
|
||||
(aref calendar-mayan-haab-month-name-array (1- month))))))
|
||||
|
||||
(defun calendar-mayan-tzolkin-from-absolute (date)
|
||||
"Convert absolute DATE into a Mayan tzolkin date (a pair)."
|
||||
(let* ((long-count (+ date calendar-mayan-days-before-absolute-zero))
|
||||
(day (mayan-adjusted-mod
|
||||
(+ long-count (car calendar-mayan-tzolkin-at-epoch))
|
||||
13))
|
||||
(name (mayan-adjusted-mod
|
||||
(+ long-count (cdr calendar-mayan-tzolkin-at-epoch))
|
||||
20)))
|
||||
(cons day name)))
|
||||
|
||||
(defun calendar-mayan-tzolkin-difference (date1 date2)
|
||||
"Number of days from Mayan tzolkin date DATE1 to the next occurrence of
|
||||
Mayan tzolkin date DATE2."
|
||||
(let ((number-difference (- (car date2) (car date1)))
|
||||
(name-difference (- (cdr date2) (cdr date1))))
|
||||
(mayan-mod (+ number-difference
|
||||
(* 13 (mayan-mod (* 3 (- number-difference name-difference))
|
||||
20)))
|
||||
260)))
|
||||
|
||||
(defun calendar-mayan-tzolkin-on-or-before (tzolkin-date date)
|
||||
"Absolute date of latest TZOLKIN-DATE on or before absolute DATE."
|
||||
(- date
|
||||
(mod (- date (calendar-mayan-tzolkin-difference
|
||||
(calendar-mayan-tzolkin-from-absolute 0)
|
||||
tzolkin-date))
|
||||
260)))
|
||||
|
||||
(defun calendar-next-tzolkin-date (tzolkin-date &optional noecho)
|
||||
"Move cursor to next instance of Mayan TZOLKIN-DATE.
|
||||
Echo Mayan date if NOECHO is t."
|
||||
(interactive (list (calendar-read-mayan-tzolkin-date)))
|
||||
(calendar-goto-date
|
||||
(calendar-gregorian-from-absolute
|
||||
(calendar-mayan-tzolkin-on-or-before
|
||||
tzolkin-date
|
||||
(+ 260
|
||||
(calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
|
||||
(or noecho (calendar-print-mayan-date)))
|
||||
|
||||
(defun calendar-previous-tzolkin-date (tzolkin-date &optional noecho)
|
||||
"Move cursor to previous instance of Mayan TZOLKIN-DATE.
|
||||
Echo Mayan date if NOECHO is t."
|
||||
(interactive (list (calendar-read-mayan-tzolkin-date)))
|
||||
(calendar-goto-date
|
||||
(calendar-gregorian-from-absolute
|
||||
(calendar-mayan-tzolkin-on-or-before
|
||||
tzolkin-date
|
||||
(1- (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
|
||||
(or noecho (calendar-print-mayan-date)))
|
||||
|
||||
(defun calendar-mayan-tzolkin-to-string (tzolkin)
|
||||
"Convert Mayan tzolkin date (a pair) into its traditional written form."
|
||||
(format "%d %s"
|
||||
(car tzolkin)
|
||||
(aref calendar-mayan-tzolkin-names-array (1- (cdr tzolkin)))))
|
||||
|
||||
(defun calendar-mayan-tzolkin-haab-on-or-before (tzolkin-date haab-date date)
|
||||
"Absolute date of latest date on or before date that is Mayan TZOLKIN-DATE
|
||||
and HAAB-DATE; returns nil if such a tzolkin-haab combination is impossible."
|
||||
(let* ((haab-difference
|
||||
(calendar-mayan-haab-difference
|
||||
(calendar-mayan-haab-from-absolute 0)
|
||||
haab-date))
|
||||
(tzolkin-difference
|
||||
(calendar-mayan-tzolkin-difference
|
||||
(calendar-mayan-tzolkin-from-absolute 0)
|
||||
tzolkin-date))
|
||||
(difference (- tzolkin-difference haab-difference)))
|
||||
(if (= (% difference 5) 0)
|
||||
(- date
|
||||
(mayan-mod (- date
|
||||
(+ haab-difference (* 365 difference)))
|
||||
18980))
|
||||
nil)))
|
||||
|
||||
(defun calendar-read-mayan-haab-date ()
|
||||
"Prompt for a Mayan haab date"
|
||||
(let* ((completion-ignore-case t)
|
||||
(haab-day (calendar-read
|
||||
"Haab kin (0-19): "
|
||||
'(lambda (x) (and (>= x 0) (< x 20)))))
|
||||
(haab-month-list (append calendar-mayan-haab-month-name-array
|
||||
(and (< haab-day 5) '("Uayeb"))))
|
||||
(haab-month (cdr
|
||||
(assoc
|
||||
(capitalize
|
||||
(completing-read "Haab uinal: "
|
||||
(mapcar 'list haab-month-list)
|
||||
nil t))
|
||||
(calendar-make-alist
|
||||
haab-month-list 1 'capitalize)))))
|
||||
(cons haab-day haab-month)))
|
||||
|
||||
(defun calendar-read-mayan-tzolkin-date ()
|
||||
"Prompt for a Mayan tzolkin date"
|
||||
(let* ((completion-ignore-case t)
|
||||
(tzolkin-count (calendar-read
|
||||
"Tzolkin kin (1-13): "
|
||||
'(lambda (x) (and (> x 0) (< x 14)))))
|
||||
(tzolkin-name-list (append calendar-mayan-tzolkin-names-array nil))
|
||||
(tzolkin-name (cdr
|
||||
(assoc
|
||||
(capitalize
|
||||
(completing-read "Tzolkin uinal: "
|
||||
(mapcar 'list tzolkin-name-list)
|
||||
nil t))
|
||||
(calendar-make-alist
|
||||
tzolkin-name-list 1 'capitalize)))))
|
||||
(cons tzolkin-count tzolkin-name)))
|
||||
|
||||
(defun calendar-next-tzolkin-date (tzolkin-date &optional noecho)
|
||||
"Move cursor to next instance of Mayan TZOLKIN-DATE.
|
||||
Echo Mayan date if NOECHO is t."
|
||||
(interactive (list (calendar-read-mayan-tzolkin-date)))
|
||||
(let* ((date (calendar-absolute-from-gregorian (calendar-cursor-to-date)))
|
||||
(tomorrow-tzolkin-date
|
||||
(calendar-mayan-tzolkin-from-absolute (1+ date))))
|
||||
(calendar-goto-date
|
||||
(calendar-gregorian-from-absolute
|
||||
(+ date 1
|
||||
(calendar-mayan-tzolkin-difference
|
||||
tomorrow-tzolkin-date tzolkin-date)))))
|
||||
(or noecho (calendar-print-mayan-date)))
|
||||
|
||||
(defun calendar-next-calendar-round-date
|
||||
(tzolkin-date haab-date &optional noecho)
|
||||
"Move cursor to next instance of Mayan HAAB-DATE TZOKLIN-DATE combination.
|
||||
Echo Mayan date if NOECHO is t."
|
||||
(interactive (list (calendar-read-mayan-tzolkin-date)
|
||||
(calendar-read-mayan-haab-date)))
|
||||
(let ((date (calendar-mayan-tzolkin-haab-on-or-before
|
||||
tzolkin-date haab-date
|
||||
(+ 18980 (calendar-absolute-from-gregorian
|
||||
(calendar-cursor-to-date))))))
|
||||
(if (not date)
|
||||
(error "%s, %s does not exist in the Mayan calendar round"
|
||||
(calendar-mayan-tzolkin-to-string tzolkin-date)
|
||||
(calendar-mayan-haab-to-string haab-date))
|
||||
(calendar-goto-date (calendar-gregorian-from-absolute date))
|
||||
(or noecho (calendar-print-mayan-date)))))
|
||||
|
||||
(defun calendar-previous-calendar-round-date
|
||||
(tzolkin-date haab-date &optional noecho)
|
||||
"Move cursor to previous instance of Mayan TZOKLIN-DATE HAAB-DATE
|
||||
combination. Echo Mayan date if NOECHO is t."
|
||||
(interactive (list (calendar-read-mayan-tzolkin-date)
|
||||
(calendar-read-mayan-haab-date)))
|
||||
(let ((date (calendar-mayan-tzolkin-haab-on-or-before
|
||||
tzolkin-date haab-date
|
||||
(1- (calendar-absolute-from-gregorian
|
||||
(calendar-cursor-to-date))))))
|
||||
(if (not date)
|
||||
(error "%s, %s does not exist in the Mayan calendar round"
|
||||
(calendar-mayan-tzolkin-to-string tzolkin-date)
|
||||
(calendar-mayan-haab-to-string haab-date))
|
||||
(calendar-goto-date (calendar-gregorian-from-absolute date))
|
||||
(or noecho (calendar-print-mayan-date)))))
|
||||
|
||||
(defun calendar-absolute-from-mayan-long-count (c)
|
||||
"Compute the absolute date corresponding to the Mayan Long
|
||||
Count $c$, which is a list (baktun katun tun uinal kin)"
|
||||
(+ (* (nth 0 c) 144000) ; baktun
|
||||
(* (nth 1 c) 7200) ; katun
|
||||
(* (nth 2 c) 360) ; tun
|
||||
(* (nth 3 c) 20) ; uinal
|
||||
(nth 4 c) ; kin (days)
|
||||
(- ; days before absolute date 0
|
||||
calendar-mayan-days-before-absolute-zero)))
|
||||
|
||||
(defun calendar-print-mayan-date ()
|
||||
"Show the Mayan long count, tzolkin, and haab equivalents of the date
|
||||
under the cursor."
|
||||
(interactive)
|
||||
(let* ((d (calendar-absolute-from-gregorian
|
||||
(or (calendar-cursor-to-date)
|
||||
(error "Cursor is not on a date!"))))
|
||||
(tzolkin (calendar-mayan-tzolkin-from-absolute d))
|
||||
(haab (calendar-mayan-haab-from-absolute d))
|
||||
(long-count (calendar-mayan-long-count-from-absolute d)))
|
||||
(message "Mayan date: Long count = %s; tzolkin = %s; haab = %s"
|
||||
(calendar-mayan-long-count-to-string long-count)
|
||||
(calendar-mayan-tzolkin-to-string haab)
|
||||
(calendar-mayan-haab-to-string tzolkin))))
|
||||
|
||||
(defun calendar-goto-mayan-long-count-date (date &optional noecho)
|
||||
"Move cursor to Mayan long count DATE. Echo Mayan date unless NOECHO is t."
|
||||
(interactive
|
||||
(let (lc)
|
||||
(while (not lc)
|
||||
(let ((datum
|
||||
(calendar-string-to-mayan-long-count
|
||||
(read-string "Mayan long count (baktun.katun.tun.uinal.kin): "
|
||||
(calendar-mayan-long-count-to-string
|
||||
(calendar-mayan-long-count-from-absolute
|
||||
(calendar-absolute-from-gregorian
|
||||
(calendar-current-date))))))))
|
||||
(if (calendar-mayan-long-count-common-era datum)
|
||||
(setq lc datum))))
|
||||
(list lc)))
|
||||
(calendar-goto-date
|
||||
(calendar-gregorian-from-absolute
|
||||
(calendar-absolute-from-mayan-long-count date)))
|
||||
(or noecho (calendar-print-mayan-date)))
|
||||
|
||||
(defun calendar-mayan-long-count-common-era (lc)
|
||||
"T if long count represents date in the Common Era."
|
||||
(let ((base (calendar-mayan-long-count-from-absolute 1)))
|
||||
(while (and (not (null base)) (= (car lc) (car base)))
|
||||
(setq lc (cdr lc)
|
||||
base (cdr base)))
|
||||
(or (null lc) (> (car lc) (car base)))))
|
||||
|
||||
(defun diary-mayan-date ()
|
||||
"Show the Mayan long count, haab, and tzolkin dates as a diary entry."
|
||||
(let* ((d (calendar-absolute-from-gregorian date))
|
||||
(tzolkin (calendar-mayan-tzolkin-from-absolute d))
|
||||
(haab (calendar-mayan-haab-from-absolute d))
|
||||
(long-count (calendar-mayan-long-count-from-absolute d)))
|
||||
(format "Mayan date: Long count = %s; tzolkin = %s; haab = %s"
|
||||
(calendar-mayan-long-count-to-string long-count)
|
||||
(calendar-mayan-tzolkin-to-string haab)
|
||||
(calendar-mayan-haab-to-string tzolkin))))
|
||||
|
||||
(provide 'cal-mayan)
|
||||
|
||||
;;; cal-mayan.el ends here
|
||||
File diff suppressed because it is too large
Load Diff
@ -1,9 +1,9 @@
|
||||
;;; holidays.el --- holiday functions for the calendar package
|
||||
|
||||
;;; 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>
|
||||
;; Keywords: calendar
|
||||
;; Keywords: holidays, calendar
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
@ -36,21 +36,51 @@
|
||||
;; Technical details of all the calendrical calculations can be found in
|
||||
;; ``Calendrical Calculations'' by Nachum Dershowitz and Edward M. Reingold,
|
||||
;; Software--Practice and Experience, Volume 20, Number 9 (September, 1990),
|
||||
;; pages 899-928.
|
||||
;; pages 899-928. ``Calendrical Calculations, Part II: Three Historical
|
||||
;; Calendars'' by E. M. Reingold, N. Dershowitz, and S. M. Clamen,
|
||||
;; Report Number UIUCDCS-R-92-1743, Department of Computer Science,
|
||||
;; University of Illinois, April, 1992.
|
||||
|
||||
;; Hard copies of these two papers can be obtained by sending email to
|
||||
;; reingold@cs.uiuc.edu with the SUBJECT "send-paper-cal" (no quotes) and
|
||||
;; the message BODY containing your mailing address (snail).
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'calendar)
|
||||
|
||||
;;;###autoload
|
||||
(defun holidays ()
|
||||
(autoload 'calendar-holiday-function-solar-equinoxes-solstices "solar"
|
||||
"Date and time of equinoxes and solstices, if visible in the calendar window.
|
||||
Requires floating point."
|
||||
t)
|
||||
|
||||
(defun holidays (&optional arg)
|
||||
"Display the holidays for last month, this month, and next month.
|
||||
If called with an optional prefix argument, prompts for month and year.
|
||||
|
||||
This function is suitable for execution in a .emacs file."
|
||||
(interactive)
|
||||
(interactive "P")
|
||||
(save-excursion
|
||||
(let* ((date (calendar-current-date))
|
||||
(displayed-month (extract-calendar-month date))
|
||||
(displayed-year (extract-calendar-year date)))
|
||||
(let* ((completion-ignore-case t)
|
||||
(date (calendar-current-date))
|
||||
(displayed-month
|
||||
(if arg
|
||||
(cdr (assoc
|
||||
(capitalize
|
||||
(completing-read
|
||||
"Month name: "
|
||||
(mapcar 'list (append calendar-month-name-array nil))
|
||||
nil t))
|
||||
(calendar-make-alist calendar-month-name-array)))
|
||||
(extract-calendar-month date)))
|
||||
(displayed-year
|
||||
(if arg
|
||||
(calendar-read
|
||||
"Year (>0): "
|
||||
'(lambda (x) (> x 0))
|
||||
(int-to-string
|
||||
(extract-calendar-year (calendar-current-date))))
|
||||
(extract-calendar-year date))))
|
||||
(list-calendar-holidays))))
|
||||
|
||||
(defun check-calendar-holidays (date)
|
||||
@ -79,13 +109,11 @@ The holidays are those in the list calendar-holidays."
|
||||
(msg (format "%s: %s" date-string holiday-string)))
|
||||
(if (not holiday-list)
|
||||
(message "No holidays known for %s" date-string)
|
||||
(if (<= (length msg) (frame-width))
|
||||
(if (<= (length msg) (screen-width))
|
||||
(message msg)
|
||||
(set-buffer (get-buffer-create holiday-buffer))
|
||||
(setq buffer-read-only nil)
|
||||
(setq mode-line-format
|
||||
(format "--------------------------%s%%-"
|
||||
date-string))
|
||||
(calendar-set-mode-line date-string)
|
||||
(erase-buffer)
|
||||
(insert (mapconcat 'identity holiday-list "\n"))
|
||||
(goto-char (point-min))
|
||||
@ -125,8 +153,8 @@ holidays are found, nil if not."
|
||||
(setq buffer-read-only nil)
|
||||
(increment-calendar-month m1 y1 -1)
|
||||
(increment-calendar-month m2 y2 1)
|
||||
(setq mode-line-format
|
||||
(format "-------------Notable Dates from %s, %d to %s, %d%%-"
|
||||
(calendar-set-mode-line
|
||||
(format "Notable Dates from %s, %d to %s, %d%%-"
|
||||
(calendar-month-name m1) y1 (calendar-month-name m2) y2))
|
||||
(erase-buffer)
|
||||
(insert
|
||||
@ -150,9 +178,14 @@ The holidays are those in the list calendar-holidays."
|
||||
(let* ((function-name
|
||||
(intern (format "calendar-holiday-function-%s" (car (car p)))))
|
||||
(holidays
|
||||
(if (cdr (car p));; optional arguments
|
||||
(funcall function-name (cdr (car p)))
|
||||
(funcall function-name))))
|
||||
(condition-case nil
|
||||
(if (cdr (car p));; optional arguments
|
||||
(funcall function-name (cdr (car p)))
|
||||
(funcall function-name))
|
||||
(error
|
||||
(beep)
|
||||
(message "Bad holiday list item: %s" (car p))
|
||||
(sleep-for 2)))))
|
||||
(if holidays
|
||||
(setq holiday-list (append holidays holiday-list))))
|
||||
(setq p (cdr p)))
|
||||
@ -164,13 +197,13 @@ The holidays are those in the list calendar-holidays."
|
||||
;; including the evaluation of each element in the list that constitutes
|
||||
;; the argument to the function. If you don't do this evaluation, the
|
||||
;; list calendar-holidays cannot contain expressions (as, for example, in
|
||||
;; the entry for the Islamic new year. Also remember that each function
|
||||
;; the entry for the Islamic new year.) Also remember that each function
|
||||
;; must return a list of items of the form ((month day year) string);
|
||||
;; the date (month day year) should be visible in the calendar window.
|
||||
|
||||
(defun calendar-holiday-function-fixed (x)
|
||||
"Returns the corresponding Gregorian date, if visible in the window, to
|
||||
month, year where month is (car X) and year is (car (cdr X)). If it is
|
||||
(month day) where month is (car X) and day is (car (cdr X)). If it is
|
||||
visible, the value returned is the list (((month day year) string)) where
|
||||
string is (car (nthcdr 2 X)). Returns nil if it is not visible in the
|
||||
current calendar window."
|
||||
@ -186,9 +219,9 @@ current calendar window."
|
||||
(defun calendar-holiday-function-float (x)
|
||||
"Returns the corresponding Gregorian date, if visible in the window, to the
|
||||
n-th occurrence (negative counts from the end of the month) of dayname in
|
||||
month, year where month is (car X), year is (car (cdr X)), n is
|
||||
\(car \(nthcdr 2 X\)\). If it is visible, the value returned is the list
|
||||
\(\(\(month day year)\ string\)\) where string is (car (nthcdr 3 X)).
|
||||
month where month is (car X), dayname is (car (cdr X)), and n is
|
||||
(car (nthcdr 2 X)). If it is visible, the value returned is the list
|
||||
(((month day year) string)) where string is (car (nthcdr 3 X)).
|
||||
Returns nil if it is not visible in the current calendar window."
|
||||
(let* ((month (eval (car x)))
|
||||
(dayname (eval (car (cdr x))))
|
||||
@ -202,7 +235,7 @@ Returns nil if it is not visible in the current calendar window."
|
||||
|
||||
(defun calendar-holiday-function-julian (x)
|
||||
"Returns the corresponding Gregorian date, if visible in the window, to the
|
||||
Julian date month, year where month is (car X) and year is (car (cdr X)).
|
||||
Julian date (month day) where month is (car X) and day is (car (cdr X)).
|
||||
If it is visible, the value returned is the list (((month day year) string))
|
||||
where string is (car (nthcdr 2 X)). Returns nil if it is not visible in the
|
||||
current calendar window."
|
||||
@ -233,7 +266,7 @@ current calendar window."
|
||||
|
||||
(defun calendar-holiday-function-islamic (x)
|
||||
"Returns the corresponding Gregorian date, if visible in the window, to the
|
||||
Islamic date month, day where month is (car X) and day is (car (cdr X)).
|
||||
Islamic date (month day) where month is (car X) and day is (car (cdr X)).
|
||||
If it is visible, the value returned is the list (((month day year) string))
|
||||
where string is (car (nthcdr 2 X)). Returns nil if it is not visible in
|
||||
the current calendar window."
|
||||
@ -257,7 +290,7 @@ the current calendar window."
|
||||
|
||||
(defun calendar-holiday-function-hebrew (x)
|
||||
"Returns the corresponding Gregorian date, if visible in the window, to the
|
||||
Hebrew date month, day where month is (car X) and day is (car (cdr X)).
|
||||
Hebrew date (month day) where month is (car X) and day is (car (cdr X)).
|
||||
If it is visible, the value returned is the list (((month day year) string))
|
||||
where string is (car (nthcdr 2 X)). Returns nil if it is not visible in
|
||||
the current calendar window."
|
||||
@ -308,6 +341,21 @@ checked. If nil, the holiday (car (cdr (cdr X))), if there, is checked."
|
||||
(funcall function-name))))
|
||||
holidays))))
|
||||
|
||||
(defun calendar-holiday-function-sexp (x)
|
||||
"Sexp holiday for dates in the calendar window.
|
||||
The sexp (in `year') is (car X). If the sexp evals to a date visible in the
|
||||
calendar window, the holiday (car (cdr X)) is on that date. If the sexp evals
|
||||
to nil, or if the date is not visible, there is no holiday."
|
||||
(let ((m displayed-month)
|
||||
(y displayed-year))
|
||||
(increment-calendar-month m y -1)
|
||||
(filter-visible-calendar-holidays
|
||||
(append
|
||||
(let ((year y))
|
||||
(list (list (eval (car x)) (eval (car (cdr x))))))
|
||||
(let ((year (1+ y)))
|
||||
(list (list (eval (car x)) (eval (car (cdr x))))))))))
|
||||
|
||||
(defun calendar-holiday-function-advent ()
|
||||
"Date of Advent, if visible in calendar window."
|
||||
(let ((year displayed-year)
|
||||
@ -389,6 +437,30 @@ checked. If nil, the holiday (car (cdr (cdr X))), if there, is checked."
|
||||
output-list)))
|
||||
output-list)))
|
||||
|
||||
(defun calendar-holiday-function-greek-orthodox-easter ()
|
||||
"Date of Easter according to the rule of the Council of Nicaea, if visible
|
||||
in the calendar window."
|
||||
(let ((m displayed-month)
|
||||
(y displayed-year))
|
||||
(increment-calendar-month m y 1)
|
||||
(let* ((julian-year
|
||||
(extract-calendar-year
|
||||
(calendar-julian-from-absolute
|
||||
(calendar-absolute-from-gregorian
|
||||
(list m (calendar-last-day-of-month m y) y)))))
|
||||
(shifted-epact ;; Age of moon for April 5.
|
||||
(% (+ 14
|
||||
(* 11 (% julian-year 19)))
|
||||
30))
|
||||
(paschal-moon ;; Day after full moon on or after March 21.
|
||||
(- (calendar-absolute-from-julian (list 4 19 julian-year))
|
||||
shifted-epact))
|
||||
(nicaean-easter;; Sunday following the Paschal moon
|
||||
(calendar-gregorian-from-absolute
|
||||
(calendar-dayname-on-or-before 0 (+ paschal-moon 7)))))
|
||||
(if (calendar-date-is-visible-p nicaean-easter)
|
||||
(list (list nicaean-easter "Pascha (Greek Orthodox Easter)"))))))
|
||||
|
||||
(defun calendar-holiday-function-rosh-hashanah-etc ()
|
||||
"List of dates related to Rosh Hashanah, as visible in calendar window."
|
||||
(if (or (< displayed-month 8)
|
||||
|
||||
290
lisp/calendar/lunar.el
Normal file
290
lisp/calendar/lunar.el
Normal file
@ -0,0 +1,290 @@
|
||||
;;; lunar.el --- calendar functions for phases of the moon.
|
||||
|
||||
;; Copyright (C) 1992 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
|
||||
;; Keywords: moon, lunar phases, calendar, diary
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY. No author or distributor
|
||||
;; accepts responsibility to anyone for the consequences of using it
|
||||
;; or for whether it serves any particular purpose or works at all,
|
||||
;; unless he says so in writing. Refer to the GNU Emacs General Public
|
||||
;; License for full details.
|
||||
|
||||
;; Everyone is granted permission to copy, modify and redistribute
|
||||
;; GNU Emacs, but only under the conditions described in the
|
||||
;; GNU Emacs General Public License. A copy of this license is
|
||||
;; supposed to have been given to you along with GNU Emacs so you
|
||||
;; can know your rights and responsibilities. It should be in a
|
||||
;; file named COPYING. Among other things, the copyright notice
|
||||
;; and this notice must be preserved on all copies.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; This collection of functions implements lunar phases for calendar.el and
|
||||
;; diary.el.
|
||||
|
||||
;; Based on ``Astronomical Formulae for Calculators,'' 3rd ed., by Jean Meeus,
|
||||
;; Willmann-Bell, Inc., 1985.
|
||||
;;
|
||||
;; WARNING: The calculations will be accurate only to within a few minutes.
|
||||
|
||||
;; The author would be delighted to have an astronomically more sophisticated
|
||||
;; person rewrite the code for the lunar calculations in this file!
|
||||
|
||||
;; Comments, corrections, and improvements should be sent to
|
||||
;; Edward M. Reingold Department of Computer Science
|
||||
;; (217) 333-6733 University of Illinois at Urbana-Champaign
|
||||
;; reingold@cs.uiuc.edu 1304 West Springfield Avenue
|
||||
;; Urbana, Illinois 61801
|
||||
|
||||
;;; Code:
|
||||
|
||||
(if (fboundp 'atan)
|
||||
(require 'lisp-float-type)
|
||||
(error "Lunar calculations impossible since floating point is unavailable."))
|
||||
|
||||
(require 'solar)
|
||||
|
||||
(defun lunar-phase-list (month year)
|
||||
"List of lunar phases for three months starting with Gregorian MONTH, YEAR."
|
||||
(let ((end-month month)
|
||||
(end-year year)
|
||||
(start-month month)
|
||||
(start-year year))
|
||||
(increment-calendar-month end-month end-year 3)
|
||||
(increment-calendar-month start-month start-year -1)
|
||||
(let* ((end-date (list (list end-month 1 end-year)))
|
||||
(start-date (list (list start-month
|
||||
(calendar-last-day-of-month
|
||||
start-month start-year)
|
||||
start-year)))
|
||||
(index (* 4
|
||||
(truncate
|
||||
(* 12.3685
|
||||
(+ year
|
||||
( / (calendar-day-number (list month 1 year))
|
||||
366.0)
|
||||
-1900)))))
|
||||
(new-moon (lunar-phase index))
|
||||
(list))
|
||||
(while (calendar-date-compare new-moon end-date)
|
||||
(if (calendar-date-compare start-date new-moon)
|
||||
(setq list (append list (list new-moon))))
|
||||
(setq index (1+ index))
|
||||
(setq new-moon (lunar-phase index)))
|
||||
list)))
|
||||
|
||||
(defun lunar-phase (index)
|
||||
"Local date and time of lunar phase INDEX.
|
||||
Integer below INDEX/4 gives the lunation number, counting from Jan 1, 1900;
|
||||
remainder mod 4 gives the phase: 0 new moon, 1 first quarter, 2 full moon,
|
||||
3 last quarter."
|
||||
(let* ((phase (% index 4))
|
||||
(index (/ index 4.0))
|
||||
(time (/ index 1236.85))
|
||||
(date (+ (calendar-absolute-from-gregorian '(1 0.5 1900))
|
||||
0.75933
|
||||
(* 29.53058868 index)
|
||||
(* 0.0001178 time time)
|
||||
(* -0.000000155 time time time)
|
||||
(* 0.00033
|
||||
(solar-sin-degrees (+ 166.56
|
||||
(* 132.87 time)
|
||||
(* -0.009173 time time))))))
|
||||
(sun-anomaly (solar-mod
|
||||
(+ 359.2242
|
||||
(* 29.105356 index)
|
||||
(* -0.0000333 time time)
|
||||
(* -0.00000347 time time time))
|
||||
360.0))
|
||||
(moon-anomaly (solar-mod
|
||||
(+ 306.0253
|
||||
(* 385.81691806 index)
|
||||
(* 0.0107306 time time)
|
||||
(* 0.00001236 time time time))
|
||||
360.0))
|
||||
(moon-lat (solar-mod
|
||||
(+ 21.2964
|
||||
(* 390.67050646 index)
|
||||
(* -0.0016528 time time)
|
||||
(* -0.00000239 time time time))
|
||||
360.0))
|
||||
(adjustment
|
||||
(if (memq phase '(0 2))
|
||||
(+ (* (- 0.1734 (* 0.000393 time))
|
||||
(solar-sin-degrees sun-anomaly))
|
||||
(* 0.0021 (solar-sin-degrees (* 2 sun-anomaly)))
|
||||
(* -0.4068 (solar-sin-degrees moon-anomaly))
|
||||
(* 0.0161 (solar-sin-degrees (* 2 moon-anomaly)))
|
||||
(* -0.0004 (solar-sin-degrees (* 3 moon-anomaly)))
|
||||
(* 0.0104 (solar-sin-degrees (* 2 moon-lat)))
|
||||
(* -0.0051 (solar-sin-degrees (+ sun-anomaly moon-anomaly)))
|
||||
(* -0.0074 (solar-sin-degrees (- sun-anomaly moon-anomaly)))
|
||||
(* 0.0004 (solar-sin-degrees (+ (* 2 moon-lat) sun-anomaly)))
|
||||
(* -0.0004 (solar-sin-degrees (- (* 2 moon-lat) sun-anomaly)))
|
||||
(* -0.0006 (solar-sin-degrees
|
||||
(+ (* 2 moon-lat) moon-anomaly)))
|
||||
(* 0.0010 (solar-sin-degrees (- (* 2 moon-lat) moon-anomaly)))
|
||||
(* 0.0005 (solar-sin-degrees
|
||||
(+ (* 2 moon-anomaly) sun-anomaly))))
|
||||
(+ (* (- 0.1721 (* 0.0004 time))
|
||||
(solar-sin-degrees sun-anomaly))
|
||||
(* 0.0021 (solar-sin-degrees (* 2 sun-anomaly)))
|
||||
(* -0.6280 (solar-sin-degrees moon-anomaly))
|
||||
(* 0.0089 (solar-sin-degrees (* 2 moon-anomaly)))
|
||||
(* -0.0004 (solar-sin-degrees (* 3 moon-anomaly)))
|
||||
(* 0.0079 (solar-sin-degrees (* 2 moon-lat)))
|
||||
(* -0.0119 (solar-sin-degrees (+ sun-anomaly moon-anomaly)))
|
||||
(* -0.0047 (solar-sin-degrees (- sun-anomaly moon-anomaly)))
|
||||
(* 0.0003 (solar-sin-degrees (+ (* 2 moon-lat) sun-anomaly)))
|
||||
(* -0.0004 (solar-sin-degrees (- (* 2 moon-lat) sun-anomaly)))
|
||||
(* -0.0006 (solar-sin-degrees (+ (* 2 moon-lat) moon-anomaly)))
|
||||
(* 0.0021 (solar-sin-degrees (- (* 2 moon-lat) moon-anomaly)))
|
||||
(* 0.0003 (solar-sin-degrees
|
||||
(+ (* 2 moon-anomaly) sun-anomaly)))
|
||||
(* 0.0004 (solar-sin-degrees
|
||||
(- sun-anomaly (* 2 moon-anomaly))))
|
||||
(* -0.0003 (solar-sin-degrees
|
||||
(+ (* 2 sun-anomaly) moon-anomaly))))))
|
||||
(adj (+ 0.0028
|
||||
(* -0.0004 (solar-cosine-degrees
|
||||
sun-anomaly))
|
||||
(* 0.0003 (solar-cosine-degrees
|
||||
moon-anomaly))))
|
||||
(adjustment (cond ((= phase 1) (+ adjustment adj))
|
||||
((= phase 2) (- adjustment adj))
|
||||
(t adjustment)))
|
||||
(date (+ date adjustment))
|
||||
(calendar-standard-time-zone-name
|
||||
(if calendar-time-zone calendar-standard-time-zone-name "UT"))
|
||||
(calendar-daylight-savings-starts
|
||||
(if calendar-time-zone calendar-daylight-savings-starts))
|
||||
(calendar-daylight-savings-ends
|
||||
(if calendar-time-zone calendar-daylight-savings-ends))
|
||||
(calendar-time-zone (if calendar-time-zone calendar-time-zone 0))
|
||||
(year (extract-calendar-year
|
||||
(calendar-gregorian-from-absolute (truncate date))))
|
||||
(dst (and calendar-daylight-savings-starts
|
||||
calendar-daylight-savings-ends
|
||||
(<= (calendar-absolute-from-gregorian
|
||||
(eval calendar-daylight-savings-starts))
|
||||
date)
|
||||
(< date
|
||||
(calendar-absolute-from-gregorian
|
||||
(eval calendar-daylight-savings-ends)))))
|
||||
(date (+ date
|
||||
(/ (+ (if dst 60 0) calendar-time-zone) 60.0 24.0)
|
||||
(- (/ (solar-ephemeris-correction year) 60.0 24.0))))
|
||||
(time (* 24 (- date (truncate date))))
|
||||
(date (calendar-gregorian-from-absolute (truncate date)))
|
||||
(time-zone calendar-time-zone)
|
||||
(time-zone (if dst
|
||||
calendar-daylight-time-zone-name
|
||||
calendar-standard-time-zone-name))
|
||||
(24-hours (truncate time))
|
||||
(12-hours (format "%d" (if (> 24-hours 12)
|
||||
(- 24-hours 12)
|
||||
(if (= 24-hours 0) 12 24-hours))))
|
||||
(am-pm (if (>= 24-hours 12) "pm" "am"))
|
||||
(minutes (format "%02d" (round (* 60 (- time 24-hours)))))
|
||||
(24-hours (format "%02d" 24-hours))
|
||||
(time (mapconcat 'eval calendar-time-display-form "")))
|
||||
(list date time phase)))
|
||||
|
||||
(defun lunar-phase-name (phase)
|
||||
"Name of lunar PHASE.
|
||||
0 = new moon, 1 = first quarter, 2 = full moon, 3 = last quarter."
|
||||
(cond ((= 0 phase) "New Moon")
|
||||
((= 1 phase) "First Quarter Moon")
|
||||
((= 2 phase) "Full Moon")
|
||||
((= 3 phase) "Last Quarter Moon")))
|
||||
|
||||
(defun calendar-phases-of-moon ()
|
||||
"Create a buffer with the lunar phases for the current calendar window."
|
||||
(interactive)
|
||||
(message "Computing phases of the moon...")
|
||||
(let ((m1 displayed-month)
|
||||
(y1 displayed-year)
|
||||
(m2 displayed-month)
|
||||
(y2 displayed-year)
|
||||
(lunar-phases-buffer "*Phases of Moon*"))
|
||||
(increment-calendar-month m1 y1 -1)
|
||||
(increment-calendar-month m2 y2 1)
|
||||
(set-buffer (get-buffer-create lunar-phases-buffer))
|
||||
(setq buffer-read-only nil)
|
||||
(calendar-set-mode-line
|
||||
(format "Phases of the moon from %s, %d to %s, %d%%-"
|
||||
(calendar-month-name m1) y1 (calendar-month-name m2) y2))
|
||||
(erase-buffer)
|
||||
(insert
|
||||
(mapconcat
|
||||
'(lambda (x)
|
||||
(let ((date (car x))
|
||||
(time (car (cdr x)))
|
||||
(phase (car (cdr (cdr x)))))
|
||||
(concat (calendar-date-string date)
|
||||
": "
|
||||
(lunar-phase-name phase)
|
||||
" "
|
||||
time)))
|
||||
(lunar-phase-list m1 y1) "\n"))
|
||||
(goto-char (point-min))
|
||||
(set-buffer-modified-p nil)
|
||||
(setq buffer-read-only t)
|
||||
(display-buffer lunar-phases-buffer)
|
||||
(message "Computing phases of the moon...done")))
|
||||
|
||||
;;;###autoload
|
||||
(defun phases-of-moon (&optional arg)
|
||||
"Display the quarters of the moon for last month, this month, and next month.
|
||||
If called with an optional prefix argument, prompts for month and year.
|
||||
|
||||
This function is suitable for execution in a .emacs file."
|
||||
(interactive "P")
|
||||
(save-excursion
|
||||
(let* ((completion-ignore-case t)
|
||||
(date (calendar-current-date))
|
||||
(displayed-month
|
||||
(if arg
|
||||
(cdr (assoc
|
||||
(capitalize
|
||||
(completing-read
|
||||
"Month name: "
|
||||
(mapcar 'list (append calendar-month-name-array nil))
|
||||
nil t))
|
||||
(calendar-make-alist calendar-month-name-array)))
|
||||
(extract-calendar-month date)))
|
||||
(displayed-year
|
||||
(if arg
|
||||
(calendar-read
|
||||
"Year (>0): "
|
||||
'(lambda (x) (> x 0))
|
||||
(int-to-string
|
||||
(extract-calendar-year (calendar-current-date))))
|
||||
(extract-calendar-year date))))
|
||||
(calendar-phases-of-moon))))
|
||||
|
||||
(defun diary-phases-of-moon ()
|
||||
"Moon phases diary entry."
|
||||
(let* ((index (* 4
|
||||
(truncate
|
||||
(* 12.3685
|
||||
(+ (extract-calendar-year date)
|
||||
( / (calendar-day-number date)
|
||||
366.0)
|
||||
-1900)))))
|
||||
(phase (lunar-phase index)))
|
||||
(while (calendar-date-compare phase (list date))
|
||||
(setq index (1+ index))
|
||||
(setq phase (lunar-phase index)))
|
||||
(if (calendar-date-equal (car phase) date)
|
||||
(concat (lunar-phase-name (car (cdr (cdr phase)))) " "
|
||||
(car (cdr phase))))))
|
||||
|
||||
(provide 'lunar)
|
||||
|
||||
;;; lunar.el ends here
|
||||
207
lisp/cl.el
207
lisp/cl.el
@ -671,110 +671,55 @@ The forms in BODY should be lists, as non-lists are reserved for new features."
|
||||
;;;; Cesar Quiroz @ UofR DofCSc - Dec. 1986
|
||||
;;;; (quiroz@cs.rochester.edu)
|
||||
|
||||
(defvar *cl-valid-named-list-accessors*
|
||||
'(first rest second third fourth fifth sixth seventh eighth ninth tenth))
|
||||
(defvar *cl-valid-nth-offsets*
|
||||
'((second . 1)
|
||||
(third . 2)
|
||||
(fourth . 3)
|
||||
(fifth . 4)
|
||||
(sixth . 5)
|
||||
(seventh . 6)
|
||||
(eighth . 7)
|
||||
(ninth . 8)
|
||||
(tenth . 9)))
|
||||
|
||||
(defun byte-compile-named-list-accessors (form)
|
||||
"Generate code for (<accessor> FORM), where <accessor> is one of the named
|
||||
list accessors: first, second, ..., tenth, rest."
|
||||
(let* ((fun (car form))
|
||||
(arg (cadr form))
|
||||
(valid *cl-valid-named-list-accessors*)
|
||||
(offsets *cl-valid-nth-offsets*))
|
||||
(cond
|
||||
|
||||
;; Check that it's a form we're prepared to handle.
|
||||
((not (memq fun valid))
|
||||
(error
|
||||
"cl.el internal bug: `%s' not in {first, ..., tenth, rest}"
|
||||
fun))
|
||||
|
||||
;; Check the number of arguments.
|
||||
((not (= (length form) 2))
|
||||
(byte-compile-subr-wrong-args form 1))
|
||||
|
||||
;; If the result will simply be tossed, don't generate any code for
|
||||
;; it, and indicate that we have already discarded the value.
|
||||
(for-effect
|
||||
(setq for-effect nil))
|
||||
|
||||
;; Generate code for the call.
|
||||
((eq fun 'first)
|
||||
(byte-compile-form arg)
|
||||
(byte-compile-out 'byte-car 0))
|
||||
((eq fun 'rest)
|
||||
(byte-compile-form arg)
|
||||
(byte-compile-out 'byte-cdr 0))
|
||||
(t ;one of the others
|
||||
(byte-compile-constant (cdr (assq fun offsets)))
|
||||
(byte-compile-form arg)
|
||||
(byte-compile-out 'byte-nth 0)))))
|
||||
;;; To make these faster, we define them using defsubst. This directs the
|
||||
;;; compiler to open-code these functions.
|
||||
|
||||
;;; Synonyms for list functions
|
||||
(defun first (x)
|
||||
(defsubst first (x)
|
||||
"Synonym for `car'"
|
||||
(car x))
|
||||
(put 'first 'byte-compile 'byte-compile-named-list-accessors)
|
||||
|
||||
(defun second (x)
|
||||
(defsubst second (x)
|
||||
"Return the second element of the list LIST."
|
||||
(nth 1 x))
|
||||
(put 'second 'byte-compile 'byte-compile-named-list-accessors)
|
||||
|
||||
(defun third (x)
|
||||
(defsubst third (x)
|
||||
"Return the third element of the list LIST."
|
||||
(nth 2 x))
|
||||
(put 'third 'byte-compile 'byte-compile-named-list-accessors)
|
||||
|
||||
(defun fourth (x)
|
||||
(defsubst fourth (x)
|
||||
"Return the fourth element of the list LIST."
|
||||
(nth 3 x))
|
||||
(put 'fourth 'byte-compile 'byte-compile-named-list-accessors)
|
||||
|
||||
(defun fifth (x)
|
||||
(defsubst fifth (x)
|
||||
"Return the fifth element of the list LIST."
|
||||
(nth 4 x))
|
||||
(put 'fifth 'byte-compile 'byte-compile-named-list-accessors)
|
||||
|
||||
(defun sixth (x)
|
||||
(defsubst sixth (x)
|
||||
"Return the sixth element of the list LIST."
|
||||
(nth 5 x))
|
||||
(put 'sixth 'byte-compile 'byte-compile-named-list-accessors)
|
||||
|
||||
(defun seventh (x)
|
||||
(defsubst seventh (x)
|
||||
"Return the seventh element of the list LIST."
|
||||
(nth 6 x))
|
||||
(put 'seventh 'byte-compile 'byte-compile-named-list-accessors)
|
||||
|
||||
(defun eighth (x)
|
||||
(defsubst eighth (x)
|
||||
"Return the eighth element of the list LIST."
|
||||
(nth 7 x))
|
||||
(put 'eighth 'byte-compile 'byte-compile-named-list-accessors)
|
||||
|
||||
(defun ninth (x)
|
||||
(defsubst ninth (x)
|
||||
"Return the ninth element of the list LIST."
|
||||
(nth 8 x))
|
||||
(put 'ninth 'byte-compile 'byte-compile-named-list-accessors)
|
||||
|
||||
(defun tenth (x)
|
||||
(defsubst tenth (x)
|
||||
"Return the tenth element of the list LIST."
|
||||
(nth 9 x))
|
||||
(put 'tenth 'byte-compile 'byte-compile-named-list-accessors)
|
||||
|
||||
(defun rest (x)
|
||||
(defsubst rest (x)
|
||||
"Synonym for `cdr'"
|
||||
(cdr x))
|
||||
(put 'rest 'byte-compile 'byte-compile-named-list-accessors)
|
||||
|
||||
(defun endp (x)
|
||||
"t if X is nil, nil if X is a cons; error otherwise."
|
||||
@ -845,186 +790,120 @@ SUBLIST must be one of the links in LIST; otherwise the value is LIST itself."
|
||||
|
||||
;;; The popular c[ad]*r functions and other list accessors.
|
||||
|
||||
;;; To implement this efficiently, a new byte compile handler is used to
|
||||
;;; generate the minimal code, saving one function call.
|
||||
;;; To implement this efficiently, we define them using defsubst,
|
||||
;;; which directs the compiler to open-code these functions.
|
||||
|
||||
(defun byte-compile-ca*d*r (form)
|
||||
"Generate code for a (c[ad]+r argument). This realizes the various
|
||||
combinations of car and cdr whose names are supported in this implementation.
|
||||
To use this functionality for a given function,just give its name a
|
||||
'byte-compile property of 'byte-compile-ca*d*r"
|
||||
(let* ((fun (car form))
|
||||
(arg (cadr form))
|
||||
(seq (mapcar (function (lambda (letter)
|
||||
(if (= letter ?a)
|
||||
'byte-car 'byte-cdr)))
|
||||
(cdr (nreverse (cdr (append (symbol-name fun) nil)))))))
|
||||
;; SEQ is a list of byte-car and byte-cdr in the correct order.
|
||||
(cond
|
||||
|
||||
;; Is this a function we can handle?
|
||||
((null seq)
|
||||
(error
|
||||
"cl.el internal bug: `%s' cannot be compiled by byte-compile-ca*d*r"
|
||||
(prin1-to-string form)))
|
||||
|
||||
;; Are we passing this function the correct number of arguments?
|
||||
((or (null (cdr form)) (cddr form))
|
||||
(byte-compile-subr-wrong-args form 1))
|
||||
|
||||
;; Are we evaluating this expression for effect only?
|
||||
(for-effect
|
||||
|
||||
;; We needn't generate any actual code, as long as we tell the rest
|
||||
;; of the compiler that we didn't push anything on the stack.
|
||||
(setq for-effect nil))
|
||||
|
||||
;; Generate code for the function.
|
||||
(t
|
||||
(byte-compile-form arg)
|
||||
(while seq
|
||||
(byte-compile-out (car seq) 0)
|
||||
(setq seq (cdr seq)))))))
|
||||
|
||||
(defun caar (X)
|
||||
(defsubst caar (X)
|
||||
"Return the car of the car of X."
|
||||
(car (car X)))
|
||||
(put 'caar 'byte-compile 'byte-compile-ca*d*r)
|
||||
|
||||
(defun cadr (X)
|
||||
(defsubst cadr (X)
|
||||
"Return the car of the cdr of X."
|
||||
(car (cdr X)))
|
||||
(put 'cadr 'byte-compile 'byte-compile-ca*d*r)
|
||||
|
||||
(defun cdar (X)
|
||||
(defsubst cdar (X)
|
||||
"Return the cdr of the car of X."
|
||||
(cdr (car X)))
|
||||
(put 'cdar 'byte-compile 'byte-compile-ca*d*r)
|
||||
|
||||
(defun cddr (X)
|
||||
(defsubst cddr (X)
|
||||
"Return the cdr of the cdr of X."
|
||||
(cdr (cdr X)))
|
||||
(put 'cddr 'byte-compile 'byte-compile-ca*d*r)
|
||||
|
||||
(defun caaar (X)
|
||||
(defsubst caaar (X)
|
||||
"Return the car of the car of the car of X."
|
||||
(car (car (car X))))
|
||||
(put 'caaar 'byte-compile 'byte-compile-ca*d*r)
|
||||
|
||||
(defun caadr (X)
|
||||
(defsubst caadr (X)
|
||||
"Return the car of the car of the cdr of X."
|
||||
(car (car (cdr X))))
|
||||
(put 'caadr 'byte-compile 'byte-compile-ca*d*r)
|
||||
|
||||
(defun cadar (X)
|
||||
(defsubst cadar (X)
|
||||
"Return the car of the cdr of the car of X."
|
||||
(car (cdr (car X))))
|
||||
(put 'cadar 'byte-compile 'byte-compile-ca*d*r)
|
||||
|
||||
(defun cdaar (X)
|
||||
(defsubst cdaar (X)
|
||||
"Return the cdr of the car of the car of X."
|
||||
(cdr (car (car X))))
|
||||
(put 'cdaar 'byte-compile 'byte-compile-ca*d*r)
|
||||
|
||||
(defun caddr (X)
|
||||
(defsubst caddr (X)
|
||||
"Return the car of the cdr of the cdr of X."
|
||||
(car (cdr (cdr X))))
|
||||
(put 'caddr 'byte-compile 'byte-compile-ca*d*r)
|
||||
|
||||
(defun cdadr (X)
|
||||
(defsubst cdadr (X)
|
||||
"Return the cdr of the car of the cdr of X."
|
||||
(cdr (car (cdr X))))
|
||||
(put 'cdadr 'byte-compile 'byte-compile-ca*d*r)
|
||||
|
||||
(defun cddar (X)
|
||||
(defsubst cddar (X)
|
||||
"Return the cdr of the cdr of the car of X."
|
||||
(cdr (cdr (car X))))
|
||||
(put 'cddar 'byte-compile 'byte-compile-ca*d*r)
|
||||
|
||||
(defun cdddr (X)
|
||||
(defsubst cdddr (X)
|
||||
"Return the cdr of the cdr of the cdr of X."
|
||||
(cdr (cdr (cdr X))))
|
||||
(put 'cdddr 'byte-compile 'byte-compile-ca*d*r)
|
||||
|
||||
(defun caaaar (X)
|
||||
(defsubst caaaar (X)
|
||||
"Return the car of the car of the car of the car of X."
|
||||
(car (car (car (car X)))))
|
||||
(put 'caaaar 'byte-compile 'byte-compile-ca*d*r)
|
||||
|
||||
(defun caaadr (X)
|
||||
(defsubst caaadr (X)
|
||||
"Return the car of the car of the car of the cdr of X."
|
||||
(car (car (car (cdr X)))))
|
||||
(put 'caaadr 'byte-compile 'byte-compile-ca*d*r)
|
||||
|
||||
(defun caadar (X)
|
||||
(defsubst caadar (X)
|
||||
"Return the car of the car of the cdr of the car of X."
|
||||
(car (car (cdr (car X)))))
|
||||
(put 'caadar 'byte-compile 'byte-compile-ca*d*r)
|
||||
|
||||
(defun cadaar (X)
|
||||
(defsubst cadaar (X)
|
||||
"Return the car of the cdr of the car of the car of X."
|
||||
(car (cdr (car (car X)))))
|
||||
(put 'cadaar 'byte-compile 'byte-compile-ca*d*r)
|
||||
|
||||
(defun cdaaar (X)
|
||||
(defsubst cdaaar (X)
|
||||
"Return the cdr of the car of the car of the car of X."
|
||||
(cdr (car (car (car X)))))
|
||||
(put 'cdaaar 'byte-compile 'byte-compile-ca*d*r)
|
||||
|
||||
(defun caaddr (X)
|
||||
(defsubst caaddr (X)
|
||||
"Return the car of the car of the cdr of the cdr of X."
|
||||
(car (car (cdr (cdr X)))))
|
||||
(put 'caaddr 'byte-compile 'byte-compile-ca*d*r)
|
||||
|
||||
(defun cadadr (X)
|
||||
(defsubst cadadr (X)
|
||||
"Return the car of the cdr of the car of the cdr of X."
|
||||
(car (cdr (car (cdr X)))))
|
||||
(put 'cadadr 'byte-compile 'byte-compile-ca*d*r)
|
||||
|
||||
(defun cdaadr (X)
|
||||
(defsubst cdaadr (X)
|
||||
"Return the cdr of the car of the car of the cdr of X."
|
||||
(cdr (car (car (cdr X)))))
|
||||
(put 'cdaadr 'byte-compile 'byte-compile-ca*d*r)
|
||||
|
||||
(defun caddar (X)
|
||||
(defsubst caddar (X)
|
||||
"Return the car of the cdr of the cdr of the car of X."
|
||||
(car (cdr (cdr (car X)))))
|
||||
(put 'caddar 'byte-compile 'byte-compile-ca*d*r)
|
||||
|
||||
(defun cdadar (X)
|
||||
(defsubst cdadar (X)
|
||||
"Return the cdr of the car of the cdr of the car of X."
|
||||
(cdr (car (cdr (car X)))))
|
||||
(put 'cdadar 'byte-compile 'byte-compile-ca*d*r)
|
||||
|
||||
(defun cddaar (X)
|
||||
(defsubst cddaar (X)
|
||||
"Return the cdr of the cdr of the car of the car of X."
|
||||
(cdr (cdr (car (car X)))))
|
||||
(put 'cddaar 'byte-compile 'byte-compile-ca*d*r)
|
||||
|
||||
(defun cadddr (X)
|
||||
(defsubst cadddr (X)
|
||||
"Return the car of the cdr of the cdr of the cdr of X."
|
||||
(car (cdr (cdr (cdr X)))))
|
||||
(put 'cadddr 'byte-compile 'byte-compile-ca*d*r)
|
||||
|
||||
(defun cddadr (X)
|
||||
(defsubst cddadr (X)
|
||||
"Return the cdr of the cdr of the car of the cdr of X."
|
||||
(cdr (cdr (car (cdr X)))))
|
||||
(put 'cddadr 'byte-compile 'byte-compile-ca*d*r)
|
||||
|
||||
(defun cdaddr (X)
|
||||
(defsubst cdaddr (X)
|
||||
"Return the cdr of the car of the cdr of the cdr of X."
|
||||
(cdr (car (cdr (cdr X)))))
|
||||
(put 'cdaddr 'byte-compile 'byte-compile-ca*d*r)
|
||||
|
||||
(defun cdddar (X)
|
||||
(defsubst cdddar (X)
|
||||
"Return the cdr of the cdr of the cdr of the car of X."
|
||||
(cdr (cdr (cdr (car X)))))
|
||||
(put 'cdddar 'byte-compile 'byte-compile-ca*d*r)
|
||||
|
||||
(defun cddddr (X)
|
||||
(defsubst cddddr (X)
|
||||
"Return the cdr of the cdr of the cdr of the cdr of X."
|
||||
(cdr (cdr (cdr (cdr X)))))
|
||||
(put 'cddddr 'byte-compile 'byte-compile-ca*d*r)
|
||||
|
||||
;;; some inverses of the accessors are needed for setf purposes
|
||||
|
||||
|
||||
684
lisp/cmulisp.el
Normal file
684
lisp/cmulisp.el
Normal file
@ -0,0 +1,684 @@
|
||||
;;; cmulisp.el --- improved version of standard inferior-lisp mode
|
||||
|
||||
;;; Copyright Olin Shivers (1988).
|
||||
;;; Please imagine a long, tedious, legalistic 5-page gnu-style copyright
|
||||
;;; notice appearing here to the effect that you may use this code any
|
||||
;;; way you like, as long as you don't charge money for it, remove this
|
||||
;;; notice, or hold me liable for its results.
|
||||
|
||||
;;; This replaces the standard inferior-lisp mode.
|
||||
;;; Hacked from tea.el by Olin Shivers (shivers@cs.cmu.edu). 8/88
|
||||
;;; Please send me bug reports, bug fixes, and extensions, so that I can
|
||||
;;; merge them into the master source.
|
||||
;;;
|
||||
;;; Change log at end of file.
|
||||
|
||||
;;; This file defines a a lisp-in-a-buffer package (cmulisp mode) built on top
|
||||
;;; of comint mode. Cmulisp mode is similar to, and intended to replace, its
|
||||
;;; counterpart in the standard gnu emacs release. This replacements is more
|
||||
;;; featureful, robust, and uniform than the released version. The key
|
||||
;;; bindings are also more compatible with the bindings of Hemlock and Zwei
|
||||
;;; (the Lisp Machine emacs).
|
||||
|
||||
;;; Since this mode is built on top of the general command-interpreter-in-
|
||||
;;; a-buffer mode (comint mode), it shares a common base functionality,
|
||||
;;; and a common set of bindings, with all modes derived from comint mode.
|
||||
;;; This makes these modes easier to use.
|
||||
|
||||
;;; For documentation on the functionality provided by comint mode, and
|
||||
;;; the hooks available for customising it, see the file comint.el.
|
||||
;;; For further information on cmulisp mode, see the comments below.
|
||||
|
||||
;;; Needs fixin:
|
||||
;;; The load-file/compile-file default mechanism could be smarter -- it
|
||||
;;; doesn't know about the relationship between filename extensions and
|
||||
;;; whether the file is source or executable. If you compile foo.lisp
|
||||
;;; with compile-file, then the next load-file should use foo.bin for
|
||||
;;; the default, not foo.lisp. This is tricky to do right, particularly
|
||||
;;; because the extension for executable files varies so much (.o, .bin,
|
||||
;;; .lbin, .mo, .vo, .ao, ...).
|
||||
;;;
|
||||
;;; It would be nice if cmulisp (and inferior scheme, T, ...) modes
|
||||
;;; had a verbose minor mode wherein sending or compiling defuns, etc.
|
||||
;;; would be reflected in the transcript with suitable comments, e.g.
|
||||
;;; ";;; redefining fact". Several ways to do this. Which is right?
|
||||
;;;
|
||||
;;; When sending text from a source file to a subprocess, the process-mark can
|
||||
;;; move off the window, so you can lose sight of the process interactions.
|
||||
;;; Maybe I should ensure the process mark is in the window when I send
|
||||
;;; text to the process? Switch selectable?
|
||||
|
||||
(require 'comint)
|
||||
;; YOUR .EMACS FILE
|
||||
;;=============================================================================
|
||||
;; Some suggestions for your .emacs file.
|
||||
;;
|
||||
;; ; If cmulisp lives in some non-standard directory, you must tell emacs
|
||||
;; ; where to get it. This may or may not be necessary.
|
||||
;; (setq load-path (cons (expand-file-name "~jones/lib/emacs") load-path))
|
||||
;;
|
||||
;; ; Autoload cmulisp from file cmulisp.el
|
||||
;; (autoload 'cmulisp "cmulisp"
|
||||
;; "Run an inferior Lisp process."
|
||||
;; t)
|
||||
;;
|
||||
;; ; Define C-c t to run my favorite command in cmulisp mode:
|
||||
;; (setq cmulisp-load-hook
|
||||
;; '((lambda ()
|
||||
;; (define-key cmulisp-mode-map "\C-ct" 'favorite-cmd))))
|
||||
|
||||
|
||||
;;; Brief Command Documentation:
|
||||
;;;============================================================================
|
||||
;;; Comint Mode Commands: (common to cmulisp and all comint-derived modes)
|
||||
;;;
|
||||
;;; m-p comint-previous-input Cycle backwards in input history
|
||||
;;; m-n comint-next-input Cycle forwards
|
||||
;;; m-c-r comint-previous-input-matching Search backwards in input history
|
||||
;;; return comint-send-input
|
||||
;;; c-a comint-bol Beginning of line; skip prompt.
|
||||
;;; c-d comint-delchar-or-maybe-eof Delete char unless at end of buff.
|
||||
;;; c-c c-u comint-kill-input ^u
|
||||
;;; c-c c-w backward-kill-word ^w
|
||||
;;; c-c c-c comint-interrupt-subjob ^c
|
||||
;;; c-c c-z comint-stop-subjob ^z
|
||||
;;; c-c c-\ comint-quit-subjob ^\
|
||||
;;; c-c c-o comint-kill-output Delete last batch of process output
|
||||
;;; c-c c-r comint-show-output Show last batch of process output
|
||||
;;; send-invisible Read line w/o echo & send to proc
|
||||
;;; comint-continue-subjob Useful if you accidentally suspend
|
||||
;;; top-level job.
|
||||
;;; comint-mode-hook is the comint mode hook.
|
||||
|
||||
;;; CMU Lisp Mode Commands:
|
||||
;;; c-m-x lisp-send-defun This binding is a gnu convention.
|
||||
;;; c-c c-l lisp-load-file Prompt for file name; tell Lisp to load it.
|
||||
;;; c-c c-k lisp-compile-file Prompt for file name; tell Lisp to kompile it.
|
||||
;;; Filename completion is available, of course.
|
||||
;;;
|
||||
;;; Additionally, these commands are added to the key bindings of Lisp mode:
|
||||
;;; c-m-x lisp-eval-defun This binding is a gnu convention.
|
||||
;;; c-c c-e lisp-eval-defun Send the current defun to Lisp process.
|
||||
;;; c-x c-e lisp-eval-last-sexp Send the previous sexp to Lisp process.
|
||||
;;; c-c c-r lisp-eval-region Send the current region to Lisp process.
|
||||
;;; c-c c-c lisp-compile-defun Compile the current defun in Lisp process.
|
||||
;;; c-c c-z switch-to-lisp Switch to the Lisp process buffer.
|
||||
;;; c-c c-l lisp-load-file (See above. In a Lisp file buffer, default
|
||||
;;; c-c c-k lisp-compile-file is to load/compile the current file.)
|
||||
;;; c-c c-d lisp-describe-sym Query Lisp for a symbol's description.
|
||||
;;; c-c c-a lisp-show-arglist Query Lisp for function's arglist.
|
||||
;;; c-c c-f lisp-show-function-documentation Query Lisp for a function's doc.
|
||||
;;; c-c c-v lisp-show-variable-documentation Query Lisp for a variable's doc.
|
||||
|
||||
;;; cmulisp Fires up the Lisp process.
|
||||
;;; lisp-compile-region Compile all forms in the current region.
|
||||
;;;
|
||||
;;; CMU Lisp Mode Variables:
|
||||
;;; cmulisp-filter-regexp Match this => don't get saved on input hist
|
||||
;;; inferior-lisp-program Name of Lisp program run-lisp executes
|
||||
;;; inferior-lisp-load-command Customises lisp-load-file
|
||||
;;; cmulisp-mode-hook
|
||||
;;; inferior-lisp-prompt Initialises comint-prompt-regexp.
|
||||
;;; Backwards compatibility.
|
||||
;;; lisp-source-modes Anything loaded into a buffer that's in
|
||||
;;; one of these modes is considered Lisp
|
||||
;;; source by lisp-load/compile-file.
|
||||
|
||||
;;; Read the rest of this file for more information.
|
||||
|
||||
(defvar cmulisp-filter-regexp "\\`\\s *\\(:\\(\\w\\|\\s_\\)\\)?\\s *\\'"
|
||||
"*What not to save on inferior Lisp's input history
|
||||
Input matching this regexp is not saved on the input history in cmulisp
|
||||
mode. Default is whitespace followed by 0 or 1 single-letter :keyword
|
||||
(as in :a, :c, etc.)")
|
||||
|
||||
(defvar cmulisp-mode-map nil)
|
||||
(cond ((not cmulisp-mode-map)
|
||||
(setq cmulisp-mode-map
|
||||
(full-copy-sparse-keymap comint-mode-map))
|
||||
(lisp-mode-commands cmulisp-mode-map)
|
||||
(define-key cmulisp-mode-map "\C-x\C-e" 'lisp-eval-last-sexp)
|
||||
(define-key cmulisp-mode-map "\C-c\C-l" 'lisp-load-file)
|
||||
(define-key cmulisp-mode-map "\C-c\C-k" 'lisp-compile-file)
|
||||
(define-key cmulisp-mode-map "\C-c\C-a" 'lisp-show-arglist)
|
||||
(define-key cmulisp-mode-map "\C-c\C-d" 'lisp-describe-sym)
|
||||
(define-key cmulisp-mode-map "\C-c\C-f" 'lisp-show-function-documentation)
|
||||
(define-key cmulisp-mode-map "\C-c\C-v" 'lisp-show-variable-documentation)))
|
||||
|
||||
;;; These commands augment Lisp mode, so you can process Lisp code in
|
||||
;;; the source files.
|
||||
(define-key lisp-mode-map "\M-\C-x" 'lisp-eval-defun) ; Gnu convention
|
||||
(define-key lisp-mode-map "\C-x\C-e" 'lisp-eval-last-sexp) ; Gnu convention
|
||||
(define-key lisp-mode-map "\C-c\C-e" 'lisp-eval-defun)
|
||||
(define-key lisp-mode-map "\C-c\C-r" 'lisp-eval-region)
|
||||
(define-key lisp-mode-map "\C-c\C-c" 'lisp-compile-defun)
|
||||
(define-key lisp-mode-map "\C-c\C-z" 'switch-to-lisp)
|
||||
(define-key lisp-mode-map "\C-c\C-l" 'lisp-load-file)
|
||||
(define-key lisp-mode-map "\C-c\C-k" 'lisp-compile-file) ; "kompile" file
|
||||
(define-key lisp-mode-map "\C-c\C-a" 'lisp-show-arglist)
|
||||
(define-key lisp-mode-map "\C-c\C-d" 'lisp-describe-sym)
|
||||
(define-key lisp-mode-map "\C-c\C-f" 'lisp-show-function-documentation)
|
||||
(define-key lisp-mode-map "\C-c\C-v" 'lisp-show-variable-documentation)
|
||||
|
||||
|
||||
;;; This function exists for backwards compatibility.
|
||||
;;; Previous versions of this package bound commands to C-c <letter>
|
||||
;;; bindings, which is not allowed by the gnumacs standard.
|
||||
|
||||
(defun cmulisp-install-letter-bindings ()
|
||||
"This function binds many cmulisp commands to C-c <letter> bindings,
|
||||
where they are more accessible. C-c <letter> bindings are reserved for the
|
||||
user, so these bindings are non-standard. If you want them, you should
|
||||
have this function called by the cmulisp-load-hook:
|
||||
(setq cmulisp-load-hook '(cmulisp-install-letter-bindings))
|
||||
You can modify this function to install just the bindings you want."
|
||||
|
||||
(define-key lisp-mode-map "\C-ce" 'lisp-eval-defun-and-go)
|
||||
(define-key lisp-mode-map "\C-cr" 'lisp-eval-region-and-go)
|
||||
(define-key lisp-mode-map "\C-cc" 'lisp-compile-defun-and-go)
|
||||
(define-key lisp-mode-map "\C-cz" 'switch-to-lisp)
|
||||
(define-key lisp-mode-map "\C-cl" 'lisp-load-file)
|
||||
(define-key lisp-mode-map "\C-ck" 'lisp-compile-file)
|
||||
(define-key lisp-mode-map "\C-ca" 'lisp-show-arglist)
|
||||
(define-key lisp-mode-map "\C-cd" 'lisp-describe-sym)
|
||||
(define-key lisp-mode-map "\C-cf" 'lisp-show-function-documentation)
|
||||
(define-key lisp-mode-map "\C-cv" 'lisp-show-variable-documentation)
|
||||
|
||||
(define-key cmulisp-mode-map "\C-cl" 'lisp-load-file)
|
||||
(define-key cmulisp-mode-map "\C-ck" 'lisp-compile-file)
|
||||
(define-key cmulisp-mode-map "\C-ca" 'lisp-show-arglist)
|
||||
(define-key cmulisp-mode-map "\C-cd" 'lisp-describe-sym)
|
||||
(define-key cmulisp-mode-map "\C-cf" 'lisp-show-function-documentation)
|
||||
(define-key cmulisp-mode-map "\C-cv" 'lisp-show-variable-documentation))
|
||||
|
||||
|
||||
(defvar inferior-lisp-program "lisp"
|
||||
"*Program name for invoking an inferior Lisp with `cmulisp'.")
|
||||
|
||||
(defvar inferior-lisp-load-command "(load \"%s\")\n"
|
||||
"*Format-string for building a Lisp expression to load a file.
|
||||
This format string should use %s to substitute a file name
|
||||
and should result in a Lisp expression that will command the inferior Lisp
|
||||
to load that file. The default works acceptably on most Lisps.
|
||||
The string \"(progn (load \\\"%s\\\" :verbose nil :print t) (values))\\\n\"
|
||||
produces cosmetically superior output for this application,
|
||||
but it works only in Common Lisp.")
|
||||
|
||||
(defvar inferior-lisp-prompt "^[^> ]*>+:? *"
|
||||
"Regexp to recognise prompts in the inferior Lisp.
|
||||
Defaults to \"^[^> ]*>+:? *\", which works pretty good for Lucid, kcl,
|
||||
and franz. This variable is used to initialise comint-prompt-regexp in the
|
||||
cmulisp buffer.
|
||||
|
||||
More precise choices:
|
||||
Lucid Common Lisp: \"^\\(>\\|\\(->\\)+\\) *\"
|
||||
franz: \"^\\(->\\|<[0-9]*>:\\) *\"
|
||||
kcl: \"^>+ *\"
|
||||
|
||||
This is a fine thing to set in your .emacs file.")
|
||||
|
||||
(defvar cmulisp-mode-hook '()
|
||||
"*Hook for customising cmulisp mode")
|
||||
|
||||
(defun cmulisp-mode ()
|
||||
"Major mode for interacting with an inferior Lisp process.
|
||||
Runs a Lisp interpreter as a subprocess of Emacs, with Lisp I/O through an
|
||||
Emacs buffer. Variable inferior-lisp-program controls which Lisp interpreter
|
||||
is run. Variables inferior-lisp-prompt, cmulisp-filter-regexp and
|
||||
inferior-lisp-load-command can customize this mode for different Lisp
|
||||
interpreters.
|
||||
|
||||
For information on running multiple processes in multiple buffers, see
|
||||
documentation for variable cmulisp-buffer.
|
||||
|
||||
\\{cmulisp-mode-map}
|
||||
|
||||
Customisation: Entry to this mode runs the hooks on comint-mode-hook and
|
||||
cmulisp-mode-hook (in that order).
|
||||
|
||||
You can send text to the inferior Lisp process from other buffers containing
|
||||
Lisp source.
|
||||
switch-to-lisp switches the current buffer to the Lisp process buffer.
|
||||
lisp-eval-defun sends the current defun to the Lisp process.
|
||||
lisp-compile-defun compiles the current defun.
|
||||
lisp-eval-region sends the current region to the Lisp process.
|
||||
lisp-compile-region compiles the current region.
|
||||
|
||||
Prefixing the lisp-eval/compile-defun/region commands with
|
||||
a \\[universal-argument] causes a switch to the Lisp process buffer after sending
|
||||
the text.
|
||||
|
||||
Commands:
|
||||
Return after the end of the process' output sends the text from the
|
||||
end of process to point.
|
||||
Return before the end of the process' output copies the sexp ending at point
|
||||
to the end of the process' output, and sends it.
|
||||
Delete converts tabs to spaces as it moves back.
|
||||
Tab indents for Lisp; with argument, shifts rest
|
||||
of expression rigidly with the current line.
|
||||
C-M-q does Tab on each line starting within following expression.
|
||||
Paragraphs are separated only by blank lines. Semicolons start comments.
|
||||
If you accidentally suspend your process, use \\[comint-continue-subjob]
|
||||
to continue it."
|
||||
(interactive)
|
||||
(comint-mode)
|
||||
(setq comint-prompt-regexp inferior-lisp-prompt)
|
||||
(setq major-mode 'cmulisp-mode)
|
||||
(setq mode-name "CMU Lisp")
|
||||
(setq mode-line-process '(": %s"))
|
||||
(if (string-match "^18.4" emacs-version) ; hack.
|
||||
(lisp-mode-variables) ; This is right for 18.49
|
||||
(lisp-mode-variables t)) ; This is right for 18.50
|
||||
(use-local-map cmulisp-mode-map) ;c-c c-k for "kompile" file
|
||||
(setq comint-get-old-input (function lisp-get-old-input))
|
||||
(setq comint-input-filter (function lisp-input-filter))
|
||||
(setq comint-input-sentinel 'ignore)
|
||||
(run-hooks 'cmulisp-mode-hook))
|
||||
|
||||
(defun lisp-get-old-input ()
|
||||
"Snarf the sexp ending at point"
|
||||
(save-excursion
|
||||
(let ((end (point)))
|
||||
(backward-sexp)
|
||||
(buffer-substring (point) end))))
|
||||
|
||||
(defun lisp-input-filter (str)
|
||||
"Don't save anything matching cmulisp-filter-regexp"
|
||||
(not (string-match cmulisp-filter-regexp str)))
|
||||
|
||||
(defun cmulisp (cmd)
|
||||
"Run an inferior Lisp process, input and output via buffer *cmulisp*.
|
||||
If there is a process already running in *cmulisp*, just switch to that buffer.
|
||||
With argument, allows you to edit the command line (default is value
|
||||
of inferior-lisp-program). Runs the hooks from cmulisp-mode-hook (after the
|
||||
comint-mode-hook is run).
|
||||
\(Type \\[describe-mode] in the process buffer for a list of commands.)"
|
||||
(interactive (list (if current-prefix-arg
|
||||
(read-string "Run lisp: " inferior-lisp-program)
|
||||
inferior-lisp-program)))
|
||||
(if (not (comint-check-proc "*cmulisp*"))
|
||||
(let ((cmdlist (cmulisp-args-to-list cmd)))
|
||||
(set-buffer (apply (function make-comint) "cmulisp" (car cmdlist) nil
|
||||
(cdr cmdlist)))
|
||||
(cmulisp-mode)))
|
||||
(setq cmulisp-buffer "*cmulisp*")
|
||||
(switch-to-buffer "*cmulisp*"))
|
||||
|
||||
;;; Break a string up into a list of arguments.
|
||||
;;; This will break if you have an argument with whitespace, as in
|
||||
;;; string = "-ab +c -x 'you lose'".
|
||||
(defun cmulisp-args-to-list (string)
|
||||
(let ((where (string-match "[ \t]" string)))
|
||||
(cond ((null where) (list string))
|
||||
((not (= where 0))
|
||||
(cons (substring string 0 where)
|
||||
(tea-args-to-list (substring string (+ 1 where)
|
||||
(length string)))))
|
||||
(t (let ((pos (string-match "[^ \t]" string)))
|
||||
(if (null pos)
|
||||
nil
|
||||
(cmulsip-args-to-list (substring string pos
|
||||
(length string)))))))))
|
||||
|
||||
(defun lisp-eval-region (start end &optional and-go)
|
||||
"Send the current region to the inferior Lisp process.
|
||||
Prefix argument means switch-to-lisp afterwards."
|
||||
(interactive "r\nP")
|
||||
(comint-send-region (cmulisp-proc) start end)
|
||||
(comint-send-string (cmulisp-proc) "\n")
|
||||
(if and-go (switch-to-lisp t)))
|
||||
|
||||
(defun lisp-eval-defun (&optional and-go)
|
||||
"Send the current defun to the inferior Lisp process.
|
||||
Prefix argument means switch-to-lisp afterwards."
|
||||
(interactive "P")
|
||||
(save-excursion
|
||||
(end-of-defun)
|
||||
(skip-chars-backward " \t\n\r\f") ; Makes allegro happy
|
||||
(let ((end (point)))
|
||||
(beginning-of-defun)
|
||||
(lisp-eval-region (point) end)))
|
||||
(if and-go (switch-to-lisp t)))
|
||||
|
||||
(defun lisp-eval-last-sexp (&optional and-go)
|
||||
"Send the previous sexp to the inferior Lisp process.
|
||||
Prefix argument means switch-to-lisp afterwards."
|
||||
(interactive "P")
|
||||
(lisp-eval-region (save-excursion (backward-sexp) (point)) (point) and-go))
|
||||
|
||||
;;; Common Lisp COMPILE sux.
|
||||
(defun lisp-compile-region (start end &optional and-go)
|
||||
"Compile the current region in the inferior Lisp process.
|
||||
Prefix argument means switch-to-lisp afterwards."
|
||||
(interactive "r\nP")
|
||||
(comint-send-string (cmulisp-proc)
|
||||
(format "(funcall (compile nil `(lambda () (progn 'compile %s))))\n"
|
||||
(buffer-substring start end)))
|
||||
(if and-go (switch-to-lisp t)))
|
||||
|
||||
(defun lisp-compile-defun (&optional and-go)
|
||||
"Compile the current defun in the inferior Lisp process.
|
||||
Prefix argument means switch-to-lisp afterwards."
|
||||
(interactive "P")
|
||||
(save-excursion
|
||||
(end-of-defun)
|
||||
(skip-chars-backward " \t\n\r\f") ; Makes allegro happy
|
||||
(let ((e (point)))
|
||||
(beginning-of-defun)
|
||||
(lisp-compile-region (point) e)))
|
||||
(if and-go (switch-to-lisp t)))
|
||||
|
||||
(defun switch-to-lisp (eob-p)
|
||||
"Switch to the inferior Lisp process buffer.
|
||||
With argument, positions cursor at end of buffer."
|
||||
(interactive "P")
|
||||
(if (get-buffer cmulisp-buffer)
|
||||
(pop-to-buffer cmulisp-buffer)
|
||||
(error "No current process buffer. See variable cmulisp-buffer."))
|
||||
(cond (eob-p
|
||||
(push-mark)
|
||||
(goto-char (point-max)))))
|
||||
|
||||
|
||||
;;; Now that lisp-compile/eval-defun/region takes an optional prefix arg,
|
||||
;;; these commands are redundant. But they are kept around for the user
|
||||
;;; to bind if he wishes, for backwards functionality, and because it's
|
||||
;;; easier to type C-c e than C-u C-c C-e.
|
||||
|
||||
(defun lisp-eval-region-and-go (start end)
|
||||
"Send the current region to the inferior Lisp,
|
||||
and switch to the process buffer."
|
||||
(interactive "r")
|
||||
(lisp-eval-region start end t))
|
||||
|
||||
(defun lisp-eval-defun-and-go ()
|
||||
"Send the current defun to the inferior Lisp,
|
||||
and switch to the process buffer."
|
||||
(interactive)
|
||||
(lisp-eval-defun t))
|
||||
|
||||
(defun lisp-compile-region-and-go (start end)
|
||||
"Compile the current region in the inferior Lisp,
|
||||
and switch to the process buffer."
|
||||
(interactive "r")
|
||||
(lisp-compile-region start end t))
|
||||
|
||||
(defun lisp-compile-defun-and-go ()
|
||||
"Compile the current defun in the inferior Lisp,
|
||||
and switch to the process buffer."
|
||||
(interactive)
|
||||
(lisp-compile-defun t))
|
||||
|
||||
;;; A version of the form in H. Shevis' soar-mode.el package. Less robust.
|
||||
;(defun lisp-compile-sexp (start end)
|
||||
; "Compile the s-expression bounded by START and END in the inferior lisp.
|
||||
;If the sexp isn't a DEFUN form, it is evaluated instead."
|
||||
; (cond ((looking-at "(defun\\s +")
|
||||
; (goto-char (match-end 0))
|
||||
; (let ((name-start (point)))
|
||||
; (forward-sexp 1)
|
||||
; (process-send-string "cmulisp" (format "(compile '%s #'(lambda "
|
||||
; (buffer-substring name-start
|
||||
; (point)))))
|
||||
; (let ((body-start (point)))
|
||||
; (goto-char start) (forward-sexp 1) ; Can't use end-of-defun.
|
||||
; (process-send-region "cmulisp" (buffer-substring body-start (point))))
|
||||
; (process-send-string "cmulisp" ")\n"))
|
||||
; (t (lisp-eval-region start end)))))
|
||||
;
|
||||
;(defun lisp-compile-region (start end)
|
||||
; "Each s-expression in the current region is compiled (if a DEFUN)
|
||||
;or evaluated (if not) in the inferior lisp."
|
||||
; (interactive "r")
|
||||
; (save-excursion
|
||||
; (goto-char start) (end-of-defun) (beginning-of-defun) ; error check
|
||||
; (if (< (point) start) (error "region begins in middle of defun"))
|
||||
; (goto-char start)
|
||||
; (let ((s start))
|
||||
; (end-of-defun)
|
||||
; (while (<= (point) end) ; Zip through
|
||||
; (lisp-compile-sexp s (point)) ; compiling up defun-sized chunks.
|
||||
; (setq s (point))
|
||||
; (end-of-defun))
|
||||
; (if (< s end) (lisp-compile-sexp s end)))))
|
||||
;;;
|
||||
;;; End of HS-style code
|
||||
|
||||
|
||||
(defvar lisp-prev-l/c-dir/file nil
|
||||
"Saves the (directory . file) pair used in the last lisp-load-file or
|
||||
lisp-compile-file command. Used for determining the default in the
|
||||
next one.")
|
||||
|
||||
(defvar lisp-source-modes '(lisp-mode)
|
||||
"*Used to determine if a buffer contains Lisp source code.
|
||||
If it's loaded into a buffer that is in one of these major modes, it's
|
||||
considered a Lisp source file by lisp-load-file and lisp-compile-file.
|
||||
Used by these commands to determine defaults.")
|
||||
|
||||
(defun lisp-load-file (file-name)
|
||||
"Load a Lisp file into the inferior Lisp process."
|
||||
(interactive (comint-get-source "Load Lisp file: " lisp-prev-l/c-dir/file
|
||||
lisp-source-modes nil)) ; NIL because LOAD
|
||||
; doesn't need an exact name
|
||||
(comint-check-source file-name) ; Check to see if buffer needs saved.
|
||||
(setq lisp-prev-l/c-dir/file (cons (file-name-directory file-name)
|
||||
(file-name-nondirectory file-name)))
|
||||
(comint-send-string (cmulisp-proc)
|
||||
(format inferior-lisp-load-command file-name))
|
||||
(switch-to-lisp t))
|
||||
|
||||
|
||||
(defun lisp-compile-file (file-name)
|
||||
"Compile a Lisp file in the inferior Lisp process."
|
||||
(interactive (comint-get-source "Compile Lisp file: " lisp-prev-l/c-dir/file
|
||||
lisp-source-modes nil)) ; NIL = don't need
|
||||
; suffix .lisp
|
||||
(comint-check-source file-name) ; Check to see if buffer needs saved.
|
||||
(setq lisp-prev-l/c-dir/file (cons (file-name-directory file-name)
|
||||
(file-name-nondirectory file-name)))
|
||||
(comint-send-string (cmulisp-proc) (concat "(compile-file \""
|
||||
file-name
|
||||
"\"\)\n"))
|
||||
(switch-to-lisp t))
|
||||
|
||||
|
||||
|
||||
;;; Documentation functions: function doc, var doc, arglist, and
|
||||
;;; describe symbol.
|
||||
;;; ===========================================================================
|
||||
|
||||
;;; Command strings
|
||||
;;; ===============
|
||||
|
||||
(defvar lisp-function-doc-command
|
||||
"(let ((fn '%s))
|
||||
(format t \"Documentation for ~a:~&~a\"
|
||||
fn (documentation fn 'function))
|
||||
(values))\n"
|
||||
"Command to query inferior Lisp for a function's documentation.")
|
||||
|
||||
(defvar lisp-var-doc-command
|
||||
"(let ((v '%s))
|
||||
(format t \"Documentation for ~a:~&~a\"
|
||||
v (documentation v 'variable))
|
||||
(values))\n"
|
||||
"Command to query inferior Lisp for a variable's documentation.")
|
||||
|
||||
(defvar lisp-arglist-command
|
||||
"(let ((fn '%s))
|
||||
(format t \"Arglist for ~a: ~a\" fn (arglist fn))
|
||||
(values))\n"
|
||||
"Command to query inferior Lisp for a function's arglist.")
|
||||
|
||||
(defvar lisp-describe-sym-command
|
||||
"(describe '%s)\n"
|
||||
"Command to query inferior Lisp for a variable's documentation.")
|
||||
|
||||
|
||||
;;; Ancillary functions
|
||||
;;; ===================
|
||||
|
||||
;;; Reads a string from the user.
|
||||
(defun lisp-symprompt (prompt default)
|
||||
(list (let* ((prompt (if default
|
||||
(format "%s (default %s): " prompt default)
|
||||
(concat prompt ": ")))
|
||||
(ans (read-string prompt)))
|
||||
(if (zerop (length ans)) default ans))))
|
||||
|
||||
|
||||
;;; Adapted from function-called-at-point in help.el.
|
||||
(defun lisp-fn-called-at-pt ()
|
||||
"Returns the name of the function called in the current call.
|
||||
Nil if it can't find one."
|
||||
(condition-case nil
|
||||
(save-excursion
|
||||
(save-restriction
|
||||
(narrow-to-region (max (point-min) (- (point) 1000)) (point-max))
|
||||
(backward-up-list 1)
|
||||
(forward-char 1)
|
||||
(let ((obj (read (current-buffer))))
|
||||
(and (symbolp obj) obj))))
|
||||
(error nil)))
|
||||
|
||||
|
||||
;;; Adapted from variable-at-point in help.el.
|
||||
(defun lisp-var-at-pt ()
|
||||
(condition-case ()
|
||||
(save-excursion
|
||||
(forward-sexp -1)
|
||||
(skip-chars-forward "'")
|
||||
(let ((obj (read (current-buffer))))
|
||||
(and (symbolp obj) obj)))
|
||||
(error nil)))
|
||||
|
||||
|
||||
;;; Documentation functions: fn and var doc, arglist, and symbol describe.
|
||||
;;; ======================================================================
|
||||
|
||||
(defun lisp-show-function-documentation (fn)
|
||||
"Send a command to the inferior Lisp to give documentation for function FN.
|
||||
See variable lisp-function-doc-command."
|
||||
(interactive (lisp-symprompt "Function doc" (lisp-fn-called-at-pt)))
|
||||
(comint-proc-query (cmulisp-proc) (format lisp-function-doc-command fn)))
|
||||
|
||||
(defun lisp-show-variable-documentation (var)
|
||||
"Send a command to the inferior Lisp to give documentation for function FN.
|
||||
See variable lisp-var-doc-command."
|
||||
(interactive (lisp-symprompt "Variable doc" (lisp-var-at-pt)))
|
||||
(comint-proc-query (cmulisp-proc) (format lisp-var-doc-command var)))
|
||||
|
||||
(defun lisp-show-arglist (fn)
|
||||
"Sends an query to the inferior Lisp for the arglist for function FN.
|
||||
See variable lisp-arglist-command."
|
||||
(interactive (lisp-symprompt "Arglist" (lisp-fn-called-at-pt)))
|
||||
(comint-proc-query (cmulisp-proc) (format lisp-arglist-command fn)))
|
||||
|
||||
(defun lisp-describe-sym (sym)
|
||||
"Send a command to the inferior Lisp to describe symbol SYM.
|
||||
See variable lisp-describe-sym-command."
|
||||
(interactive (lisp-symprompt "Describe" (lisp-var-at-pt)))
|
||||
(comint-proc-query (cmulisp-proc) (format lisp-describe-sym-command sym)))
|
||||
|
||||
|
||||
(defvar cmulisp-buffer nil "*The current cmulisp process buffer.
|
||||
|
||||
MULTIPLE PROCESS SUPPORT
|
||||
===========================================================================
|
||||
Cmulisp.el supports, in a fairly simple fashion, running multiple Lisp
|
||||
processes. To run multiple Lisp processes, you start the first up with
|
||||
\\[cmulisp]. It will be in a buffer named *cmulisp*. Rename this buffer
|
||||
with \\[rename-buffer]. You may now start up a new process with another
|
||||
\\[cmulisp]. It will be in a new buffer, named *cmulisp*. You can
|
||||
switch between the different process buffers with \\[switch-to-buffer].
|
||||
|
||||
Commands that send text from source buffers to Lisp processes --
|
||||
like lisp-eval-defun or lisp-show-arglist -- have to choose a process
|
||||
to send to, when you have more than one Lisp process around. This
|
||||
is determined by the global variable cmulisp-buffer. Suppose you
|
||||
have three inferior lisps running:
|
||||
Buffer Process
|
||||
foo cmulisp
|
||||
bar cmulisp<2>
|
||||
*cmulisp* cmulisp<3>
|
||||
If you do a \\[lisp-eval-defun] command on some Lisp source code,
|
||||
what process do you send it to?
|
||||
|
||||
- If you're in a process buffer (foo, bar, or *cmulisp*),
|
||||
you send it to that process.
|
||||
- If you're in some other buffer (e.g., a source file), you
|
||||
send it to the process attached to buffer cmulisp-buffer.
|
||||
This process selection is performed by function cmulisp-proc.
|
||||
|
||||
Whenever \\[cmulisp] fires up a new process, it resets cmulisp-buffer
|
||||
to be the new process's buffer. If you only run one process, this will
|
||||
do the right thing. If you run multiple processes, you can change
|
||||
cmulisp-buffer to another process buffer with \\[set-variable].
|
||||
|
||||
More sophisticated approaches are, of course, possible. If you find youself
|
||||
needing to switch back and forth between multiple processes frequently,
|
||||
you may wish to consider ilisp.el, a larger, more sophisticated package
|
||||
for running inferior Lisp processes. The approach taken here is for a
|
||||
minimal, simple implementation. Feel free to extend it.")
|
||||
|
||||
(defun cmulisp-proc ()
|
||||
"Returns the current cmulisp process. See variable cmulisp-buffer."
|
||||
(let ((proc (get-buffer-process (if (eq major-mode 'inferior-lisp-mode)
|
||||
(current-buffer)
|
||||
cmulisp-buffer))))
|
||||
(or proc
|
||||
(error "No current process. See variable cmulisp-buffer"))))
|
||||
|
||||
|
||||
;;; Do the user's customisation...
|
||||
;;;===============================
|
||||
(defvar cmulisp-load-hook nil
|
||||
"This hook is run when cmulisp is loaded in.
|
||||
This is a good place to put keybindings.")
|
||||
|
||||
(run-hooks 'cmulisp-load-hook)
|
||||
|
||||
;;; CHANGE LOG
|
||||
;;; ===========================================================================
|
||||
;;; 5/24/90 Olin
|
||||
;;; - Split cmulisp and cmushell modes into separate files.
|
||||
;;; Not only is this a good idea, it's apparently the way it'll be rel 19.
|
||||
;;; - Upgraded process sends to use comint-send-string instead of
|
||||
;;; process-send-string.
|
||||
;;; - Explicit references to process "cmulisp" have been replaced with
|
||||
;;; (cmulisp-proc). This allows better handling of multiple process bufs.
|
||||
;;; - Added process query and var/function/symbol documentation
|
||||
;;; commands. Based on code written by Douglas Roberts.
|
||||
;;; - Added lisp-eval-last-sexp, bound to C-x C-e.
|
||||
;;;
|
||||
;;; 9/20/90 Olin
|
||||
;;; Added a save-restriction to lisp-fn-called-at-pt. This bug and fix
|
||||
;;; reported by Lennart Staflin.
|
||||
;;;
|
||||
;;; 3/12/90 Olin
|
||||
;;; - lisp-load-file and lisp-compile-file no longer switch-to-lisp.
|
||||
;;; Tale suggested this.
|
||||
;;; - Reversed this decision 7/15/91. You need the visual feedback.
|
||||
;;;
|
||||
;;; 7/25/91 Olin
|
||||
;;; Changed all keybindings of the form C-c <letter>. These are
|
||||
;;; supposed to be reserved for the user to bind. This affected
|
||||
;;; mainly the compile/eval-defun/region[-and-go] commands.
|
||||
;;; This was painful, but necessary to adhere to the gnumacs standard.
|
||||
;;; For some backwards compatibility, see the
|
||||
;;; cmulisp-install-letter-bindings
|
||||
;;; function.
|
||||
;;;
|
||||
;;; 8/2/91 Olin
|
||||
;;; - The lisp-compile/eval-defun/region commands now take a prefix arg,
|
||||
;;; which means switch-to-lisp after sending the text to the Lisp process.
|
||||
;;; This obsoletes all the -and-go commands. The -and-go commands are
|
||||
;;; kept around for historical reasons, and because the user can bind
|
||||
;;; them to key sequences shorter than C-u C-c C-<letter>.
|
||||
;;; - If M-x cmulisp is invoked with a prefix arg, it allows you to
|
||||
;;; edit the command line.
|
||||
|
||||
(provide 'cmulisp)
|
||||
|
||||
;;; cmulisp.el ends here
|
||||
262
lisp/diary-ins.el
Normal file
262
lisp/diary-ins.el
Normal file
@ -0,0 +1,262 @@
|
||||
;;; diary-insert.el --- calendar functions for adding diary entries.
|
||||
|
||||
;; Copyright (C) 1990 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
|
||||
;; Keywords: diary, calendar
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY. No author or distributor
|
||||
;; accepts responsibility to anyone for the consequences of using it
|
||||
;; or for whether it serves any particular purpose or works at all,
|
||||
;; unless he says so in writing. Refer to the GNU Emacs General Public
|
||||
;; License for full details.
|
||||
|
||||
;; Everyone is granted permission to copy, modify and redistribute
|
||||
;; GNU Emacs, but only under the conditions described in the
|
||||
;; GNU Emacs General Public License. A copy of this license is
|
||||
;; supposed to have been given to you along with GNU Emacs so you
|
||||
;; can know your rights and responsibilities. It should be in a
|
||||
;; file named COPYING. Among other things, the copyright notice
|
||||
;; and this notice must be preserved on all copies.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; This collection of functions implements the diary insertion features as
|
||||
;; described in calendar.el.
|
||||
|
||||
;; Comments, corrections, and improvements should be sent to
|
||||
;; Edward M. Reingold Department of Computer Science
|
||||
;; (217) 333-6733 University of Illinois at Urbana-Champaign
|
||||
;; reingold@cs.uiuc.edu 1304 West Springfield Avenue
|
||||
;; Urbana, Illinois 61801
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'diary)
|
||||
|
||||
(defun make-diary-entry (string &optional nonmarking file)
|
||||
"Insert a diary entry STRING which may be NONMARKING in FILE.
|
||||
If omitted, NONMARKING defaults to nil and FILE defaults to diary-file."
|
||||
(find-file-other-window
|
||||
(substitute-in-file-name (if file file diary-file)))
|
||||
(goto-char (point-max))
|
||||
(insert
|
||||
(if (bolp) "" "\n")
|
||||
(if nonmarking diary-nonmarking-symbol "")
|
||||
string " "))
|
||||
|
||||
(defun insert-diary-entry (arg)
|
||||
"Insert a diary entry for the date indicated by point.
|
||||
Prefix arg will make the entry nonmarking."
|
||||
(interactive "P")
|
||||
(make-diary-entry
|
||||
(calendar-date-string
|
||||
(or (calendar-cursor-to-date)
|
||||
(error "Cursor is not on a date!"))
|
||||
t t)
|
||||
arg))
|
||||
|
||||
(defun insert-weekly-diary-entry (arg)
|
||||
"Insert a weekly diary entry for the day of the week indicated by point.
|
||||
Prefix arg will make the entry nonmarking."
|
||||
(interactive "P")
|
||||
(make-diary-entry
|
||||
(calendar-day-name
|
||||
(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")
|
||||
(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!"))
|
||||
nil t))
|
||||
arg))
|
||||
|
||||
(defun insert-block-diary-entry (arg)
|
||||
"Insert a block diary entry for the days between the point and marked date.
|
||||
Prefix arg will make the entry nonmarking."
|
||||
(interactive "P")
|
||||
(let* ((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 nil t)
|
||||
(calendar-date-string end nil t))
|
||||
arg)))
|
||||
|
||||
(defun insert-cyclic-diary-entry (arg)
|
||||
"Insert a cyclic diary entry starting at the date given by point.
|
||||
Prefix arg will make the entry nonmarking."
|
||||
(interactive "P")
|
||||
(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!"))
|
||||
nil t))
|
||||
arg))
|
||||
|
||||
(defun insert-hebrew-diary-entry (arg)
|
||||
"Insert a diary entry for the Hebrew date corresponding to the date
|
||||
indicated by point. Prefix arg will make the entry nonmarking."
|
||||
(interactive "P")
|
||||
(let* ((calendar-month-name-array
|
||||
calendar-hebrew-month-name-array-leap-year))
|
||||
(make-diary-entry
|
||||
(concat
|
||||
hebrew-diary-entry-symbol
|
||||
(calendar-date-string
|
||||
(calendar-hebrew-from-absolute
|
||||
(calendar-absolute-from-gregorian
|
||||
(or (calendar-cursor-to-date)
|
||||
(error "Cursor is not on a date!"))))
|
||||
nil t))
|
||||
arg)))
|
||||
|
||||
(defun insert-monthly-hebrew-diary-entry (arg)
|
||||
"Insert a monthly diary entry for the day of the Hebrew month corresponding
|
||||
to the date indicated by point. Prefix arg will make the entry nonmarking."
|
||||
(interactive "P")
|
||||
(let* ((calendar-date-display-form
|
||||
(if european-calendar-style '(day " * ") '("* " day )))
|
||||
(calendar-month-name-array
|
||||
calendar-hebrew-month-name-array-leap-year))
|
||||
(make-diary-entry
|
||||
(concat
|
||||
hebrew-diary-entry-symbol
|
||||
(calendar-date-string
|
||||
(calendar-hebrew-from-absolute
|
||||
(calendar-absolute-from-gregorian
|
||||
(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-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!"))))
|
||||
nil t))
|
||||
arg)))
|
||||
|
||||
(defun insert-monthly-islamic-diary-entry (arg)
|
||||
"Insert a monthly diary entry for the day of the Islamic month corresponding
|
||||
to the date indicated by point. Prefix arg will make the entry nonmarking."
|
||||
(interactive "P")
|
||||
(let* ((calendar-date-display-form
|
||||
(if european-calendar-style '(day " * ") '("* " day )))
|
||||
(calendar-month-name-array calendar-islamic-month-name-array))
|
||||
(make-diary-entry
|
||||
(concat
|
||||
islamic-diary-entry-symbol
|
||||
(calendar-date-string
|
||||
(calendar-islamic-from-absolute
|
||||
(calendar-absolute-from-gregorian
|
||||
(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-insert)
|
||||
|
||||
;;; diary-insert.el ends here
|
||||
@ -234,9 +234,9 @@
|
||||
(let ((lambda (car form))
|
||||
(values (cdr form)))
|
||||
(if (compiled-function-p lambda)
|
||||
(setq lambda (list 'lambda (nth 0 form)
|
||||
(list 'byte-code
|
||||
(nth 1 form) (nth 2 form) (nth 3 form)))))
|
||||
(setq lambda (list 'lambda (aref lambda 0)
|
||||
(list 'byte-code (aref lambda 1)
|
||||
(aref lambda 2) (aref lambda 3)))))
|
||||
(let ((arglist (nth 1 lambda))
|
||||
(body (cdr (cdr lambda)))
|
||||
optionalp restp
|
||||
@ -913,7 +913,8 @@
|
||||
(eq (car-safe last) 'quote))
|
||||
(if (listp (nth 1 last))
|
||||
(let ((butlast (nreverse (cdr (reverse (cdr (cdr form)))))))
|
||||
(nconc (list 'funcall fn) butlast (nth 1 last)))
|
||||
(nconc (list 'funcall fn) butlast
|
||||
(mapcar '(lambda (x) (list 'quote x)) (nth 1 last))))
|
||||
(byte-compile-warn
|
||||
"last arg to apply can't be a literal atom: %s"
|
||||
(prin1-to-string last))
|
||||
|
||||
@ -142,6 +142,7 @@
|
||||
(require 'lisp-mode)
|
||||
|
||||
|
||||
;;;###autoload
|
||||
(defvar inferior-lisp-filter-regexp "\\`\\s *\\(:\\(\\w\\|\\s_\\)\\)?\\s *\\'"
|
||||
"*What not to save on inferior Lisp's input history
|
||||
Input matching this regexp is not saved on the input history in inferior-lisp
|
||||
@ -212,9 +213,11 @@ You can modify this function to install just the bindings you want."
|
||||
'lisp-show-variable-documentation))
|
||||
|
||||
|
||||
;;;###autoload
|
||||
(defvar inferior-lisp-program "lisp"
|
||||
"*Program name for invoking an inferior Lisp with `inferior-lisp'.")
|
||||
|
||||
;;;###autoload
|
||||
(defvar inferior-lisp-load-command "(load \"%s\")\n"
|
||||
"*Format-string for building a Lisp expression to load a file.
|
||||
This format string should use %s to substitute a file name
|
||||
@ -224,6 +227,7 @@ The string \"(progn (load \\\"%s\\\" :verbose nil :print t) (values))\\\n\"
|
||||
produces cosmetically superior output for this application,
|
||||
but it works only in Common Lisp.")
|
||||
|
||||
;;;###autoload
|
||||
(defvar inferior-lisp-prompt "^[^> ]*>+:? *"
|
||||
"Regexp to recognise prompts in the inferior Lisp.
|
||||
Defaults to \"^[^> ]*>+:? *\", which works pretty good for Lucid, kcl,
|
||||
@ -237,6 +241,7 @@ kcl: \"^>+ *\"
|
||||
|
||||
This is a fine thing to set in your .emacs file.")
|
||||
|
||||
;;;###autoload
|
||||
(defvar inferior-lisp-mode-hook '()
|
||||
"*Hook for customising inferior-lisp mode")
|
||||
|
||||
@ -304,6 +309,7 @@ to continue it."
|
||||
"Don't save anything matching inferior-lisp-filter-regexp"
|
||||
(not (string-match inferior-lisp-filter-regexp str)))
|
||||
|
||||
;;;###autoload
|
||||
(defun inferior-lisp (cmd)
|
||||
"Run an inferior Lisp process, input and output via buffer *inferior-lisp*.
|
||||
If there is a process already running in *inferior-lisp*, just switch
|
||||
|
||||
@ -29,24 +29,29 @@
|
||||
;; This was a pain. Now, make-comint should autoload comint.
|
||||
;; (require 'comint)
|
||||
|
||||
;;;###autoload
|
||||
(defvar tex-shell-file-name nil
|
||||
"*If non-nil, is file name to use for the subshell in which TeX is run.")
|
||||
|
||||
;;;###autoload
|
||||
(defvar tex-directory "."
|
||||
"*Directory in which temporary files are left.
|
||||
You can make this /tmp if your TEXINPUTS has no relative directories in it
|
||||
and you don't try to apply \\[tex-region] or \\[tex-buffer] when there are
|
||||
\\input commands with relative directories.")
|
||||
|
||||
;;;###autoload
|
||||
(defvar tex-offer-save t
|
||||
"*If non-nil, ask about saving modified buffers before \\[tex-file] is run.")
|
||||
|
||||
;;;###autoload
|
||||
(defvar tex-run-command "tex"
|
||||
"*Command used to run TeX subjob.
|
||||
If this string contains an asterisk (*), it will be replaced by the
|
||||
filename; if not, the name of the file, preceded by blank, will be added to
|
||||
this string.")
|
||||
|
||||
;;;###autoload
|
||||
(defvar latex-run-command "latex"
|
||||
"*Command used to run LaTeX subjob.
|
||||
If this string contains an asterisk (*), it will be replaced by the
|
||||
@ -65,28 +70,33 @@ this string.")
|
||||
"verbatim" "verbatim*" "verse")
|
||||
"Standard LaTeX block names.")
|
||||
|
||||
;;;###autoload
|
||||
(defvar latex-block-names nil
|
||||
"*User defined LaTeX block names.
|
||||
Combined with `standard-latex-block-names' for minibuffer completion.")
|
||||
|
||||
;;;###autoload
|
||||
(defvar slitex-run-command "slitex"
|
||||
"*Command used to run SliTeX subjob.
|
||||
If this string contains an asterisk (*), it will be replaced by the
|
||||
filename; if not, the name of the file, preceded by blank, will be added to
|
||||
this string.")
|
||||
|
||||
;;;###autoload
|
||||
(defvar tex-bibtex-command "bibtex"
|
||||
"*Command used by `tex-bibtex-file' to gather bibliographic data.
|
||||
If this string contains an asterisk (*), it will be replaced by the
|
||||
filename; if not, the name of the file, preceded by blank, will be added to
|
||||
this string.")
|
||||
|
||||
;;;###autoload
|
||||
(defvar tex-dvi-print-command "lpr -d"
|
||||
"*Command used by \\[tex-print] to print a .dvi file.
|
||||
If this string contains an asterisk (*), it will be replaced by the
|
||||
filename; if not, the name of the file, preceded by blank, will be added to
|
||||
this string.")
|
||||
|
||||
;;;###autoload
|
||||
(defvar tex-alt-dvi-print-command "lpr -d"
|
||||
"*Command used by \\[tex-print] with a prefix arg to print a .dvi file.
|
||||
If this string contains an asterisk (*), it will be replaced by the
|
||||
@ -103,6 +113,7 @@ for example,
|
||||
would tell \\[tex-print] with a prefix argument to ask you which printer to
|
||||
use.")
|
||||
|
||||
;;;###autoload
|
||||
(defvar tex-dvi-view-command nil
|
||||
"*Command used by \\[tex-view] to display a .dvi file.
|
||||
If this string contains an asterisk (*), it will be replaced by the
|
||||
@ -118,19 +129,23 @@ window system being used. For example,
|
||||
would tell \\[tex-view] use xdvi under X windows and to use dvi2tty
|
||||
otherwise.")
|
||||
|
||||
;;;###autoload
|
||||
(defvar tex-show-queue-command "lpq"
|
||||
"*Command used by \\[tex-show-print-queue] to show the print queue.
|
||||
Should show the queue(s) that \\[tex-print] puts jobs on.")
|
||||
|
||||
;;;###autoload
|
||||
(defvar tex-default-mode 'plain-tex-mode
|
||||
"*Mode to enter for a new file that might be either TeX or LaTeX.
|
||||
This variable is used when it can't be determined whether the file
|
||||
is plain TeX or LaTeX or what because the file contains no commands.
|
||||
Normally set to either 'plain-tex-mode or 'latex-mode.")
|
||||
|
||||
;;;###autoload
|
||||
(defvar tex-open-quote "``"
|
||||
"*String inserted by typing \\[tex-insert-quote] to open a quotation.")
|
||||
|
||||
;;;###autoload
|
||||
(defvar tex-close-quote "''"
|
||||
"*String inserted by typing \\[tex-insert-quote] to close a quotation.")
|
||||
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user