aboutsummaryrefslogtreecommitdiffstats
path: root/lisp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp')
-rw-r--r--lisp/calendar/cal-bahai.el125
-rw-r--r--lisp/calendar/cal-dst.el173
-rw-r--r--lisp/calendar/cal-french.el98
-rw-r--r--lisp/calendar/cal-hebrew.el444
-rw-r--r--lisp/calendar/cal-mayan.el80
-rw-r--r--lisp/calendar/cal-menu.el2
-rw-r--r--lisp/calendar/cal-move.el16
-rw-r--r--lisp/calendar/cal-tex.el2
-rw-r--r--lisp/calendar/cal-x.el10
-rw-r--r--lisp/calendar/calendar.el128
-rw-r--r--lisp/calendar/diary-lib.el632
-rw-r--r--lisp/calendar/lunar.el206
12 files changed, 961 insertions, 955 deletions
diff --git a/lisp/calendar/cal-bahai.el b/lisp/calendar/cal-bahai.el
index 3bb21e9bef5..911ee588dbb 100644
--- a/lisp/calendar/cal-bahai.el
+++ b/lisp/calendar/cal-bahai.el
@@ -77,36 +77,36 @@
77The absolute date is the number of days elapsed since the (imaginary) 77The absolute date is the number of days elapsed since the (imaginary)
78Gregorian date Sunday, December 31, 1 BC." 78Gregorian date Sunday, December 31, 1 BC."
79 (let* ((month (extract-calendar-month date)) 79 (let* ((month (extract-calendar-month date))
80 (day (extract-calendar-day date)) 80 (day (extract-calendar-day date))
81 (year (extract-calendar-year date)) 81 (year (extract-calendar-year date))
82 (prior-years (+ (1- year) 1844)) 82 (prior-years (+ (1- year) 1844))
83 (leap-days (- (+ (/ prior-years 4) ; leap days in prior years 83 (leap-days (- (+ (/ prior-years 4) ; leap days in prior years
84 (- (/ prior-years 100)) 84 (- (/ prior-years 100))
85 (/ prior-years 400)) 85 (/ prior-years 400))
86 calendar-bahai-leap-base))) 86 calendar-bahai-leap-base)))
87 (+ (1- calendar-bahai-epoch) ; days before epoch 87 (+ (1- calendar-bahai-epoch) ; days before epoch
88 (* 365 (1- year)) ; days in prior years 88 (* 365 (1- year)) ; days in prior years
89 leap-days 89 leap-days
90 (calendar-sum m 1 (< m month) 19) 90 (calendar-sum m 1 (< m month) 19)
91 (if (= month 19) 4 0) 91 (if (= month 19) 4 0)
92 day))) ; days so far this month 92 day))) ; days so far this month
93 93
94(defun calendar-bahai-from-absolute (date) 94(defun calendar-bahai-from-absolute (date)
95 "Bahá'í year corresponding to the absolute DATE." 95 "Bahá'í year corresponding to the absolute DATE."
96 (if (< date calendar-bahai-epoch) 96 (if (< date calendar-bahai-epoch)
97 (list 0 0 0) ; pre-Bahá'í date 97 (list 0 0 0) ; pre-Bahá'í date
98 (let* ((greg (calendar-gregorian-from-absolute date)) 98 (let* ((greg (calendar-gregorian-from-absolute date))
99 (year (+ (- (extract-calendar-year greg) 1844) 99 (year (+ (- (extract-calendar-year greg) 1844)
100 (if (or (> (extract-calendar-month greg) 3) 100 (if (or (> (extract-calendar-month greg) 3)
101 (and (= (extract-calendar-month greg) 3) 101 (and (= (extract-calendar-month greg) 3)
102 (>= (extract-calendar-day greg) 21))) 102 (>= (extract-calendar-day greg) 21)))
103 1 0))) 103 1 0)))
104 (month ; search forward from Baha 104 (month ; search forward from Baha
105 (1+ (calendar-sum m 1 105 (1+ (calendar-sum m 1
106 (> date 106 (> date
107 (calendar-absolute-from-bahai 107 (calendar-absolute-from-bahai
108 (list m 19 year))) 108 (list m 19 year)))
109 1))) 109 1)))
110 (day ; calculate the day by subtraction 110 (day ; calculate the day by subtraction
111 (- date 111 (- date
112 (1- (calendar-absolute-from-bahai (list month 1 year)))))) 112 (1- (calendar-absolute-from-bahai (list month 1 year))))))
@@ -117,25 +117,25 @@ Gregorian date Sunday, December 31, 1 BC."
117 "String of Bahá'í date of Gregorian DATE. 117 "String of Bahá'í date of Gregorian DATE.
118Defaults to today's date if DATE is not given." 118Defaults to today's date if DATE is not given."
119 (let* ((bahai-date (calendar-bahai-from-absolute 119 (let* ((bahai-date (calendar-bahai-from-absolute
120 (calendar-absolute-from-gregorian 120 (calendar-absolute-from-gregorian
121 (or date (calendar-current-date))))) 121 (or date (calendar-current-date)))))
122 (y (extract-calendar-year bahai-date)) 122 (y (extract-calendar-year bahai-date))
123 (m (extract-calendar-month bahai-date)) 123 (m (extract-calendar-month bahai-date))
124 (d (extract-calendar-day bahai-date))) 124 (d (extract-calendar-day bahai-date)))
125 (let ((monthname 125 (let ((monthname
126 (if (and (= m 19) 126 (if (and (= m 19)
127 (<= d 0)) 127 (<= d 0))
128 "Ayyám-i-Há" 128 "Ayyám-i-Há"
129 (aref calendar-bahai-month-name-array (1- m)))) 129 (aref calendar-bahai-month-name-array (1- m))))
130 (day (int-to-string 130 (day (int-to-string
131 (if (<= d 0) 131 (if (<= d 0)
132 (if (calendar-bahai-leap-year-p y) 132 (if (calendar-bahai-leap-year-p y)
133 (+ d 5) 133 (+ d 5)
134 (+ d 4)) 134 (+ d 4))
135 d))) 135 d)))
136 (dayname nil) 136 (dayname nil)
137 (month (int-to-string m)) 137 (month (int-to-string m))
138 (year (int-to-string y))) 138 (year (int-to-string y)))
139 (mapconcat 'eval calendar-date-display-form "")))) 139 (mapconcat 'eval calendar-date-display-form ""))))
140 140
141;;;###cal-autoload 141;;;###cal-autoload
@@ -166,15 +166,15 @@ Echo Bahá'í date unless NOECHO is t."
166 (calendar-absolute-from-gregorian today)))))) 166 (calendar-absolute-from-gregorian today))))))
167 (completion-ignore-case t) 167 (completion-ignore-case t)
168 (month (cdr (assoc 168 (month (cdr (assoc
169 (completing-read 169 (completing-read
170 "Bahá'í calendar month name: " 170 "Bahá'í calendar month name: "
171 (mapcar 'list 171 (mapcar 'list
172 (append calendar-bahai-month-name-array nil)) 172 (append calendar-bahai-month-name-array nil))
173 nil t) 173 nil t)
174 (calendar-make-alist calendar-bahai-month-name-array 174 (calendar-make-alist calendar-bahai-month-name-array
175 1)))) 175 1))))
176 (day (calendar-read "Bahá'í calendar day (1-19): " 176 (day (calendar-read "Bahá'í calendar day (1-19): "
177 (lambda (x) (and (< 0 x) (<= x 19)))))) 177 (lambda (x) (and (< 0 x) (<= x 19))))))
178 (list (list month day year)))) 178 (list (list month day year))))
179 179
180(defvar displayed-month) 180(defvar displayed-month)
@@ -187,15 +187,15 @@ If MONTH, DAY (Bahá'í) is visible, the value returned is corresponding
187Gregorian date in the form of the list (((month day year) STRING)). Returns 187Gregorian date in the form of the list (((month day year) STRING)). Returns
188nil if it is not visible in the current calendar window." 188nil if it is not visible in the current calendar window."
189 (let* ((bahai-date (calendar-bahai-from-absolute 189 (let* ((bahai-date (calendar-bahai-from-absolute
190 (calendar-absolute-from-gregorian 190 (calendar-absolute-from-gregorian
191 (list displayed-month 15 displayed-year)))) 191 (list displayed-month 15 displayed-year))))
192 (m (extract-calendar-month bahai-date)) 192 (m (extract-calendar-month bahai-date))
193 (y (extract-calendar-year bahai-date)) 193 (y (extract-calendar-year bahai-date))
194 (date)) 194 (date))
195 (if (< m 1) 195 (if (< m 1)
196 nil ; Bahá'í calendar doesn't apply 196 nil ; Bahá'í calendar doesn't apply
197 (increment-calendar-month m y (- 10 month)) 197 (increment-calendar-month m y (- 10 month))
198 (if (> m 7) ; Bahá'í date might be visible 198 (if (> m 7) ; Bahá'í date might be visible
199 (let ((date (calendar-gregorian-from-absolute 199 (let ((date (calendar-gregorian-from-absolute
200 (calendar-absolute-from-bahai (list month day y))))) 200 (calendar-absolute-from-bahai (list month day y)))))
201 (if (calendar-date-is-visible-p date) 201 (if (calendar-date-is-visible-p date)
@@ -406,7 +406,7 @@ part of `nongregorian-diary-marking-hook'."
406 (cdr (assoc-string 406 (cdr (assoc-string
407 mm-name 407 mm-name
408 (calendar-make-alist 408 (calendar-make-alist
409 calendar-bahai-month-name-array) 409 calendar-bahai-month-name-array)
410 t))))) 410 t)))))
411 (calendar-bahai-mark-date-pattern mm dd yy))))) 411 (calendar-bahai-mark-date-pattern mm dd yy)))))
412 (setq d (cdr d))))) 412 (setq d (cdr d)))))
@@ -427,15 +427,15 @@ A value of 0 in any position is a wildcard."
427 (mark-visible-calendar-date date))) 427 (mark-visible-calendar-date date)))
428 ;; Month and day in any year--this taken from the holiday stuff. 428 ;; Month and day in any year--this taken from the holiday stuff.
429 (let* ((bahai-date (calendar-bahai-from-absolute 429 (let* ((bahai-date (calendar-bahai-from-absolute
430 (calendar-absolute-from-gregorian 430 (calendar-absolute-from-gregorian
431 (list displayed-month 15 displayed-year)))) 431 (list displayed-month 15 displayed-year))))
432 (m (extract-calendar-month bahai-date)) 432 (m (extract-calendar-month bahai-date))
433 (y (extract-calendar-year bahai-date)) 433 (y (extract-calendar-year bahai-date))
434 (date)) 434 (date))
435 (if (< m 1) 435 (if (< m 1)
436 nil ; Bahá'í calendar doesn't apply 436 nil ; Bahá'í calendar doesn't apply
437 (increment-calendar-month m y (- 10 month)) 437 (increment-calendar-month m y (- 10 month))
438 (if (> m 7) ; Bahá'í date might be visible 438 (if (> m 7) ; Bahá'í date might be visible
439 (let ((date (calendar-gregorian-from-absolute 439 (let ((date (calendar-gregorian-from-absolute
440 (calendar-absolute-from-bahai 440 (calendar-absolute-from-bahai
441 (list month day y))))) 441 (list month day y)))))
@@ -457,18 +457,19 @@ A value of 0 in any position is a wildcard."
457 (calendar-absolute-from-gregorian 457 (calendar-absolute-from-gregorian
458 (list m (calendar-last-day-of-month m y) y))) 458 (list m (calendar-last-day-of-month m y) y)))
459 (calendar-for-loop date from first-date to last-date do 459 (calendar-for-loop date from first-date to last-date do
460 (let* ((b-date (calendar-bahai-from-absolute date)) 460 (let* ((b-date (calendar-bahai-from-absolute date))
461 (i-month (extract-calendar-month b-date)) 461 (i-month (extract-calendar-month b-date))
462 (i-day (extract-calendar-day b-date)) 462 (i-day (extract-calendar-day b-date))
463 (i-year (extract-calendar-year b-date))) 463 (i-year (extract-calendar-year b-date)))
464 (and (or (zerop month) 464 (and (or (zerop month)
465 (= month i-month)) 465 (= month i-month))
466 (or (zerop day) 466 (or (zerop day)
467 (= day i-day)) 467 (= day i-day))
468 (or (zerop year) 468 (or (zerop year)
469 (= year i-year)) 469 (= year i-year))
470 (mark-visible-calendar-date 470 (mark-visible-calendar-date
471 (calendar-gregorian-from-absolute date))))))))) 471 (calendar-gregorian-from-absolute
472 date)))))))))
472 473
473;;;###cal-autoload 474;;;###cal-autoload
474(defun diary-bahai-insert-entry (arg) 475(defun diary-bahai-insert-entry (arg)
diff --git a/lisp/calendar/cal-dst.el b/lisp/calendar/cal-dst.el
index b35ec29deb0..78d8b7f4793 100644
--- a/lisp/calendar/cal-dst.el
+++ b/lisp/calendar/cal-dst.el
@@ -4,7 +4,7 @@
4;; 2006, 2007, 2008 Free Software Foundation, Inc. 4;; 2006, 2007, 2008 Free Software Foundation, Inc.
5 5
6;; Author: Paul Eggert <eggert@twinsun.com> 6;; Author: Paul Eggert <eggert@twinsun.com>
7;; Edward M. Reingold <reingold@cs.uiuc.edu> 7;; Edward M. Reingold <reingold@cs.uiuc.edu>
8;; Maintainer: Glenn Morris <rgm@gnu.org> 8;; Maintainer: Glenn Morris <rgm@gnu.org>
9;; Keywords: calendar 9;; Keywords: calendar
10;; Human-Keywords: daylight saving time, calendar, diary, holidays 10;; Human-Keywords: daylight saving time, calendar, diary, holidays
@@ -113,15 +113,15 @@ high and low 16 bits, respectively, of the number of seconds since
113Returns the pair (ABS-DATE . SECONDS) where SECONDS after local midnight on 113Returns the pair (ABS-DATE . SECONDS) where SECONDS after local midnight on
114absolute date ABS-DATE is the equivalent moment to X." 114absolute date ABS-DATE is the equivalent moment to X."
115 (let* ((h (car x)) 115 (let* ((h (car x))
116 (xtail (cdr x)) 116 (xtail (cdr x))
117 (l (+ utc-diff (if (numberp xtail) xtail (car xtail)))) 117 (l (+ utc-diff (if (numberp xtail) xtail (car xtail))))
118 (u (+ (* 512 (mod h 675)) (floor l 128)))) 118 (u (+ (* 512 (mod h 675)) (floor l 128))))
119 ;; Overflow is a terrible thing! 119 ;; Overflow is a terrible thing!
120 (cons (+ calendar-system-time-basis 120 (cons (+ calendar-system-time-basis
121 ;; floor((2^16 h +l) / (60*60*24)) 121 ;; floor((2^16 h +l) / (60*60*24))
122 (* 512 (floor h 675)) (floor u 675)) 122 (* 512 (floor h 675)) (floor u 675))
123 ;; (2^16 h +l) mod (60*60*24) 123 ;; (2^16 h +l) mod (60*60*24)
124 (+ (* (mod u 675) 128) (mod l 128))))) 124 (+ (* (mod u 675) 128) (mod l 128)))))
125 125
126(defun calendar-time-from-absolute (abs-date s) 126(defun calendar-time-from-absolute (abs-date s)
127 "Time of absolute date ABS-DATE, S seconds after midnight. 127 "Time of absolute date ABS-DATE, S seconds after midnight.
@@ -143,12 +143,12 @@ midnight UTC on absolute date ABS-DATE."
143 "Return the time of the next time zone transition after TIME. 143 "Return the time of the next time zone transition after TIME.
144Both TIME and the result are acceptable arguments to `current-time-zone'. 144Both TIME and the result are acceptable arguments to `current-time-zone'.
145Return nil if no such transition can be found." 145Return nil if no such transition can be found."
146 (let* ((base 65536);; 2^16 = base of current-time output 146 (let* ((base 65536) ;; 2^16 = base of current-time output
147 (quarter-multiple 120);; approx = (seconds per quarter year) / base 147 (quarter-multiple 120) ;; approx = (seconds per quarter year) / base
148 (time-zone (current-time-zone time)) 148 (time-zone (current-time-zone time))
149 (time-utc-diff (car time-zone)) 149 (time-utc-diff (car time-zone))
150 hi 150 hi
151 hi-zone 151 hi-zone
152 (hi-utc-diff time-utc-diff) 152 (hi-utc-diff time-utc-diff)
153 (quarters '(2 1 3))) 153 (quarters '(2 1 3)))
154 ;; Heuristic: probe the time zone offset in the next three calendar 154 ;; Heuristic: probe the time zone offset in the next three calendar
@@ -166,21 +166,21 @@ Return nil if no such transition can be found."
166 ;; Set LO to TIME, and then binary search to increase LO and decrease HI 166 ;; Set LO to TIME, and then binary search to increase LO and decrease HI
167 ;; until LO is just before and HI is just after the time zone transition. 167 ;; until LO is just before and HI is just after the time zone transition.
168 (let* ((tail (cdr time)) 168 (let* ((tail (cdr time))
169 (lo (cons (car time) (if (numberp tail) tail (car tail)))) 169 (lo (cons (car time) (if (numberp tail) tail (car tail))))
170 probe) 170 probe)
171 (while 171 (while
172 ;; Set PROBE to halfway between LO and HI, rounding down. 172 ;; Set PROBE to halfway between LO and HI, rounding down.
173 ;; If PROBE equals LO, we are done. 173 ;; If PROBE equals LO, we are done.
174 (let* ((lsum (+ (cdr lo) (cdr hi))) 174 (let* ((lsum (+ (cdr lo) (cdr hi)))
175 (hsum (+ (car lo) (car hi) (/ lsum base))) 175 (hsum (+ (car lo) (car hi) (/ lsum base)))
176 (hsumodd (logand 1 hsum))) 176 (hsumodd (logand 1 hsum)))
177 (setq probe (cons (/ (- hsum hsumodd) 2) 177 (setq probe (cons (/ (- hsum hsumodd) 2)
178 (/ (+ (* hsumodd base) (% lsum base)) 2))) 178 (/ (+ (* hsumodd base) (% lsum base)) 2)))
179 (not (equal lo probe))) 179 (not (equal lo probe)))
180 ;; Set either LO or HI to PROBE, depending on probe results. 180 ;; Set either LO or HI to PROBE, depending on probe results.
181 (if (eq (car (current-time-zone probe)) hi-utc-diff) 181 (if (eq (car (current-time-zone probe)) hi-utc-diff)
182 (setq hi probe) 182 (setq hi probe)
183 (setq lo probe))) 183 (setq lo probe)))
184 hi)))) 184 hi))))
185 185
186(defun calendar-time-zone-daylight-rules (abs-date utc-diff) 186(defun calendar-time-zone-daylight-rules (abs-date utc-diff)
@@ -188,69 +188,70 @@ Return nil if no such transition can be found."
188ABS-DATE must specify a day that contains a daylight saving transition. 188ABS-DATE must specify a day that contains a daylight saving transition.
189The result has the proper form for `calendar-daylight-savings-starts'." 189The result has the proper form for `calendar-daylight-savings-starts'."
190 (let* ((date (calendar-gregorian-from-absolute abs-date)) 190 (let* ((date (calendar-gregorian-from-absolute abs-date))
191 (weekday (% abs-date 7)) 191 (weekday (% abs-date 7))
192 (m (extract-calendar-month date)) 192 (m (extract-calendar-month date))
193 (d (extract-calendar-day date)) 193 (d (extract-calendar-day date))
194 (y (extract-calendar-year date)) 194 (y (extract-calendar-year date))
195 (last (calendar-last-day-of-month m y)) 195 (last (calendar-last-day-of-month m y))
196 (candidate-rules 196 (candidate-rules
197 (append 197 (append
198 ;; Day D of month M. 198 ;; Day D of month M.
199 (list (list 'list m d 'year)) 199 (list (list 'list m d 'year))
200 ;; The first WEEKDAY of month M. 200 ;; The first WEEKDAY of month M.
201 (if (< d 8) 201 (if (< d 8)
202 (list (list 'calendar-nth-named-day 1 weekday m 'year))) 202 (list (list 'calendar-nth-named-day 1 weekday m 'year)))
203 ;; The last WEEKDAY of month M. 203 ;; The last WEEKDAY of month M.
204 (if (> d (- last 7)) 204 (if (> d (- last 7))
205 (list (list 'calendar-nth-named-day -1 weekday m 'year))) 205 (list (list 'calendar-nth-named-day -1 weekday m 'year)))
206 ;; The first WEEKDAY after day J of month M, for D-6 < J <= D. 206 ;; The first WEEKDAY after day J of month M, for D-6 < J <= D.
207 (let (l) 207 (let (l)
208 (calendar-for-loop j from (max 2 (- d 6)) to (min d (- last 8)) do 208 (calendar-for-loop j from (max 2 (- d 6)) to (min d (- last 8)) do
209 (setq l 209 (setq l
210 (cons 210 (cons
211 (list 'calendar-nth-named-day 1 weekday m 'year j) 211 (list 'calendar-nth-named-day
212 l))) 212 1 weekday m 'year j)
213 l) 213 l)))
214 ;; 01-01 and 07-01 for this year's Persian calendar. 214 l)
215 (if (and (= m 3) (<= 20 d) (<= d 21)) 215 ;; 01-01 and 07-01 for this year's Persian calendar.
216 '((calendar-gregorian-from-absolute 216 (if (and (= m 3) (<= 20 d) (<= d 21))
217 (calendar-absolute-from-persian 217 '((calendar-gregorian-from-absolute
218 (list 1 1 (- year 621)))))) 218 (calendar-absolute-from-persian
219 (if (and (= m 9) (<= 22 d) (<= d 23)) 219 (list 1 1 (- year 621))))))
220 '((calendar-gregorian-from-absolute 220 (if (and (= m 9) (<= 22 d) (<= d 23))
221 (calendar-absolute-from-persian 221 '((calendar-gregorian-from-absolute
222 (list 7 1 (- year 621)))))))) 222 (calendar-absolute-from-persian
223 (prevday-sec (- -1 utc-diff)) ;; last sec of previous local day 223 (list 7 1 (- year 621))))))))
224 (year (1+ y))) 224 (prevday-sec (- -1 utc-diff)) ;; last sec of previous local day
225 (year (1+ y)))
225 ;; Scan through the next few years until only one rule remains. 226 ;; Scan through the next few years until only one rule remains.
226 (while 227 (while
227 (let ((rules candidate-rules) 228 (let ((rules candidate-rules)
228 new-rules) 229 new-rules)
229 (while 230 (while
230 (let* 231 (let*
231 ((rule (car rules)) 232 ((rule (car rules))
232 (date 233 (date
233 ;; The following is much faster than 234 ;; The following is much faster than
234 ;; (calendar-absolute-from-gregorian (eval rule)). 235 ;; (calendar-absolute-from-gregorian (eval rule)).
235 (cond ((eq (car rule) 'calendar-nth-named-day) 236 (cond ((eq (car rule) 'calendar-nth-named-day)
236 (eval (cons 'calendar-nth-named-absday (cdr rule)))) 237 (eval (cons 'calendar-nth-named-absday (cdr rule))))
237 ((eq (car rule) 'calendar-gregorian-from-absolute) 238 ((eq (car rule) 'calendar-gregorian-from-absolute)
238 (eval (car (cdr rule)))) 239 (eval (car (cdr rule))))
239 (t (let ((g (eval rule))) 240 (t (let ((g (eval rule)))
240 (calendar-absolute-from-gregorian g)))))) 241 (calendar-absolute-from-gregorian g))))))
241 (or (equal 242 (or (equal
242 (current-time-zone 243 (current-time-zone
243 (calendar-time-from-absolute date prevday-sec)) 244 (calendar-time-from-absolute date prevday-sec))
244 (current-time-zone 245 (current-time-zone
245 (calendar-time-from-absolute (1+ date) prevday-sec))) 246 (calendar-time-from-absolute (1+ date) prevday-sec)))
246 (setq new-rules (cons rule new-rules))) 247 (setq new-rules (cons rule new-rules)))
247 (setq rules (cdr rules)))) 248 (setq rules (cdr rules))))
248 ;; If no rules remain, just use the first candidate rule; 249 ;; If no rules remain, just use the first candidate rule;
249 ;; it's wrong in general, but it's right for at least one year. 250 ;; it's wrong in general, but it's right for at least one year.
250 (setq candidate-rules (if new-rules (nreverse new-rules) 251 (setq candidate-rules (if new-rules (nreverse new-rules)
251 (list (car candidate-rules)))) 252 (list (car candidate-rules))))
252 (setq year (1+ year)) 253 (setq year (1+ year))
253 (cdr candidate-rules))) 254 (cdr candidate-rules)))
254 (car candidate-rules))) 255 (car candidate-rules)))
255 256
256;; TODO it might be better to extract this information directly from 257;; TODO it might be better to extract this information directly from
@@ -414,7 +415,7 @@ This function respects the value of `calendar-dst-check-each-year-flag'."
414 (cadr (calendar-dst-find-startend year)) 415 (cadr (calendar-dst-find-startend year))
415 (nth 4 calendar-current-time-zone-cache)))) 416 (nth 4 calendar-current-time-zone-cache))))
416 (if expr (eval expr))) 417 (if expr (eval expr)))
417 ;; New US rules commencing 2007. ftp://elsie.nci.nih.gov/pub/. 418 ;; New US rules commencing 2007. ftp://elsie.nci.nih.gov/pub/.
418 (and (not (zerop calendar-daylight-time-offset)) 419 (and (not (zerop calendar-daylight-time-offset))
419 (calendar-nth-named-day 2 0 3 year)))) 420 (calendar-nth-named-day 2 0 3 year))))
420 421
@@ -425,7 +426,7 @@ This function respects the value of `calendar-dst-check-each-year-flag'."
425 (nth 2 (calendar-dst-find-startend year)) 426 (nth 2 (calendar-dst-find-startend year))
426 (nth 5 calendar-current-time-zone-cache)))) 427 (nth 5 calendar-current-time-zone-cache))))
427 (if expr (eval expr))) 428 (if expr (eval expr)))
428 ;; New US rules commencing 2007. ftp://elsie.nci.nih.gov/pub/. 429 ;; New US rules commencing 2007. ftp://elsie.nci.nih.gov/pub/.
429 (and (not (zerop calendar-daylight-time-offset)) 430 (and (not (zerop calendar-daylight-time-offset))
430 (calendar-nth-named-day 1 0 11 year)))) 431 (calendar-nth-named-day 1 0 11 year))))
431 432
@@ -469,12 +470,12 @@ Conversion to daylight saving time is done according to
469`calendar-daylight-savings-offset'." 470`calendar-daylight-savings-offset'."
470 471
471 (let* ((rounded-abs-date (+ (calendar-absolute-from-gregorian date) 472 (let* ((rounded-abs-date (+ (calendar-absolute-from-gregorian date)
472 (/ (round (* 60 time)) 60.0 24.0))) 473 (/ (round (* 60 time)) 60.0 24.0)))
473 (dst (dst-in-effect rounded-abs-date)) 474 (dst (dst-in-effect rounded-abs-date))
474 (time-zone (if dst 475 (time-zone (if dst
475 calendar-daylight-time-zone-name 476 calendar-daylight-time-zone-name
476 calendar-standard-time-zone-name)) 477 calendar-standard-time-zone-name))
477 (time (+ rounded-abs-date 478 (time (+ rounded-abs-date
478 (if dst (/ calendar-daylight-time-offset 24.0 60.0) 0)))) 479 (if dst (/ calendar-daylight-time-offset 24.0 60.0) 0))))
479 (list (calendar-gregorian-from-absolute (truncate time)) 480 (list (calendar-gregorian-from-absolute (truncate time))
480 (* 24.0 (- time (truncate time))) 481 (* 24.0 (- time (truncate time)))
diff --git a/lisp/calendar/cal-french.el b/lisp/calendar/cal-french.el
index 1284370809f..1a6057b9b93 100644
--- a/lisp/calendar/cal-french.el
+++ b/lisp/calendar/cal-french.el
@@ -44,10 +44,10 @@
44(defun french-calendar-accents () 44(defun french-calendar-accents ()
45 "True if diacritical marks are available." 45 "True if diacritical marks are available."
46 (and (or window-system 46 (and (or window-system
47 (terminal-coding-system)) 47 (terminal-coding-system))
48 (or enable-multibyte-characters 48 (or enable-multibyte-characters
49 (and (char-table-p standard-display-table) 49 (and (char-table-p standard-display-table)
50 (equal (aref standard-display-table 161) [161]))))) 50 (equal (aref standard-display-table 161) [161])))))
51 51
52(defconst french-calendar-epoch (calendar-absolute-from-gregorian '(9 22 1792)) 52(defconst french-calendar-epoch (calendar-absolute-from-gregorian '(9 22 1792))
53 "Absolute date of start of French Revolutionary calendar = September 22, 1792.") 53 "Absolute date of start of French Revolutionary calendar = September 22, 1792.")
@@ -145,20 +145,22 @@ The absolute date is the number of days elapsed since the
145 (year ; search forward from the approximation 145 (year ; search forward from the approximation
146 (+ approx 146 (+ approx
147 (calendar-sum y approx 147 (calendar-sum y approx
148 (>= date (calendar-absolute-from-french (list 1 1 (1+ y)))) 148 (>= date (calendar-absolute-from-french
149 1))) 149 (list 1 1 (1+ y))))
150 1)))
150 (month ; search forward from Vendemiaire 151 (month ; search forward from Vendemiaire
151 (1+ (calendar-sum m 1 152 (1+ (calendar-sum m 1
152 (> date 153 (> date
153 (calendar-absolute-from-french 154 (calendar-absolute-from-french
154 (list m 155 (list m
155 (french-calendar-last-day-of-month m year) 156 (french-calendar-last-day-of-month
156 year))) 157 m year)
157 1))) 158 year)))
159 1)))
158 (day ; calculate the day by subtraction 160 (day ; calculate the day by subtraction
159 (- date 161 (- date
160 (1- (calendar-absolute-from-french (list month 1 year)))))) 162 (1- (calendar-absolute-from-french (list month 1 year))))))
161 (list month day year)))) 163 (list month day year))))
162 164
163;;;###cal-autoload 165;;;###cal-autoload
164(defun calendar-french-date-string (&optional date) 166(defun calendar-french-date-string (&optional date)
@@ -201,47 +203,47 @@ Defaults to today's date if DATE is not given."
201Echo French Revolutionary date unless NOECHO is t." 203Echo French Revolutionary date unless NOECHO is t."
202 (interactive 204 (interactive
203 (let ((accents (french-calendar-accents)) 205 (let ((accents (french-calendar-accents))
204 (months (french-calendar-month-name-array)) 206 (months (french-calendar-month-name-array))
205 (special-days (french-calendar-special-days-array))) 207 (special-days (french-calendar-special-days-array)))
206 (let* ((year 208 (let* ((year
207 (progn 209 (progn
208 (calendar-read 210 (calendar-read
209 (if accents 211 (if accents
210 "Année de la Révolution (>0): " 212 "Année de la Révolution (>0): "
211 "Anne'e de la Re'volution (>0): ") 213 "Anne'e de la Re'volution (>0): ")
212 (lambda (x) (> x 0)) 214 (lambda (x) (> x 0))
213 (int-to-string 215 (int-to-string
214 (extract-calendar-year 216 (extract-calendar-year
215 (calendar-french-from-absolute 217 (calendar-french-from-absolute
216 (calendar-absolute-from-gregorian 218 (calendar-absolute-from-gregorian
217 (calendar-current-date)))))))) 219 (calendar-current-date))))))))
218 (month-list 220 (month-list
219 (mapcar 'list 221 (mapcar 'list
220 (append months 222 (append months
221 (if (french-calendar-leap-year-p year) 223 (if (french-calendar-leap-year-p year)
222 (mapcar 224 (mapcar
223 (lambda (x) (concat "Jour " x)) 225 (lambda (x) (concat "Jour " x))
224 french-calendar-special-days-array) 226 french-calendar-special-days-array)
225 (reverse 227 (reverse
226 (cdr ; we don't want rev. day in a non-leap yr 228 (cdr ; we don't want rev. day in a non-leap yr
227 (reverse 229 (reverse
228 (mapcar 230 (mapcar
229 (lambda (x) 231 (lambda (x)
230 (concat "Jour " x)) 232 (concat "Jour " x))
231 special-days)))))))) 233 special-days))))))))
232 (completion-ignore-case t) 234 (completion-ignore-case t)
233 (month (cdr (assoc-string 235 (month (cdr (assoc-string
234 (completing-read 236 (completing-read
235 "Mois ou Sansculottide: " 237 "Mois ou Sansculottide: "
236 month-list 238 month-list
237 nil t) 239 nil t)
238 (calendar-make-alist month-list 1 'car) t))) 240 (calendar-make-alist month-list 1 'car) t)))
239 (day (if (> month 12) 241 (day (if (> month 12)
240 (- month 12) 242 (- month 12)
241 (calendar-read 243 (calendar-read
242 "Jour (1-30): " 244 "Jour (1-30): "
243 (lambda (x) (and (<= 1 x) (<= x 30)))))) 245 (lambda (x) (and (<= 1 x) (<= x 30))))))
244 (month (if (> month 12) 13 month))) 246 (month (if (> month 12) 13 month)))
245 (list (list month day year))))) 247 (list (list month day year)))))
246 (calendar-goto-date (calendar-gregorian-from-absolute 248 (calendar-goto-date (calendar-gregorian-from-absolute
247 (calendar-absolute-from-french date))) 249 (calendar-absolute-from-french date)))
diff --git a/lisp/calendar/cal-hebrew.el b/lisp/calendar/cal-hebrew.el
index 1e68cc6b7d2..c4d2ac67f0b 100644
--- a/lisp/calendar/cal-hebrew.el
+++ b/lisp/calendar/cal-hebrew.el
@@ -64,27 +64,27 @@
64 (* 12 months-elapsed) 64 (* 12 months-elapsed)
65 (* 793 (/ months-elapsed 1080)) 65 (* 793 (/ months-elapsed 1080))
66 (/ parts-elapsed 1080))) 66 (/ parts-elapsed 1080)))
67 (parts ; conjunction parts 67 (parts ; conjunction parts
68 (+ (* 1080 (% hours-elapsed 24)) (% parts-elapsed 1080))) 68 (+ (* 1080 (% hours-elapsed 24)) (% parts-elapsed 1080)))
69 (day ; conjunction day 69 (day ; conjunction day
70 (+ 1 (* 29 months-elapsed) (/ hours-elapsed 24))) 70 (+ 1 (* 29 months-elapsed) (/ hours-elapsed 24)))
71 (alternative-day 71 (alternative-day
72 (if (or (>= parts 19440) ; if the new moon is at or after midday 72 (if (or (>= parts 19440) ; if the new moon is at or after midday
73 (and (= (% day 7) 2) ; ...or is on a Tuesday... 73 (and (= (% day 7) 2) ; ...or is on a Tuesday...
74 (>= parts 9924) ; at 9 hours, 204 parts or later... 74 (>= parts 9924) ; at 9 hours, 204 parts or later...
75 ;; of a common year... 75 ;; of a common year...
76 (not (hebrew-calendar-leap-year-p year))) 76 (not (hebrew-calendar-leap-year-p year)))
77 (and (= (% day 7) 1) ; ...or is on a Monday... 77 (and (= (% day 7) 1) ; ...or is on a Monday...
78 (>= parts 16789) ; at 15 hours, 589 parts or later... 78 (>= parts 16789) ; at 15 hours, 589 parts or later...
79 ;; at the end of a leap year. 79 ;; at the end of a leap year.
80 (hebrew-calendar-leap-year-p (1- year)))) 80 (hebrew-calendar-leap-year-p (1- year))))
81 ;; Then postpone Rosh HaShanah one day. 81 ;; Then postpone Rosh HaShanah one day.
82 (1+ day) 82 (1+ day)
83 ;; Else: 83 ;; Else:
84 day))) 84 day)))
85 ;; If Rosh HaShanah would occur on Sunday, Wednesday, or Friday 85 ;; If Rosh HaShanah would occur on Sunday, Wednesday, or Friday
86 (if (memq (% alternative-day 7) (list 0 3 5)) 86 (if (memq (% alternative-day 7) (list 0 3 5))
87 ;; Then postpone it one (more) day and return. 87 ;; Then postpone it one (more) day and return.
88 (1+ alternative-day) 88 (1+ alternative-day)
89 ;; Else return. 89 ;; Else return.
90 alternative-day))) 90 alternative-day)))
@@ -118,21 +118,21 @@ Gregorian date Sunday, December 31, 1 BC."
118 (let* ((month (extract-calendar-month date)) 118 (let* ((month (extract-calendar-month date))
119 (day (extract-calendar-day date)) 119 (day (extract-calendar-day date))
120 (year (extract-calendar-year date))) 120 (year (extract-calendar-year date)))
121 (+ day ; days so far this month 121 (+ day ; days so far this month
122 (if (< month 7) ; before Tishri 122 (if (< month 7) ; before Tishri
123 ;; Then add days in prior months this year before and after Nisan. 123 ;; Then add days in prior months this year before and after Nisan.
124 (+ (calendar-sum 124 (+ (calendar-sum
125 m 7 (<= m (hebrew-calendar-last-month-of-year year)) 125 m 7 (<= m (hebrew-calendar-last-month-of-year year))
126 (hebrew-calendar-last-day-of-month m year)) 126 (hebrew-calendar-last-day-of-month m year))
127 (calendar-sum 127 (calendar-sum
128 m 1 (< m month) 128 m 1 (< m month)
129 (hebrew-calendar-last-day-of-month m year))) 129 (hebrew-calendar-last-day-of-month m year)))
130 ;; Else add days in prior months this year. 130 ;; Else add days in prior months this year.
131 (calendar-sum 131 (calendar-sum
132 m 7 (< m month) 132 m 7 (< m month)
133 (hebrew-calendar-last-day-of-month m year))) 133 (hebrew-calendar-last-day-of-month m year)))
134 (hebrew-calendar-elapsed-days year) ; days in prior years 134 (hebrew-calendar-elapsed-days year) ; days in prior years
135 -1373429))) ; days elapsed before absolute date 1 135 -1373429))) ; days elapsed before absolute date 1
136 136
137(defun calendar-hebrew-from-absolute (date) 137(defun calendar-hebrew-from-absolute (date)
138 "Compute the Hebrew date (month day year) corresponding to absolute DATE. 138 "Compute the Hebrew date (month day year) corresponding to absolute DATE.
@@ -140,11 +140,11 @@ The absolute date is the number of days elapsed since the (imaginary)
140Gregorian date Sunday, December 31, 1 BC." 140Gregorian date Sunday, December 31, 1 BC."
141 (let* ((greg-date (calendar-gregorian-from-absolute date)) 141 (let* ((greg-date (calendar-gregorian-from-absolute date))
142 (month (aref [9 10 11 12 1 2 3 4 7 7 7 8] 142 (month (aref [9 10 11 12 1 2 3 4 7 7 7 8]
143 (1- (extract-calendar-month greg-date)))) 143 (1- (extract-calendar-month greg-date))))
144 (day) 144 (day)
145 (year (+ 3760 (extract-calendar-year greg-date)))) 145 (year (+ 3760 (extract-calendar-year greg-date))))
146 (while (>= date (calendar-absolute-from-hebrew (list 7 1 (1+ year)))) 146 (while (>= date (calendar-absolute-from-hebrew (list 7 1 (1+ year))))
147 (setq year (1+ year))) 147 (setq year (1+ year)))
148 (let ((length (hebrew-calendar-last-month-of-year year))) 148 (let ((length (hebrew-calendar-last-month-of-year year)))
149 (while (> date 149 (while (> date
150 (calendar-absolute-from-hebrew 150 (calendar-absolute-from-hebrew
@@ -159,12 +159,12 @@ Gregorian date Sunday, December 31, 1 BC."
159(defvar calendar-hebrew-month-name-array-common-year 159(defvar calendar-hebrew-month-name-array-common-year
160 ["Nisan" "Iyar" "Sivan" "Tammuz" "Av" "Elul" "Tishri" 160 ["Nisan" "Iyar" "Sivan" "Tammuz" "Av" "Elul" "Tishri"
161 "Heshvan" "Kislev" "Teveth" "Shevat" "Adar"] 161 "Heshvan" "Kislev" "Teveth" "Shevat" "Adar"]
162"Array of strings giving the names of the Hebrew months in a common year.") 162 "Array of strings giving the names of the Hebrew months in a common year.")
163 163
164(defvar calendar-hebrew-month-name-array-leap-year 164(defvar calendar-hebrew-month-name-array-leap-year
165 ["Nisan" "Iyar" "Sivan" "Tammuz" "Av" "Elul" "Tishri" 165 ["Nisan" "Iyar" "Sivan" "Tammuz" "Av" "Elul" "Tishri"
166 "Heshvan" "Kislev" "Teveth" "Shevat" "Adar I" "Adar II"] 166 "Heshvan" "Kislev" "Teveth" "Shevat" "Adar I" "Adar II"]
167"Array of strings giving the names of the Hebrew months in a leap year.") 167 "Array of strings giving the names of the Hebrew months in a leap year.")
168 168
169;;;###cal-autoload 169;;;###cal-autoload
170(defun calendar-hebrew-date-string (&optional date) 170(defun calendar-hebrew-date-string (&optional date)
@@ -242,17 +242,17 @@ Driven by the variable `calendar-date-display-form'."
242 (mapcar 'list (append month-array nil)) 242 (mapcar 'list (append month-array nil))
243 (if (= year 3761) 243 (if (= year 3761)
244 (lambda (x) 244 (lambda (x)
245 (let ((m (cdr 245 (let ((m (cdr
246 (assoc-string 246 (assoc-string
247 (car x) 247 (car x)
248 (calendar-make-alist month-array) 248 (calendar-make-alist month-array)
249 t)))) 249 t))))
250 (< 0 250 (< 0
251 (calendar-absolute-from-hebrew 251 (calendar-absolute-from-hebrew
252 (list m 252 (list m
253 (hebrew-calendar-last-day-of-month 253 (hebrew-calendar-last-day-of-month
254 m year) 254 m year)
255 year)))))) 255 year))))))
256 t) 256 t)
257 (calendar-make-alist month-array 1) t))) 257 (calendar-make-alist month-array 1) t)))
258 (last (hebrew-calendar-last-day-of-month month year)) 258 (last (hebrew-calendar-last-day-of-month month year))
@@ -311,21 +311,21 @@ nil if it is not visible in the current calendar window."
311 "List of dates related to Rosh Hashanah, as visible in calendar window." 311 "List of dates related to Rosh Hashanah, as visible in calendar window."
312 (if (or (< displayed-month 8) 312 (if (or (< displayed-month 8)
313 (> displayed-month 11)) 313 (> displayed-month 11))
314 nil ; none of the dates is visible 314 nil ; none of the dates is visible
315 (let* ((abs-r-h (calendar-absolute-from-hebrew 315 (let* ((abs-r-h (calendar-absolute-from-hebrew
316 (list 7 1 (+ displayed-year 3761)))) 316 (list 7 1 (+ displayed-year 3761))))
317 (mandatory 317 (mandatory
318 (list 318 (list
319 (list (calendar-gregorian-from-absolute abs-r-h) 319 (list (calendar-gregorian-from-absolute abs-r-h)
320 (format "Rosh HaShanah %d" (+ 3761 displayed-year))) 320 (format "Rosh HaShanah %d" (+ 3761 displayed-year)))
321 (list (calendar-gregorian-from-absolute (+ abs-r-h 9)) 321 (list (calendar-gregorian-from-absolute (+ abs-r-h 9))
322 "Yom Kippur") 322 "Yom Kippur")
323 (list (calendar-gregorian-from-absolute (+ abs-r-h 14)) 323 (list (calendar-gregorian-from-absolute (+ abs-r-h 14))
324 "Sukkot") 324 "Sukkot")
325 (list (calendar-gregorian-from-absolute (+ abs-r-h 21)) 325 (list (calendar-gregorian-from-absolute (+ abs-r-h 21))
326 "Shemini Atzeret") 326 "Shemini Atzeret")
327 (list (calendar-gregorian-from-absolute (+ abs-r-h 22)) 327 (list (calendar-gregorian-from-absolute (+ abs-r-h 22))
328 "Simchat Torah"))) 328 "Simchat Torah")))
329 (optional 329 (optional
330 (list 330 (list
331 (list (calendar-gregorian-from-absolute 331 (list (calendar-gregorian-from-absolute
@@ -357,8 +357,8 @@ nil if it is not visible in the current calendar window."
357 "Hol Hamoed Sukkot (fourth day)") 357 "Hol Hamoed Sukkot (fourth day)")
358 (list (calendar-gregorian-from-absolute (+ abs-r-h 20)) 358 (list (calendar-gregorian-from-absolute (+ abs-r-h 20))
359 "Hoshanah Rabbah"))) 359 "Hoshanah Rabbah")))
360 (output-list 360 (output-list
361 (holiday-filter-visible-calendar mandatory))) 361 (holiday-filter-visible-calendar mandatory)))
362 (if all-hebrew-calendar-holidays 362 (if all-hebrew-calendar-holidays
363 (setq output-list 363 (setq output-list
364 (append 364 (append
@@ -371,43 +371,43 @@ nil if it is not visible in the current calendar window."
371 "List of dates related to Hanukkah, as visible in calendar window." 371 "List of dates related to Hanukkah, as visible in calendar window."
372 ;; This test is only to speed things up a bit, it works fine without it. 372 ;; This test is only to speed things up a bit, it works fine without it.
373 (if (memq displayed-month 373 (if (memq displayed-month
374 '(10 11 12 1 2)) 374 '(10 11 12 1 2))
375 (let ((m displayed-month) 375 (let ((m displayed-month)
376 (y displayed-year)) 376 (y displayed-year))
377 (increment-calendar-month m y 1) 377 (increment-calendar-month m y 1)
378 (let* ((h-y (extract-calendar-year 378 (let* ((h-y (extract-calendar-year
379 (calendar-hebrew-from-absolute 379 (calendar-hebrew-from-absolute
380 (calendar-absolute-from-gregorian 380 (calendar-absolute-from-gregorian
381 (list m (calendar-last-day-of-month m y) y))))) 381 (list m (calendar-last-day-of-month m y) y)))))
382 (abs-h (calendar-absolute-from-hebrew (list 9 25 h-y)))) 382 (abs-h (calendar-absolute-from-hebrew (list 9 25 h-y))))
383 (holiday-filter-visible-calendar 383 (holiday-filter-visible-calendar
384 (list 384 (list
385 (list (calendar-gregorian-from-absolute (1- abs-h)) 385 (list (calendar-gregorian-from-absolute (1- abs-h))
386 "Erev Hanukkah") 386 "Erev Hanukkah")
387 (list (calendar-gregorian-from-absolute abs-h) 387 (list (calendar-gregorian-from-absolute abs-h)
388 "Hanukkah (first day)") 388 "Hanukkah (first day)")
389 (list (calendar-gregorian-from-absolute (1+ abs-h)) 389 (list (calendar-gregorian-from-absolute (1+ abs-h))
390 "Hanukkah (second day)") 390 "Hanukkah (second day)")
391 (list (calendar-gregorian-from-absolute (+ abs-h 2)) 391 (list (calendar-gregorian-from-absolute (+ abs-h 2))
392 "Hanukkah (third day)") 392 "Hanukkah (third day)")
393 (list (calendar-gregorian-from-absolute (+ abs-h 3)) 393 (list (calendar-gregorian-from-absolute (+ abs-h 3))
394 "Hanukkah (fourth day)") 394 "Hanukkah (fourth day)")
395 (list (calendar-gregorian-from-absolute (+ abs-h 4)) 395 (list (calendar-gregorian-from-absolute (+ abs-h 4))
396 "Hanukkah (fifth day)") 396 "Hanukkah (fifth day)")
397 (list (calendar-gregorian-from-absolute (+ abs-h 5)) 397 (list (calendar-gregorian-from-absolute (+ abs-h 5))
398 "Hanukkah (sixth day)") 398 "Hanukkah (sixth day)")
399 (list (calendar-gregorian-from-absolute (+ abs-h 6)) 399 (list (calendar-gregorian-from-absolute (+ abs-h 6))
400 "Hanukkah (seventh day)") 400 "Hanukkah (seventh day)")
401 (list (calendar-gregorian-from-absolute (+ abs-h 7)) 401 (list (calendar-gregorian-from-absolute (+ abs-h 7))
402 "Hanukkah (eighth day)"))))))) 402 "Hanukkah (eighth day)")))))))
403 403
404;;;###holiday-autoload 404;;;###holiday-autoload
405(defun holiday-passover-etc () 405(defun holiday-passover-etc ()
406 "List of dates related to Passover, as visible in calendar window." 406 "List of dates related to Passover, as visible in calendar window."
407 (if (< 7 displayed-month) 407 (if (< 7 displayed-month)
408 nil ; none of the dates is visible 408 nil ; none of the dates is visible
409 (let* ((abs-p (calendar-absolute-from-hebrew 409 (let* ((abs-p (calendar-absolute-from-hebrew
410 (list 1 15 (+ displayed-year 3760)))) 410 (list 1 15 (+ displayed-year 3760))))
411 (mandatory 411 (mandatory
412 (list 412 (list
413 (list (calendar-gregorian-from-absolute abs-p) 413 (list (calendar-gregorian-from-absolute abs-p)
@@ -478,7 +478,7 @@ nil if it is not visible in the current calendar window."
478 (list (calendar-gregorian-from-absolute (+ abs-p 51)) 478 (list (calendar-gregorian-from-absolute (+ abs-p 51))
479 "Shavuot (second day)"))) 479 "Shavuot (second day)")))
480 (output-list 480 (output-list
481 (holiday-filter-visible-calendar mandatory))) 481 (holiday-filter-visible-calendar mandatory)))
482 (if all-hebrew-calendar-holidays 482 (if all-hebrew-calendar-holidays
483 (setq output-list 483 (setq output-list
484 (append 484 (append
@@ -491,9 +491,9 @@ nil if it is not visible in the current calendar window."
491 "List of dates around Tisha B'Av, as visible in calendar window." 491 "List of dates around Tisha B'Av, as visible in calendar window."
492 (if (or (< displayed-month 5) 492 (if (or (< displayed-month 5)
493 (> displayed-month 9)) 493 (> displayed-month 9))
494 nil ; none of the dates is visible 494 nil ; none of the dates is visible
495 (let* ((abs-t-a (calendar-absolute-from-hebrew 495 (let* ((abs-t-a (calendar-absolute-from-hebrew
496 (list 5 9 (+ displayed-year 3760))))) 496 (list 5 9 (+ displayed-year 3760)))))
497 497
498 (holiday-filter-visible-calendar 498 (holiday-filter-visible-calendar
499 (list 499 (list
@@ -514,7 +514,7 @@ nil if it is not visible in the current calendar window."
514(declare-function add-to-diary-list "diary-lib" 514(declare-function add-to-diary-list "diary-lib"
515 (date string specifier &optional marker globcolor literal)) 515 (date string specifier &optional marker globcolor literal))
516 516
517(defvar number) ; from diary-list-entries 517(defvar number) ; from diary-list-entries
518 518
519;;;###diary-autoload 519;;;###diary-autoload
520(defun list-hebrew-diary-entries () 520(defun list-hebrew-diary-entries ()
@@ -619,8 +619,8 @@ A value of 0 in any position is a wildcard."
619 (if (calendar-date-is-visible-p date) 619 (if (calendar-date-is-visible-p date)
620 (mark-visible-calendar-date date))) 620 (mark-visible-calendar-date date)))
621 ;; Month and day in any year--this taken from the holiday stuff. 621 ;; Month and day in any year--this taken from the holiday stuff.
622 ;; This test is only to speed things up a bit, it works 622 ;; This test is only to speed things up a bit, it works
623 ;; fine without it. 623 ;; fine without it.
624 (if (memq displayed-month 624 (if (memq displayed-month
625 (list 625 (list
626 (if (< 11 month) (- month 11) (+ month 1)) 626 (if (< 11 month) (- month 11) (+ month 1))
@@ -668,18 +668,19 @@ A value of 0 in any position is a wildcard."
668 (calendar-absolute-from-gregorian 668 (calendar-absolute-from-gregorian
669 (list m (calendar-last-day-of-month m y) y))) 669 (list m (calendar-last-day-of-month m y) y)))
670 (calendar-for-loop date from first-date to last-date do 670 (calendar-for-loop date from first-date to last-date do
671 (let* ((h-date (calendar-hebrew-from-absolute date)) 671 (let* ((h-date (calendar-hebrew-from-absolute date))
672 (h-month (extract-calendar-month h-date)) 672 (h-month (extract-calendar-month h-date))
673 (h-day (extract-calendar-day h-date)) 673 (h-day (extract-calendar-day h-date))
674 (h-year (extract-calendar-year h-date))) 674 (h-year (extract-calendar-year h-date)))
675 (and (or (zerop month) 675 (and (or (zerop month)
676 (= month h-month)) 676 (= month h-month))
677 (or (zerop day) 677 (or (zerop day)
678 (= day h-day)) 678 (= day h-day))
679 (or (zerop year) 679 (or (zerop year)
680 (= year h-year)) 680 (= year h-year))
681 (mark-visible-calendar-date 681 (mark-visible-calendar-date
682 (calendar-gregorian-from-absolute date))))))))) 682 (calendar-gregorian-from-absolute date)))))
683 ))))
683 684
684(declare-function diary-name-pattern "diary-lib" 685(declare-function diary-name-pattern "diary-lib"
685 (string-array &optional abbrev-array paren)) 686 (string-array &optional abbrev-array paren))
@@ -704,7 +705,7 @@ is provided for use as part of `nongregorian-diary-marking-hook'."
704 (let* 705 (let*
705 ((date-form (if (equal (car (car d)) 'backup) 706 ((date-form (if (equal (car (car d)) 'backup)
706 (cdr (car d)) 707 (cdr (car d))
707 (car d))) ; ignore 'backup directive 708 (car d))) ; ignore 'backup directive
708 (dayname (diary-name-pattern calendar-day-name-array 709 (dayname (diary-name-pattern calendar-day-name-array
709 calendar-day-abbrev-array)) 710 calendar-day-abbrev-array))
710 (monthname 711 (monthname
@@ -781,9 +782,9 @@ is provided for use as part of `nongregorian-diary-marking-hook'."
781 (if dd-name 782 (if dd-name
782 (mark-calendar-days-named 783 (mark-calendar-days-named
783 (cdr (assoc-string dd-name 784 (cdr (assoc-string dd-name
784 (calendar-make-alist 785 (calendar-make-alist
785 calendar-day-name-array 786 calendar-day-name-array
786 0 nil calendar-day-abbrev-array) t))) 787 0 nil calendar-day-abbrev-array) t)))
787 (if mm-name 788 (if mm-name
788 (setq mm 789 (setq mm
789 (if (string-equal mm-name "*") 0 790 (if (string-equal mm-name "*") 0
@@ -889,8 +890,8 @@ from the cursor position."
889 (end-year (calendar-read 890 (end-year (calendar-read
890 (format "Ending year of Yahrzeit table (>=%d): " 891 (format "Ending year of Yahrzeit table (>=%d): "
891 start-year) 892 start-year)
892 (lambda (x) (>= x start-year))))) 893 (lambda (x) (>= x start-year)))))
893 (list death-date start-year end-year))) 894 (list death-date start-year end-year)))
894 (message "Computing Yahrzeits...") 895 (message "Computing Yahrzeits...")
895 (let* ((h-date (calendar-hebrew-from-absolute 896 (let* ((h-date (calendar-hebrew-from-absolute
896 (calendar-absolute-from-gregorian death-date))) 897 (calendar-absolute-from-gregorian death-date)))
@@ -910,14 +911,15 @@ from the cursor position."
910 (erase-buffer) 911 (erase-buffer)
911 (goto-char (point-min)) 912 (goto-char (point-min))
912 (calendar-for-loop i from start-year to end-year do 913 (calendar-for-loop i from start-year to end-year do
913 (insert 914 (insert
914 (calendar-date-string 915 (calendar-date-string
915 (calendar-gregorian-from-absolute 916 (calendar-gregorian-from-absolute
916 (hebrew-calendar-yahrzeit 917 (hebrew-calendar-yahrzeit
917 h-date 918 h-date
918 (extract-calendar-year 919 (extract-calendar-year
919 (calendar-hebrew-from-absolute 920 (calendar-hebrew-from-absolute
920 (calendar-absolute-from-gregorian (list 1 1 i))))))) "\n")) 921 (calendar-absolute-from-gregorian
922 (list 1 1 i))))))) "\n"))
921 (goto-char (point-min)) 923 (goto-char (point-min))
922 (set-buffer-modified-p nil) 924 (set-buffer-modified-p nil)
923 (setq buffer-read-only t) 925 (setq buffer-read-only t)
@@ -947,17 +949,17 @@ use when highlighting the day in the calendar."
947 (day (% omer 7))) 949 (day (% omer 7)))
948 (if (and (> omer 0) (< omer 50)) 950 (if (and (> omer 0) (< omer 50))
949 (cons mark 951 (cons mark
950 (format "Day %d%s of the omer (until sunset)" 952 (format "Day %d%s of the omer (until sunset)"
951 omer 953 omer
952 (if (zerop week) 954 (if (zerop week)
953 "" 955 ""
954 (format ", that is, %d week%s%s" 956 (format ", that is, %d week%s%s"
955 week 957 week
956 (if (= week 1) "" "s") 958 (if (= week 1) "" "s")
957 (if (zerop day) 959 (if (zerop day)
958 "" 960 ""
959 (format " and %d day%s" 961 (format " and %d day%s"
960 day (if (= day 1) "" "s")))))))))) 962 day (if (= day 1) "" "s"))))))))))
961 963
962(defvar entry) 964(defvar entry)
963 965
@@ -976,7 +978,7 @@ use when highlighting the day in the calendar."
976 (calendar-absolute-from-gregorian 978 (calendar-absolute-from-gregorian
977 (if european-calendar-style 979 (if european-calendar-style
978 (list death-day death-month death-year) 980 (list death-day death-month death-year)
979 (list death-month death-day death-year))))) 981 (list death-month death-day death-year)))))
980 (h-month (extract-calendar-month h-date)) 982 (h-month (extract-calendar-month h-date))
981 (h-day (extract-calendar-day h-date)) 983 (h-day (extract-calendar-day h-date))
982 (h-year (extract-calendar-year h-date)) 984 (h-year (extract-calendar-year h-date))
@@ -986,14 +988,14 @@ use when highlighting the day in the calendar."
986 (y (hebrew-calendar-yahrzeit h-date yr))) 988 (y (hebrew-calendar-yahrzeit h-date yr)))
987 (if (and (> diff 0) (or (= y d) (= y (1+ d)))) 989 (if (and (> diff 0) (or (= y d) (= y (1+ d))))
988 (cons mark 990 (cons mark
989 (format "Yahrzeit of %s%s: %d%s anniversary" 991 (format "Yahrzeit of %s%s: %d%s anniversary"
990 entry 992 entry
991 (if (= y d) "" " (evening)") 993 (if (= y d) "" " (evening)")
992 diff 994 diff
993 (cond ((= (% diff 10) 1) "st") 995 (cond ((= (% diff 10) 1) "st")
994 ((= (% diff 10) 2) "nd") 996 ((= (% diff 10) 2) "nd")
995 ((= (% diff 10) 3) "rd") 997 ((= (% diff 10) 3) "rd")
996 (t "th"))))))) 998 (t "th")))))))
997 999
998;;;###diary-autoload 1000;;;###diary-autoload
999(defun diary-rosh-hodesh (&optional mark) 1001(defun diary-rosh-hodesh (&optional mark)
@@ -1018,60 +1020,60 @@ use when highlighting the day in the calendar."
1018 (calendar-hebrew-from-absolute (1- d))))) 1020 (calendar-hebrew-from-absolute (1- d)))))
1019 (if (or (= h-day 30) (and (= h-day 1) (/= h-month 7))) 1021 (if (or (= h-day 30) (and (= h-day 1) (/= h-month 7)))
1020 (cons mark 1022 (cons mark
1021 (format 1023 (format
1022 "Rosh Hodesh %s" 1024 "Rosh Hodesh %s"
1023 (if (= h-day 30) 1025 (if (= h-day 30)
1024 (format 1026 (format
1025 "%s (first day)" 1027 "%s (first day)"
1026 ;; Next month must be in the same year since this 1028 ;; Next month must be in the same year since this
1027 ;; month can't be the last month of the year since 1029 ;; month can't be the last month of the year since
1028 ;; it has 30 days 1030 ;; it has 30 days
1029 (aref h-month-names h-month)) 1031 (aref h-month-names h-month))
1030 (if (= h-yesterday 30) 1032 (if (= h-yesterday 30)
1031 (format "%s (second day)" this-month) 1033 (format "%s (second day)" this-month)
1032 this-month)))) 1034 this-month))))
1033 (if (= (% d 7) 6) ; Saturday--check for Shabbat Mevarchim 1035 (if (= (% d 7) 6) ; Saturday--check for Shabbat Mevarchim
1034 (cons mark 1036 (cons mark
1035 (cond ((and (> h-day 22) (/= h-month 6) (= 29 last-day)) 1037 (cond ((and (> h-day 22) (/= h-month 6) (= 29 last-day))
1036 (format "Mevarchim Rosh Hodesh %s (%s)" 1038 (format "Mevarchim Rosh Hodesh %s (%s)"
1037 (aref h-month-names 1039 (aref h-month-names
1038 (if (= h-month 1040 (if (= h-month
1039 (hebrew-calendar-last-month-of-year 1041 (hebrew-calendar-last-month-of-year
1040 h-year)) 1042 h-year))
1041 0 h-month)) 1043 0 h-month))
1042 (aref calendar-day-name-array (- 29 h-day)))) 1044 (aref calendar-day-name-array (- 29 h-day))))
1043 ((and (< h-day 30) (> h-day 22) (= 30 last-day)) 1045 ((and (< h-day 30) (> h-day 22) (= 30 last-day))
1044 (format "Mevarchim Rosh Hodesh %s (%s-%s)" 1046 (format "Mevarchim Rosh Hodesh %s (%s-%s)"
1045 (aref h-month-names h-month) 1047 (aref h-month-names h-month)
1046 (if (= h-day 29) 1048 (if (= h-day 29)
1047 "tomorrow" 1049 "tomorrow"
1048 (aref calendar-day-name-array (- 29 h-day))) 1050 (aref calendar-day-name-array (- 29 h-day)))
1049 (aref calendar-day-name-array 1051 (aref calendar-day-name-array
1050 (% (- 30 h-day) 7)))))) 1052 (% (- 30 h-day) 7))))))
1051 (if (and (= h-day 29) (/= h-month 6)) 1053 (if (and (= h-day 29) (/= h-month 6))
1052 (cons mark 1054 (cons mark
1053 (format "Erev Rosh Hodesh %s" 1055 (format "Erev Rosh Hodesh %s"
1054 (aref h-month-names 1056 (aref h-month-names
1055 (if (= h-month 1057 (if (= h-month
1056 (hebrew-calendar-last-month-of-year 1058 (hebrew-calendar-last-month-of-year
1057 h-year)) 1059 h-year))
1058 0 h-month))))))))) 1060 0 h-month)))))))))
1059 1061
1060(defvar hebrew-calendar-parashiot-names 1062(defvar hebrew-calendar-parashiot-names
1061["Bereshith" "Noah" "Lech L'cha" "Vayera" "Hayei Sarah" "Toledoth" 1063 ["Bereshith" "Noah" "Lech L'cha" "Vayera" "Hayei Sarah" "Toledoth"
1062 "Vayetze" "Vayishlah" "Vayeshev" "Mikketz" "Vayiggash" "Vayhi" 1064 "Vayetze" "Vayishlah" "Vayeshev" "Mikketz" "Vayiggash" "Vayhi"
1063 "Shemoth" "Vaera" "Bo" "Beshallah" "Yithro" "Mishpatim" 1065 "Shemoth" "Vaera" "Bo" "Beshallah" "Yithro" "Mishpatim"
1064 "Terumah" "Tetzavveh" "Ki Tissa" "Vayakhel" "Pekudei" "Vayikra" 1066 "Terumah" "Tetzavveh" "Ki Tissa" "Vayakhel" "Pekudei" "Vayikra"
1065 "Tzav" "Shemini" "Tazria" "Metzora" "Aharei Moth" "Kedoshim" 1067 "Tzav" "Shemini" "Tazria" "Metzora" "Aharei Moth" "Kedoshim"
1066 "Emor" "Behar" "Behukkotai" "Bemidbar" "Naso" "Behaalot'cha" 1068 "Emor" "Behar" "Behukkotai" "Bemidbar" "Naso" "Behaalot'cha"
1067 "Shelah L'cha" "Korah" "Hukkath" "Balak" "Pinhas" "Mattoth" 1069 "Shelah L'cha" "Korah" "Hukkath" "Balak" "Pinhas" "Mattoth"
1068 "Masei" "Devarim" "Vaethanan" "Ekev" "Reeh" "Shofetim" 1070 "Masei" "Devarim" "Vaethanan" "Ekev" "Reeh" "Shofetim"
1069 "Ki Tetze" "Ki Tavo" "Nitzavim" "Vayelech" "Haazinu"] 1071 "Ki Tetze" "Ki Tavo" "Nitzavim" "Vayelech" "Haazinu"]
1070 "The names of the parashiot in the Torah.") 1072 "The names of the parashiot in the Torah.")
1071 1073
1072(defun hebrew-calendar-parasha-name (p) 1074(defun hebrew-calendar-parasha-name (p)
1073 "Name(s) corresponding to parasha P." 1075 "Name(s) corresponding to parasha P."
1074 (if (arrayp p) ; combined parasha 1076 (if (arrayp p) ; combined parasha
1075 (format "%s/%s" 1077 (format "%s/%s"
1076 (aref hebrew-calendar-parashiot-names (aref p 0)) 1078 (aref hebrew-calendar-parashiot-names (aref p 0))
1077 (aref hebrew-calendar-parashiot-names (aref p 1))) 1079 (aref hebrew-calendar-parashiot-names (aref p 1)))
@@ -1083,7 +1085,7 @@ use when highlighting the day in the calendar."
1083An optional parameter MARK specifies a face or single-character string to 1085An optional parameter MARK specifies a face or single-character string to
1084use when highlighting the day in the calendar." 1086use when highlighting the day in the calendar."
1085 (let ((d (calendar-absolute-from-gregorian date))) 1087 (let ((d (calendar-absolute-from-gregorian date)))
1086 (if (= (% d 7) 6) ; Saturday 1088 (if (= (% d 7) 6) ; Saturday
1087 (let* 1089 (let*
1088 ((h-year (extract-calendar-year 1090 ((h-year (extract-calendar-year
1089 (calendar-hebrew-from-absolute d))) 1091 (calendar-hebrew-from-absolute d)))
@@ -1104,81 +1106,81 @@ use when highlighting the day in the calendar."
1104 (symbol-value 1106 (symbol-value
1105 (intern (format "hebrew-calendar-year-%s-%s-%s" ; keviah 1107 (intern (format "hebrew-calendar-year-%s-%s-%s" ; keviah
1106 rosh-hashanah-day type passover-day)))) 1108 rosh-hashanah-day type passover-day))))
1107 (first-saturday ; of Hebrew year 1109 (first-saturday ; of Hebrew year
1108 (calendar-dayname-on-or-before 6 (+ 6 rosh-hashanah))) 1110 (calendar-dayname-on-or-before 6 (+ 6 rosh-hashanah)))
1109 (saturday ; which Saturday of the Hebrew year 1111 (saturday ; which Saturday of the Hebrew year
1110 (/ (- d first-saturday) 7)) 1112 (/ (- d first-saturday) 7))
1111 (parasha (aref year-format saturday))) 1113 (parasha (aref year-format saturday)))
1112 (if parasha 1114 (if parasha
1113 (cons mark 1115 (cons mark
1114 (format 1116 (format
1115 "Parashat %s" 1117 "Parashat %s"
1116 (if (listp parasha) ; Israel differs from diaspora 1118 (if (listp parasha) ; Israel differs from diaspora
1117 (if (car parasha) 1119 (if (car parasha)
1118 (format "%s (diaspora), %s (Israel)" 1120 (format "%s (diaspora), %s (Israel)"
1119 (hebrew-calendar-parasha-name 1121 (hebrew-calendar-parasha-name
1120 (car parasha)) 1122 (car parasha))
1121 (hebrew-calendar-parasha-name 1123 (hebrew-calendar-parasha-name
1122 (cdr parasha))) 1124 (cdr parasha)))
1123 (format "%s (Israel)" 1125 (format "%s (Israel)"
1124 (hebrew-calendar-parasha-name 1126 (hebrew-calendar-parasha-name
1125 (cdr parasha)))) 1127 (cdr parasha))))
1126 (hebrew-calendar-parasha-name parasha))))))))) 1128 (hebrew-calendar-parasha-name parasha)))))))))
1127 1129
1128;; The seven ordinary year types (keviot). 1130;; The seven ordinary year types (keviot).
1129(defconst hebrew-calendar-year-Saturday-incomplete-Sunday 1131(defconst hebrew-calendar-year-Saturday-incomplete-Sunday
1130 [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] 1132 [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
1131 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42] 1133 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
1132 43 44 45 46 47 48 49 50] 1134 43 44 45 46 47 48 49 50]
1133 "The structure of the parashiot. 1135 "The structure of the parashiot.
1134Hebrew year starts on Saturday, is `incomplete' (Heshvan and Kislev each have 1136Hebrew year starts on Saturday, is `incomplete' (Heshvan and Kislev each have
113529 days), and has Passover start on Sunday.") 113729 days), and has Passover start on Sunday.")
1136 1138
1137(defconst hebrew-calendar-year-Saturday-complete-Tuesday 1139(defconst hebrew-calendar-year-Saturday-complete-Tuesday
1138 [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] 1140 [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
1139 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42] 1141 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
1140 43 44 45 46 47 48 49 [50 51]] 1142 43 44 45 46 47 48 49 [50 51]]
1141 "The structure of the parashiot. 1143 "The structure of the parashiot.
1142Hebrew year that starts on Saturday, is `complete' (Heshvan and Kislev each 1144Hebrew year that starts on Saturday, is `complete' (Heshvan and Kislev each
1143have 30 days), and has Passover start on Tuesday.") 1145have 30 days), and has Passover start on Tuesday.")
1144 1146
1145(defconst hebrew-calendar-year-Monday-incomplete-Tuesday 1147(defconst hebrew-calendar-year-Monday-incomplete-Tuesday
1146 [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] 1148 [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
1147 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42] 1149 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
1148 43 44 45 46 47 48 49 [50 51]] 1150 43 44 45 46 47 48 49 [50 51]]
1149 "The structure of the parashiot. 1151 "The structure of the parashiot.
1150Hebrew year that starts on Monday, is `incomplete' (Heshvan and Kislev each 1152Hebrew year that starts on Monday, is `incomplete' (Heshvan and Kislev each
1151have 29 days), and has Passover start on Tuesday.") 1153have 29 days), and has Passover start on Tuesday.")
1152 1154
1153(defconst hebrew-calendar-year-Monday-complete-Thursday 1155(defconst hebrew-calendar-year-Monday-complete-Thursday
1154 [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] 1156 [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
1155 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 (nil . 34) (34 . 35) (35 . 36) 1157 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 (nil . 34) (34 . 35) (35 . 36)
1156 (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]] 1158 (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
1157 "The structure of the parashiot. 1159 "The structure of the parashiot.
1158Hebrew year that starts on Monday, is `complete' (Heshvan and Kislev each have 1160Hebrew year that starts on Monday, is `complete' (Heshvan and Kislev each have
115930 days), and has Passover start on Thursday.") 116130 days), and has Passover start on Thursday.")
1160 1162
1161(defconst hebrew-calendar-year-Tuesday-regular-Thursday 1163(defconst hebrew-calendar-year-Tuesday-regular-Thursday
1162 [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] 1164 [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
1163 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 (nil . 34) (34 . 35) (35 . 36) 1165 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 (nil . 34) (34 . 35) (35 . 36)
1164 (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]] 1166 (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
1165 "The structure of the parashiot. 1167 "The structure of the parashiot.
1166Hebrew year that starts on Tuesday, is `regular' (Heshvan has 29 days and 1168Hebrew year that starts on Tuesday, is `regular' (Heshvan has 29 days and
1167Kislev has 30 days), and has Passover start on Thursday.") 1169Kislev has 30 days), and has Passover start on Thursday.")
1168 1170
1169(defconst hebrew-calendar-year-Thursday-regular-Saturday 1171(defconst hebrew-calendar-year-Thursday-regular-Saturday
1170 [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] 23 1172 [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] 23
1171 24 nil (nil . 25) (25 . [26 27]) ([26 27] . [28 29]) ([28 29] . 30) 1173 24 nil (nil . 25) (25 . [26 27]) ([26 27] . [28 29]) ([28 29] . 30)
1172 (30 . 31) ([31 32] . 32) 33 34 35 36 37 38 39 40 [41 42] 43 44 45 46 47 48 1174 (30 . 31) ([31 32] . 32) 33 34 35 36 37 38 39 40 [41 42] 43 44 45 46 47 48
1173 49 50] 1175 49 50]
1174 "The structure of the parashiot. 1176 "The structure of the parashiot.
1175Hebrew year that starts on Thursday, is `regular' (Heshvan has 29 days and 1177Hebrew year that starts on Thursday, is `regular' (Heshvan has 29 days and
1176Kislev has 30 days), and has Passover start on Saturday.") 1178Kislev has 30 days), and has Passover start on Saturday.")
1177 1179
1178(defconst hebrew-calendar-year-Thursday-complete-Sunday 1180(defconst hebrew-calendar-year-Thursday-complete-Sunday
1179 [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 1181 [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
1180 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42] 1182 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
1181 43 44 45 46 47 48 49 50] 1183 43 44 45 46 47 48 49 50]
1182 "The structure of the parashiot. 1184 "The structure of the parashiot.
1183Hebrew year that starts on Thursday, is `complete' (Heshvan and Kislev each 1185Hebrew year that starts on Thursday, is `complete' (Heshvan and Kislev each
1184have 30 days), and has Passover start on Sunday.") 1186have 30 days), and has Passover start on Sunday.")
@@ -1186,58 +1188,58 @@ have 30 days), and has Passover start on Sunday.")
1186;; The seven leap year types (keviot). 1188;; The seven leap year types (keviot).
1187(defconst hebrew-calendar-year-Saturday-incomplete-Tuesday 1189(defconst hebrew-calendar-year-Saturday-incomplete-Tuesday
1188 [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 1190 [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
1189 23 24 25 26 27 nil 28 29 30 31 32 33 34 35 36 37 38 39 40 [41 42] 1191 23 24 25 26 27 nil 28 29 30 31 32 33 34 35 36 37 38 39 40 [41 42]
1190 43 44 45 46 47 48 49 [50 51]] 1192 43 44 45 46 47 48 49 [50 51]]
1191 "The structure of the parashiot. 1193 "The structure of the parashiot.
1192Hebrew year that starts on Saturday, is `incomplete' (Heshvan and Kislev each 1194Hebrew year that starts on Saturday, is `incomplete' (Heshvan and Kislev each
1193have 29 days), and has Passover start on Tuesday.") 1195have 29 days), and has Passover start on Tuesday.")
1194 1196
1195(defconst hebrew-calendar-year-Saturday-complete-Thursday 1197(defconst hebrew-calendar-year-Saturday-complete-Thursday
1196 [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 1198 [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
1197 23 24 25 26 27 nil 28 29 30 31 32 33 (nil . 34) (34 . 35) (35 . 36) 1199 23 24 25 26 27 nil 28 29 30 31 32 33 (nil . 34) (34 . 35) (35 . 36)
1198 (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]] 1200 (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
1199 "The structure of the parashiot. 1201 "The structure of the parashiot.
1200Hebrew year that starts on Saturday, is `complete' (Heshvan and Kislev each 1202Hebrew year that starts on Saturday, is `complete' (Heshvan and Kislev each
1201have 30 days), and has Passover start on Thursday.") 1203have 30 days), and has Passover start on Thursday.")
1202 1204
1203(defconst hebrew-calendar-year-Monday-incomplete-Thursday 1205(defconst hebrew-calendar-year-Monday-incomplete-Thursday
1204 [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 1206 [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
1205 23 24 25 26 27 nil 28 29 30 31 32 33 (nil . 34) (34 . 35) (35 . 36) 1207 23 24 25 26 27 nil 28 29 30 31 32 33 (nil . 34) (34 . 35) (35 . 36)
1206 (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]] 1208 (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
1207 "The structure of the parashiot. 1209 "The structure of the parashiot.
1208Hebrew year that starts on Monday, is `incomplete' (Heshvan and Kislev each 1210Hebrew year that starts on Monday, is `incomplete' (Heshvan and Kislev each
1209have 29 days), and has Passover start on Thursday.") 1211have 29 days), and has Passover start on Thursday.")
1210 1212
1211(defconst hebrew-calendar-year-Monday-complete-Saturday 1213(defconst hebrew-calendar-year-Monday-complete-Saturday
1212 [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 1214 [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
1213 23 24 25 26 27 nil (nil . 28) (28 . 29) (29 . 30) (30 . 31) (31 . 32) 1215 23 24 25 26 27 nil (nil . 28) (28 . 29) (29 . 30) (30 . 31) (31 . 32)
1214 (32 . 33) (33 . 34) (34 . 35) (35 . 36) (36 . 37) (37 . 38) (38 . 39) 1216 (32 . 33) (33 . 34) (34 . 35) (35 . 36) (36 . 37) (37 . 38) (38 . 39)
1215 (39 . 40) (40 . 41) ([41 42] . 42) 43 44 45 46 47 48 49 50] 1217 (39 . 40) (40 . 41) ([41 42] . 42) 43 44 45 46 47 48 49 50]
1216 "The structure of the parashiot. 1218 "The structure of the parashiot.
1217Hebrew year that starts on Monday, is `complete' (Heshvan and Kislev each have 1219Hebrew year that starts on Monday, is `complete' (Heshvan and Kislev each have
121830 days), and has Passover start on Saturday.") 122030 days), and has Passover start on Saturday.")
1219 1221
1220(defconst hebrew-calendar-year-Tuesday-regular-Saturday 1222(defconst hebrew-calendar-year-Tuesday-regular-Saturday
1221 [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 1223 [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
1222 23 24 25 26 27 nil (nil . 28) (28 . 29) (29 . 30) (30 . 31) (31 . 32) 1224 23 24 25 26 27 nil (nil . 28) (28 . 29) (29 . 30) (30 . 31) (31 . 32)
1223 (32 . 33) (33 . 34) (34 . 35) (35 . 36) (36 . 37) (37 . 38) (38 . 39) 1225 (32 . 33) (33 . 34) (34 . 35) (35 . 36) (36 . 37) (37 . 38) (38 . 39)
1224 (39 . 40) (40 . 41) ([41 42] . 42) 43 44 45 46 47 48 49 50] 1226 (39 . 40) (40 . 41) ([41 42] . 42) 43 44 45 46 47 48 49 50]
1225 "The structure of the parashiot. 1227 "The structure of the parashiot.
1226Hebrew year that starts on Tuesday, is `regular' (Heshvan has 29 days and 1228Hebrew year that starts on Tuesday, is `regular' (Heshvan has 29 days and
1227Kislev has 30 days), and has Passover start on Saturday.") 1229Kislev has 30 days), and has Passover start on Saturday.")
1228 1230
1229(defconst hebrew-calendar-year-Thursday-incomplete-Sunday 1231(defconst hebrew-calendar-year-Thursday-incomplete-Sunday
1230 [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 1232 [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
1231 23 24 25 26 27 28 nil 29 30 31 32 33 34 35 36 37 38 39 40 41 42 1233 23 24 25 26 27 28 nil 29 30 31 32 33 34 35 36 37 38 39 40 41 42
1232 43 44 45 46 47 48 49 50] 1234 43 44 45 46 47 48 49 50]
1233 "The structure of the parashiot. 1235 "The structure of the parashiot.
1234Hebrew year that starts on Thursday, is `incomplete' (Heshvan and Kislev both 1236Hebrew year that starts on Thursday, is `incomplete' (Heshvan and Kislev both
1235have 29 days), and has Passover start on Sunday.") 1237have 29 days), and has Passover start on Sunday.")
1236 1238
1237(defconst hebrew-calendar-year-Thursday-complete-Tuesday 1239(defconst hebrew-calendar-year-Thursday-complete-Tuesday
1238 [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 1240 [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
1239 23 24 25 26 27 28 nil 29 30 31 32 33 34 35 36 37 38 39 40 41 42 1241 23 24 25 26 27 28 nil 29 30 31 32 33 34 35 36 37 38 39 40 41 42
1240 43 44 45 46 47 48 49 [50 51]] 1242 43 44 45 46 47 48 49 [50 51]]
1241 "The structure of the parashiot. 1243 "The structure of the parashiot.
1242Hebrew year that starts on Thursday, is `complete' (Heshvan and Kislev both 1244Hebrew year that starts on Thursday, is `complete' (Heshvan and Kislev both
1243have 30 days), and has Passover start on Tuesday.") 1245have 30 days), and has Passover start on Tuesday.")
diff --git a/lisp/calendar/cal-mayan.el b/lisp/calendar/cal-mayan.el
index 6cea9545898..c52b6d86a2f 100644
--- a/lisp/calendar/cal-mayan.el
+++ b/lisp/calendar/cal-mayan.el
@@ -4,7 +4,7 @@
4;; 2006, 2007, 2008 Free Software Foundation, Inc. 4;; 2006, 2007, 2008 Free Software Foundation, Inc.
5 5
6;; Author: Stewart M. Clamen <clamen@cs.cmu.edu> 6;; Author: Stewart M. Clamen <clamen@cs.cmu.edu>
7;; Edward M. Reingold <reingold@cs.uiuc.edu> 7;; Edward M. Reingold <reingold@cs.uiuc.edu>
8;; Maintainer: Glenn Morris <rgm@gnu.org> 8;; Maintainer: Glenn Morris <rgm@gnu.org>
9;; Keywords: calendar 9;; Keywords: calendar
10;; Human-Keywords: Mayan calendar, Maya, calendar, diary 10;; Human-Keywords: Mayan calendar, Maya, calendar, diary
@@ -100,12 +100,12 @@ but some use 1137140. Using 1232041 gives you Spinden's correlation; using
100 (condition-case condition 100 (condition-case condition
101 (progn 101 (progn
102 (while (< cc c) 102 (while (< cc c)
103 (let* ((start (string-match "[0-9]+" str cc)) 103 (let* ((start (string-match "[0-9]+" str cc))
104 (end (match-end 0)) 104 (end (match-end 0))
105 datum) 105 datum)
106 (setq datum (read (substring str start end))) 106 (setq datum (read (substring str start end)))
107 (setq rlc (cons datum rlc)) 107 (setq rlc (cons datum rlc))
108 (setq cc end))) 108 (setq cc end)))
109 (if (not (= (length rlc) 5)) (signal 'invalid-read-syntax nil))) 109 (if (not (= (length rlc) 5)) (signal 'invalid-read-syntax nil)))
110 (invalid-read-syntax nil)) 110 (invalid-read-syntax nil))
111 (reverse rlc))) 111 (reverse rlc)))
@@ -125,16 +125,16 @@ but some use 1137140. Using 1232041 gives you Spinden's correlation; using
125(defun calendar-mayan-haab-difference (date1 date2) 125(defun calendar-mayan-haab-difference (date1 date2)
126 "Number of days from Mayan haab DATE1 to next occurrence of haab date DATE2." 126 "Number of days from Mayan haab DATE1 to next occurrence of haab date DATE2."
127 (mod (+ (* 20 (- (cdr date2) (cdr date1))) 127 (mod (+ (* 20 (- (cdr date2) (cdr date1)))
128 (- (car date2) (car date1))) 128 (- (car date2) (car date1)))
129 365)) 129 365))
130 130
131(defun calendar-mayan-haab-on-or-before (haab-date date) 131(defun calendar-mayan-haab-on-or-before (haab-date date)
132 "Absolute date of latest HAAB-DATE on or before absolute DATE." 132 "Absolute date of latest HAAB-DATE on or before absolute DATE."
133 (- date 133 (- date
134 (% (- date 134 (% (- date
135 (calendar-mayan-haab-difference 135 (calendar-mayan-haab-difference
136 (calendar-mayan-haab-from-absolute 0) haab-date)) 136 (calendar-mayan-haab-from-absolute 0) haab-date))
137 365))) 137 365)))
138 138
139;;;###cal-autoload 139;;;###cal-autoload
140(defun calendar-next-haab-date (haab-date &optional noecho) 140(defun calendar-next-haab-date (haab-date &optional noecho)
@@ -165,12 +165,12 @@ Echo Mayan date if NOECHO is t."
165 "Convert Mayan HAAB date (a pair) into its traditional written form." 165 "Convert Mayan HAAB date (a pair) into its traditional written form."
166 (let ((month (cdr haab)) 166 (let ((month (cdr haab))
167 (day (car haab))) 167 (day (car haab)))
168 ;; 19th month consists of 5 special days 168 ;; 19th month consists of 5 special days
169 (if (= month 19) 169 (if (= month 19)
170 (format "%d Uayeb" day) 170 (format "%d Uayeb" day)
171 (format "%d %s" 171 (format "%d %s"
172 day 172 day
173 (aref calendar-mayan-haab-month-name-array (1- month)))))) 173 (aref calendar-mayan-haab-month-name-array (1- month))))))
174 174
175(defun calendar-mayan-tzolkin-from-absolute (date) 175(defun calendar-mayan-tzolkin-from-absolute (date)
176 "Convert absolute DATE into a Mayan tzolkin date (a pair)." 176 "Convert absolute DATE into a Mayan tzolkin date (a pair)."
@@ -188,17 +188,17 @@ Echo Mayan date if NOECHO is t."
188 (let ((number-difference (- (car date2) (car date1))) 188 (let ((number-difference (- (car date2) (car date1)))
189 (name-difference (- (cdr date2) (cdr date1)))) 189 (name-difference (- (cdr date2) (cdr date1))))
190 (mod (+ number-difference 190 (mod (+ number-difference
191 (* 13 (mod (* 3 (- number-difference name-difference)) 191 (* 13 (mod (* 3 (- number-difference name-difference))
192 20))) 192 20)))
193 260))) 193 260)))
194 194
195(defun calendar-mayan-tzolkin-on-or-before (tzolkin-date date) 195(defun calendar-mayan-tzolkin-on-or-before (tzolkin-date date)
196 "Absolute date of latest TZOLKIN-DATE on or before absolute DATE." 196 "Absolute date of latest TZOLKIN-DATE on or before absolute DATE."
197 (- date 197 (- date
198 (% (- date (calendar-mayan-tzolkin-difference 198 (% (- date (calendar-mayan-tzolkin-difference
199 (calendar-mayan-tzolkin-from-absolute 0) 199 (calendar-mayan-tzolkin-from-absolute 0)
200 tzolkin-date)) 200 tzolkin-date))
201 260))) 201 260)))
202 202
203;;;###cal-autoload 203;;;###cal-autoload
204(defun calendar-next-tzolkin-date (tzolkin-date &optional noecho) 204(defun calendar-next-tzolkin-date (tzolkin-date &optional noecho)
@@ -247,8 +247,8 @@ Returns nil if such a tzolkin-haab combination is impossible."
247 (if (= (% difference 5) 0) 247 (if (= (% difference 5) 0)
248 (- date 248 (- date
249 (mod (- date 249 (mod (- date
250 (+ haab-difference (* 365 difference))) 250 (+ haab-difference (* 365 difference)))
251 18980)) 251 18980))
252 nil))) 252 nil)))
253 253
254(defun calendar-read-mayan-haab-date () 254(defun calendar-read-mayan-haab-date ()
@@ -276,9 +276,9 @@ Returns nil if such a tzolkin-haab combination is impossible."
276 (tzolkin-name-list (append calendar-mayan-tzolkin-names-array nil)) 276 (tzolkin-name-list (append calendar-mayan-tzolkin-names-array nil))
277 (tzolkin-name (cdr 277 (tzolkin-name (cdr
278 (assoc-string 278 (assoc-string
279 (completing-read "Tzolkin uinal: " 279 (completing-read "Tzolkin uinal: "
280 (mapcar 'list tzolkin-name-list) 280 (mapcar 'list tzolkin-name-list)
281 nil t) 281 nil t)
282 (calendar-make-alist tzolkin-name-list 1) t)))) 282 (calendar-make-alist tzolkin-name-list 1) t))))
283 (cons tzolkin-count tzolkin-name))) 283 (cons tzolkin-count tzolkin-name)))
284 284
@@ -321,12 +321,12 @@ Echo Mayan date if NOECHO is t."
321(defun calendar-absolute-from-mayan-long-count (c) 321(defun calendar-absolute-from-mayan-long-count (c)
322 "Compute the absolute date corresponding to the Mayan Long Count C. 322 "Compute the absolute date corresponding to the Mayan Long Count C.
323Long count is a list (baktun katun tun uinal kin)" 323Long count is a list (baktun katun tun uinal kin)"
324 (+ (* (nth 0 c) 144000) ; baktun 324 (+ (* (nth 0 c) 144000) ; baktun
325 (* (nth 1 c) 7200) ; katun 325 (* (nth 1 c) 7200) ; katun
326 (* (nth 2 c) 360) ; tun 326 (* (nth 2 c) 360) ; tun
327 (* (nth 3 c) 20) ; uinal 327 (* (nth 3 c) 20) ; uinal
328 (nth 4 c) ; kin (days) 328 (nth 4 c) ; kin (days)
329 (- ; days before absolute date 0 329 (- ; days before absolute date 0
330 calendar-mayan-days-before-absolute-zero))) 330 calendar-mayan-days-before-absolute-zero)))
331 331
332;;;###cal-autoload 332;;;###cal-autoload
@@ -338,10 +338,10 @@ Defaults to today's date if DATE is not given."
338 (tzolkin (calendar-mayan-tzolkin-from-absolute d)) 338 (tzolkin (calendar-mayan-tzolkin-from-absolute d))
339 (haab (calendar-mayan-haab-from-absolute d)) 339 (haab (calendar-mayan-haab-from-absolute d))
340 (long-count (calendar-mayan-long-count-from-absolute d))) 340 (long-count (calendar-mayan-long-count-from-absolute d)))
341 (format "Long count = %s; tzolkin = %s; haab = %s" 341 (format "Long count = %s; tzolkin = %s; haab = %s"
342 (calendar-mayan-long-count-to-string long-count) 342 (calendar-mayan-long-count-to-string long-count)
343 (calendar-mayan-tzolkin-to-string tzolkin) 343 (calendar-mayan-tzolkin-to-string tzolkin)
344 (calendar-mayan-haab-to-string haab)))) 344 (calendar-mayan-haab-to-string haab))))
345 345
346;;;###cal-autoload 346;;;###cal-autoload
347(defun calendar-print-mayan-date () 347(defun calendar-print-mayan-date ()
@@ -361,8 +361,8 @@ Defaults to today's date if DATE is not given."
361 (read-string "Mayan long count (baktun.katun.tun.uinal.kin): " 361 (read-string "Mayan long count (baktun.katun.tun.uinal.kin): "
362 (calendar-mayan-long-count-to-string 362 (calendar-mayan-long-count-to-string
363 (calendar-mayan-long-count-from-absolute 363 (calendar-mayan-long-count-from-absolute
364 (calendar-absolute-from-gregorian 364 (calendar-absolute-from-gregorian
365 (calendar-current-date)))))))) 365 (calendar-current-date))))))))
366 (if (calendar-mayan-long-count-common-era datum) 366 (if (calendar-mayan-long-count-common-era datum)
367 (setq lc datum)))) 367 (setq lc datum))))
368 (list lc))) 368 (list lc)))
diff --git a/lisp/calendar/cal-menu.el b/lisp/calendar/cal-menu.el
index f458ebec2f7..fffe0b3d462 100644
--- a/lisp/calendar/cal-menu.el
+++ b/lisp/calendar/cal-menu.el
@@ -4,7 +4,7 @@
4;; Free Software Foundation, Inc. 4;; Free Software Foundation, Inc.
5 5
6;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> 6;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
7;; Lara Rios <lrios@coewl.cen.uiuc.edu> 7;; Lara Rios <lrios@coewl.cen.uiuc.edu>
8;; Maintainer: Glenn Morris <rgm@gnu.org> 8;; Maintainer: Glenn Morris <rgm@gnu.org>
9;; Keywords: calendar 9;; Keywords: calendar
10;; Human-Keywords: calendar, popup menus, menu bar 10;; Human-Keywords: calendar, popup menus, menu bar
diff --git a/lisp/calendar/cal-move.el b/lisp/calendar/cal-move.el
index e28542b7c21..92e569e0a59 100644
--- a/lisp/calendar/cal-move.el
+++ b/lisp/calendar/cal-move.el
@@ -318,21 +318,21 @@ Moves forward if ARG is negative."
318(defun calendar-cursor-to-visible-date (date) 318(defun calendar-cursor-to-visible-date (date)
319 "Move the cursor to DATE that is on the screen." 319 "Move the cursor to DATE that is on the screen."
320 (let* ((month (extract-calendar-month date)) 320 (let* ((month (extract-calendar-month date))
321 (day (extract-calendar-day date)) 321 (day (extract-calendar-day date))
322 (year (extract-calendar-year date)) 322 (year (extract-calendar-year date))
323 (first-of-month-weekday (calendar-day-of-week (list month 1 year)))) 323 (first-of-month-weekday (calendar-day-of-week (list month 1 year))))
324 (goto-line (+ 3 324 (goto-line (+ 3
325 (/ (+ day -1 325 (/ (+ day -1
326 (mod 326 (mod
327 (- (calendar-day-of-week (list month 1 year)) 327 (- (calendar-day-of-week (list month 1 year))
328 calendar-week-start-day) 328 calendar-week-start-day)
329 7)) 329 7))
330 7))) 330 7)))
331 (move-to-column (+ 6 331 (move-to-column (+ 6
332 (* 25 332 (* 25
333 (1+ (calendar-interval 333 (1+ (calendar-interval
334 displayed-month displayed-year month year))) 334 displayed-month displayed-year month year)))
335 (* 3 (mod 335 (* 3 (mod
336 (- (calendar-day-of-week date) 336 (- (calendar-day-of-week date)
337 calendar-week-start-day) 337 calendar-week-start-day)
338 7)))))) 338 7))))))
diff --git a/lisp/calendar/cal-tex.el b/lisp/calendar/cal-tex.el
index 9906fa7c5ec..b8d0dcb1634 100644
--- a/lisp/calendar/cal-tex.el
+++ b/lisp/calendar/cal-tex.el
@@ -1280,7 +1280,7 @@ are non-nil. Pages are ruled if `cal-tex-rules' is non-nil."
1280 (cal-tex-list-diary-entries 1280 (cal-tex-list-diary-entries
1281 ;; FIXME d1? 1281 ;; FIXME d1?
1282 (calendar-absolute-from-gregorian (list month 1 year)) 1282 (calendar-absolute-from-gregorian (list month 1 year))
1283 d2)))) 1283 d2))))
1284 (cal-tex-preamble "twoside") 1284 (cal-tex-preamble "twoside")
1285 (cal-tex-cmd "\\textwidth 3.25in") 1285 (cal-tex-cmd "\\textwidth 3.25in")
1286 (cal-tex-cmd "\\textheight 6.5in") 1286 (cal-tex-cmd "\\textheight 6.5in")
diff --git a/lisp/calendar/cal-x.el b/lisp/calendar/cal-x.el
index 12612ac9ac7..2dfaa7c0a0b 100644
--- a/lisp/calendar/cal-x.el
+++ b/lisp/calendar/cal-x.el
@@ -4,7 +4,7 @@
4;; 2008 Free Software Foundation, Inc. 4;; 2008 Free Software Foundation, Inc.
5 5
6;; Author: Michael Kifer <kifer@cs.sunysb.edu> 6;; Author: Michael Kifer <kifer@cs.sunysb.edu>
7;; Edward M. Reingold <reingold@cs.uiuc.edu> 7;; Edward M. Reingold <reingold@cs.uiuc.edu>
8;; Maintainer: Glenn Morris <rgm@gnu.org> 8;; Maintainer: Glenn Morris <rgm@gnu.org>
9;; Keywords: calendar 9;; Keywords: calendar
10;; Human-Keywords: calendar, dedicated frames, X Window System 10;; Human-Keywords: calendar, dedicated frames, X Window System
@@ -91,11 +91,11 @@ passed to `calendar-basic-setup'."
91 (save-window-excursion 91 (save-window-excursion
92 (save-excursion 92 (save-excursion
93 (setq calendar-frame 93 (setq calendar-frame
94 (make-frame calendar-and-diary-frame-parameters)) 94 (make-frame calendar-and-diary-frame-parameters))
95 (run-hooks 'calendar-after-frame-setup-hooks) 95 (run-hooks 'calendar-after-frame-setup-hooks)
96 (select-frame calendar-frame) 96 (select-frame calendar-frame)
97 (if (eq 'icon (cdr (assoc 'visibility 97 (if (eq 'icon (cdr (assoc 'visibility
98 (frame-parameters calendar-frame)))) 98 (frame-parameters calendar-frame))))
99 (iconify-or-deiconify-frame)) 99 (iconify-or-deiconify-frame))
100 (calendar-basic-setup arg) 100 (calendar-basic-setup arg)
101 (set-window-dedicated-p (selected-window) t) 101 (set-window-dedicated-p (selected-window) t)
@@ -122,11 +122,11 @@ ARG is passed to `calendar-basic-setup'."
122 (save-window-excursion 122 (save-window-excursion
123 (save-excursion 123 (save-excursion
124 (setq calendar-frame 124 (setq calendar-frame
125 (make-frame calendar-frame-parameters)) 125 (make-frame calendar-frame-parameters))
126 (run-hooks 'calendar-after-frame-setup-hooks) 126 (run-hooks 'calendar-after-frame-setup-hooks)
127 (select-frame calendar-frame) 127 (select-frame calendar-frame)
128 (if (eq 'icon (cdr (assoc 'visibility 128 (if (eq 'icon (cdr (assoc 'visibility
129 (frame-parameters calendar-frame)))) 129 (frame-parameters calendar-frame))))
130 (iconify-or-deiconify-frame)) 130 (iconify-or-deiconify-frame))
131 (calendar-basic-setup arg) 131 (calendar-basic-setup arg)
132 (set-window-dedicated-p (selected-window) t)))))) 132 (set-window-dedicated-p (selected-window) t))))))
diff --git a/lisp/calendar/calendar.el b/lisp/calendar/calendar.el
index 0aa97e4fa78..bb0ed3d045c 100644
--- a/lisp/calendar/calendar.el
+++ b/lisp/calendar/calendar.el
@@ -494,14 +494,14 @@ calendar package is already loaded). Rather, use either
494 "List of pseudo-patterns describing the American patterns of date used. 494 "List of pseudo-patterns describing the American patterns of date used.
495See the documentation of `diary-date-forms' for an explanation." 495See the documentation of `diary-date-forms' for an explanation."
496 :type '(repeat (choice (cons :tag "Backup" 496 :type '(repeat (choice (cons :tag "Backup"
497 :value (backup . nil) 497 :value (backup . nil)
498 (const backup) 498 (const backup)
499 (repeat (list :inline t :format "%v" 499 (repeat (list :inline t :format "%v"
500 (symbol :tag "Keyword") 500 (symbol :tag "Keyword")
501 (choice symbol regexp)))) 501 (choice symbol regexp))))
502 (repeat (list :inline t :format "%v" 502 (repeat (list :inline t :format "%v"
503 (symbol :tag "Keyword") 503 (symbol :tag "Keyword")
504 (choice symbol regexp))))) 504 (choice symbol regexp)))))
505 :group 'diary) 505 :group 'diary)
506 506
507(defcustom european-date-diary-pattern 507(defcustom european-date-diary-pattern
@@ -513,14 +513,14 @@ See the documentation of `diary-date-forms' for an explanation."
513 "List of pseudo-patterns describing the European patterns of date used. 513 "List of pseudo-patterns describing the European patterns of date used.
514See the documentation of `diary-date-forms' for an explanation." 514See the documentation of `diary-date-forms' for an explanation."
515 :type '(repeat (choice (cons :tag "Backup" 515 :type '(repeat (choice (cons :tag "Backup"
516 :value (backup . nil) 516 :value (backup . nil)
517 (const backup) 517 (const backup)
518 (repeat (list :inline t :format "%v" 518 (repeat (list :inline t :format "%v"
519 (symbol :tag "Keyword") 519 (symbol :tag "Keyword")
520 (choice symbol regexp)))) 520 (choice symbol regexp))))
521 (repeat (list :inline t :format "%v" 521 (repeat (list :inline t :format "%v"
522 (symbol :tag "Keyword") 522 (symbol :tag "Keyword")
523 (choice symbol regexp))))) 523 (choice symbol regexp)))))
524 :group 'diary) 524 :group 'diary)
525 525
526(defvar diary-font-lock-keywords) 526(defvar diary-font-lock-keywords)
@@ -554,14 +554,14 @@ directive causes the date recognizer to back up to the beginning of the
554current word of the diary entry, so in no case can the pattern match more than 554current word of the diary entry, so in no case can the pattern match more than
555a portion of the first word of the diary entry." 555a portion of the first word of the diary entry."
556 :type '(repeat (choice (cons :tag "Backup" 556 :type '(repeat (choice (cons :tag "Backup"
557 :value (backup . nil) 557 :value (backup . nil)
558 (const backup) 558 (const backup)
559 (repeat (list :inline t :format "%v" 559 (repeat (list :inline t :format "%v"
560 (symbol :tag "Keyword") 560 (symbol :tag "Keyword")
561 (choice symbol regexp)))) 561 (choice symbol regexp))))
562 (repeat (list :inline t :format "%v" 562 (repeat (list :inline t :format "%v"
563 (symbol :tag "Keyword") 563 (symbol :tag "Keyword")
564 (choice symbol regexp))))) 564 (choice symbol regexp)))))
565 :initialize 'custom-initialize-default 565 :initialize 'custom-initialize-default
566 :set (lambda (symbol value) 566 :set (lambda (symbol value)
567 (unless (equal value (eval symbol)) 567 (unless (equal value (eval symbol))
@@ -706,7 +706,7 @@ See the documentation for `calendar-holidays' for details."
706;;;###autoload 706;;;###autoload
707(defcustom oriental-holidays 707(defcustom oriental-holidays
708 '((if (fboundp 'atan) 708 '((if (fboundp 'atan)
709 (holiday-chinese-new-year))) 709 (holiday-chinese-new-year)))
710 "Oriental holidays. 710 "Oriental holidays.
711See the documentation for `calendar-holidays' for details." 711See the documentation for `calendar-holidays' for details."
712 :type 'sexp 712 :type 'sexp
@@ -965,24 +965,24 @@ calendar."
965 (format "Baha'i New Year (Naw-Ruz) %d" (- displayed-year (1- 1844)))) 965 (format "Baha'i New Year (Naw-Ruz) %d" (- displayed-year (1- 1844))))
966 (holiday-fixed 4 21 "First Day of Ridvan") 966 (holiday-fixed 4 21 "First Day of Ridvan")
967 (if all-bahai-calendar-holidays 967 (if all-bahai-calendar-holidays
968 (holiday-fixed 4 22 "Second Day of Ridvan")) 968 (holiday-fixed 4 22 "Second Day of Ridvan"))
969 (if all-bahai-calendar-holidays 969 (if all-bahai-calendar-holidays
970 (holiday-fixed 4 23 "Third Day of Ridvan")) 970 (holiday-fixed 4 23 "Third Day of Ridvan"))
971 (if all-bahai-calendar-holidays 971 (if all-bahai-calendar-holidays
972 (holiday-fixed 4 24 "Fourth Day of Ridvan")) 972 (holiday-fixed 4 24 "Fourth Day of Ridvan"))
973 (if all-bahai-calendar-holidays 973 (if all-bahai-calendar-holidays
974 (holiday-fixed 4 25 "Fifth Day of Ridvan")) 974 (holiday-fixed 4 25 "Fifth Day of Ridvan"))
975 (if all-bahai-calendar-holidays 975 (if all-bahai-calendar-holidays
976 (holiday-fixed 4 26 "Sixth Day of Ridvan")) 976 (holiday-fixed 4 26 "Sixth Day of Ridvan"))
977 (if all-bahai-calendar-holidays 977 (if all-bahai-calendar-holidays
978 (holiday-fixed 4 27 "Seventh Day of Ridvan")) 978 (holiday-fixed 4 27 "Seventh Day of Ridvan"))
979 (if all-bahai-calendar-holidays 979 (if all-bahai-calendar-holidays
980 (holiday-fixed 4 28 "Eighth Day of Ridvan")) 980 (holiday-fixed 4 28 "Eighth Day of Ridvan"))
981 (holiday-fixed 4 29 "Ninth Day of Ridvan") 981 (holiday-fixed 4 29 "Ninth Day of Ridvan")
982 (if all-bahai-calendar-holidays 982 (if all-bahai-calendar-holidays
983 (holiday-fixed 4 30 "Tenth Day of Ridvan")) 983 (holiday-fixed 4 30 "Tenth Day of Ridvan"))
984 (if all-bahai-calendar-holidays 984 (if all-bahai-calendar-holidays
985 (holiday-fixed 5 1 "Eleventh Day of Ridvan")) 985 (holiday-fixed 5 1 "Eleventh Day of Ridvan"))
986 (holiday-fixed 5 2 "Twelfth Day of Ridvan") 986 (holiday-fixed 5 2 "Twelfth Day of Ridvan")
987 (holiday-fixed 5 23 "Declaration of the Bab") 987 (holiday-fixed 5 23 "Declaration of the Bab")
988 (holiday-fixed 5 29 "Ascension of Baha'u'llah") 988 (holiday-fixed 5 29 "Ascension of Baha'u'llah")
@@ -990,9 +990,9 @@ calendar."
990 (holiday-fixed 10 20 "Birth of the Bab") 990 (holiday-fixed 10 20 "Birth of the Bab")
991 (holiday-fixed 11 12 "Birth of Baha'u'llah") 991 (holiday-fixed 11 12 "Birth of Baha'u'llah")
992 (if all-bahai-calendar-holidays 992 (if all-bahai-calendar-holidays
993 (holiday-fixed 11 26 "Day of the Covenant")) 993 (holiday-fixed 11 26 "Day of the Covenant"))
994 (if all-bahai-calendar-holidays 994 (if all-bahai-calendar-holidays
995 (holiday-fixed 11 28 "Ascension of `Abdu'l-Baha"))) 995 (holiday-fixed 11 28 "Ascension of `Abdu'l-Baha")))
996 "Baha'i holidays. 996 "Baha'i holidays.
997See the documentation for `calendar-holidays' for details." 997See the documentation for `calendar-holidays' for details."
998 :type 'sexp 998 :type 'sexp
@@ -1003,7 +1003,7 @@ See the documentation for `calendar-holidays' for details."
1003;;;###autoload 1003;;;###autoload
1004(defcustom solar-holidays 1004(defcustom solar-holidays
1005 '((if (fboundp 'atan) 1005 '((if (fboundp 'atan)
1006 (solar-equinoxes-solstices)) 1006 (solar-equinoxes-solstices))
1007 (if (require 'cal-dst) 1007 (if (require 'cal-dst)
1008 (funcall 1008 (funcall
1009 'holiday-sexp 1009 'holiday-sexp
@@ -1431,8 +1431,8 @@ Or, for optional MON, YR."
1431 (fit-window-to-buffer nil nil calendar-minimum-window-height)) 1431 (fit-window-to-buffer nil nil calendar-minimum-window-height))
1432 (sit-for 0)) 1432 (sit-for 0))
1433 (if (and (boundp 'font-lock-mode) 1433 (if (and (boundp 'font-lock-mode)
1434 font-lock-mode) 1434 font-lock-mode)
1435 (font-lock-fontify-buffer)) 1435 (font-lock-fontify-buffer))
1436 (and mark-holidays-in-calendar 1436 (and mark-holidays-in-calendar
1437;;; (calendar-date-is-valid-p today) ; useful for BC dates 1437;;; (calendar-date-is-valid-p today) ; useful for BC dates
1438 (calendar-mark-holidays) 1438 (calendar-mark-holidays)
@@ -1470,7 +1470,7 @@ line."
1470 (- (calendar-day-of-week (list month 1 year)) 1470 (- (calendar-day-of-week (list month 1 year))
1471 calendar-week-start-day) 1471 calendar-week-start-day)
1472 7)) 1472 7))
1473 (last (calendar-last-day-of-month month year))) 1473 (last (calendar-last-day-of-month month year)))
1474 (goto-char (point-min)) 1474 (goto-char (point-min))
1475 (calendar-insert-indented 1475 (calendar-insert-indented
1476 (calendar-string-spread 1476 (calendar-string-spread
@@ -1496,7 +1496,7 @@ line."
1496 (add-text-properties 1496 (add-text-properties
1497 (- (point) 3) (1- (point)) 1497 (- (point) 3) (1- (point))
1498 '(mouse-face highlight 1498 '(mouse-face highlight
1499 help-echo "mouse-2: menu of operations for this date")) 1499 help-echo "mouse-2: menu of operations for this date"))
1500 (and (zerop (mod (+ i blank-days) 7)) 1500 (and (zerop (mod (+ i blank-days) 7))
1501 (/= i last) 1501 (/= i last)
1502 (calendar-insert-indented "" 0 t) ; force onto following line 1502 (calendar-insert-indented "" 0 t) ; force onto following line
@@ -1696,10 +1696,10 @@ the inserted text. Returns t."
1696(defcustom calendar-mode-line-format 1696(defcustom calendar-mode-line-format
1697 (list 1697 (list
1698 (propertize "<" 1698 (propertize "<"
1699 'help-echo "mouse-1: previous month" 1699 'help-echo "mouse-1: previous month"
1700 'mouse-face 'mode-line-highlight 1700 'mouse-face 'mode-line-highlight
1701 'keymap (make-mode-line-mouse-map 'mouse-1 1701 'keymap (make-mode-line-mouse-map 'mouse-1
1702 'calendar-scroll-right)) 1702 'calendar-scroll-right))
1703 "Calendar" 1703 "Calendar"
1704 (concat 1704 (concat
1705 (propertize 1705 (propertize
@@ -1715,7 +1715,7 @@ the inserted text. Returns t."
1715 'help-echo "mouse-1: choose another month" 1715 'help-echo "mouse-1: choose another month"
1716 'mouse-face 'mode-line-highlight 1716 'mouse-face 'mode-line-highlight
1717 'keymap (make-mode-line-mouse-map 1717 'keymap (make-mode-line-mouse-map
1718 'mouse-1 'mouse-calendar-other-month)) 1718 'mouse-1 'mouse-calendar-other-month))
1719 " / " 1719 " / "
1720 (propertize 1720 (propertize
1721 (substitute-command-keys 1721 (substitute-command-keys
@@ -1725,10 +1725,10 @@ the inserted text. Returns t."
1725 'keymap (make-mode-line-mouse-map 'mouse-1 #'calendar-goto-today))) 1725 'keymap (make-mode-line-mouse-map 'mouse-1 #'calendar-goto-today)))
1726 '(calendar-date-string (calendar-current-date) t) 1726 '(calendar-date-string (calendar-current-date) t)
1727 (propertize ">" 1727 (propertize ">"
1728 'help-echo "mouse-1: next month" 1728 'help-echo "mouse-1: next month"
1729 'mouse-face 'mode-line-highlight 1729 'mouse-face 'mode-line-highlight
1730 'keymap (make-mode-line-mouse-map 1730 'keymap (make-mode-line-mouse-map
1731 'mouse-1 'calendar-scroll-left))) 1731 'mouse-1 'calendar-scroll-left)))
1732 "The mode line of the calendar buffer. 1732 "The mode line of the calendar buffer.
1733 1733
1734This must be a list of items that evaluate to strings--those strings are 1734This must be a list of items that evaluate to strings--those strings are
@@ -1845,8 +1845,8 @@ the STRINGS are just concatenated and the result truncated."
1845 (let ((calendar-buffers (calendar-buffer-list)) 1845 (let ((calendar-buffers (calendar-buffer-list))
1846 list) 1846 list)
1847 (walk-windows (lambda (w) 1847 (walk-windows (lambda (w)
1848 (if (memq (window-buffer w) calendar-buffers) 1848 (if (memq (window-buffer w) calendar-buffers)
1849 (push w list))) 1849 (push w list)))
1850 nil t) 1850 nil t)
1851 list)) 1851 list))
1852 1852
@@ -2122,7 +2122,7 @@ If optional NODAY is t, does not ask for day, but just returns
2122 (list month year)) 2122 (list month year))
2123 (list month 2123 (list month
2124 (calendar-read (format "Day (1-%d): " last) 2124 (calendar-read (format "Day (1-%d): " last)
2125 (lambda (x) (and (< 0 x) (<= x last)))) 2125 (lambda (x) (and (< 0 x) (<= x last))))
2126 year)))) 2126 year))))
2127 2127
2128(defun calendar-interval (mon1 yr1 mon2 yr2) 2128(defun calendar-interval (mon1 yr1 mon2 yr2)
@@ -2153,11 +2153,11 @@ each element returned has a final `.' character."
2153 2153
2154(defvar calendar-font-lock-keywords 2154(defvar calendar-font-lock-keywords
2155 `((,(concat (regexp-opt (mapcar 'identity calendar-month-name-array) t) 2155 `((,(concat (regexp-opt (mapcar 'identity calendar-month-name-array) t)
2156 " -?[0-9]+") 2156 " -?[0-9]+")
2157 . font-lock-function-name-face) ; month and year 2157 . font-lock-function-name-face) ; month and year
2158 (,(regexp-opt 2158 (,(regexp-opt
2159 (list (substring (aref calendar-day-name-array 6) 0 2) 2159 (list (substring (aref calendar-day-name-array 6) 0 2)
2160 (substring (aref calendar-day-name-array 0) 0 2))) 2160 (substring (aref calendar-day-name-array 0) 0 2)))
2161 ;; Saturdays and Sundays are highlighted differently. 2161 ;; Saturdays and Sundays are highlighted differently.
2162 . font-lock-comment-face) 2162 . font-lock-comment-face)
2163 ;; First two chars of each day are used in the calendar. 2163 ;; First two chars of each day are used in the calendar.
@@ -2383,17 +2383,17 @@ If N>0, return the Nth DAYNAME after MONTH DAY, YEAR (inclusive).
2383If DAY is omitted, it defaults to 1 if N>0, and MONTH's last day otherwise." 2383If DAY is omitted, it defaults to 1 if N>0, and MONTH's last day otherwise."
2384 (if (> n 0) 2384 (if (> n 0)
2385 (+ (* 7 (1- n)) 2385 (+ (* 7 (1- n))
2386 (calendar-dayname-on-or-before 2386 (calendar-dayname-on-or-before
2387 dayname 2387 dayname
2388 (+ 6 (calendar-absolute-from-gregorian 2388 (+ 6 (calendar-absolute-from-gregorian
2389 (list month (or day 1) year))))) 2389 (list month (or day 1) year)))))
2390 (+ (* 7 (1+ n)) 2390 (+ (* 7 (1+ n))
2391 (calendar-dayname-on-or-before 2391 (calendar-dayname-on-or-before
2392 dayname 2392 dayname
2393 (calendar-absolute-from-gregorian 2393 (calendar-absolute-from-gregorian
2394 (list month 2394 (list month
2395 (or day (calendar-last-day-of-month month year)) 2395 (or day (calendar-last-day-of-month month year))
2396 year)))))) 2396 year))))))
2397 2397
2398(defun calendar-nth-named-day (n dayname month year &optional day) 2398(defun calendar-nth-named-day (n dayname month year &optional day)
2399 "The date of Nth DAYNAME in MONTH, YEAR before/after optional DAY. 2399 "The date of Nth DAYNAME in MONTH, YEAR before/after optional DAY.
diff --git a/lisp/calendar/diary-lib.el b/lisp/calendar/diary-lib.el
index 4139ec340ad..dbba1ce7d26 100644
--- a/lisp/calendar/diary-lib.el
+++ b/lisp/calendar/diary-lib.el
@@ -54,7 +54,7 @@ are holidays."
54 :type 'face 54 :type 'face
55 :group 'diary) 55 :group 'diary)
56(make-obsolete-variable 'diary-face "customize the face `diary' instead." 56(make-obsolete-variable 'diary-face "customize the face `diary' instead."
57 "23.1") 57 "23.1")
58 58
59;; Face markup of calendar and diary displays: Any entry line that 59;; Face markup of calendar and diary displays: Any entry line that
60;; ends with [foo:value] where foo is a face attribute (except :box 60;; ends with [foo:value] where foo is a face attribute (except :box
@@ -90,14 +90,14 @@ that this is a face (`:face') to apply. TYPE is the type of
90attribute being applied. Available TYPES (see `diary-attrtype-convert') 90attribute being applied. Available TYPES (see `diary-attrtype-convert')
91are: `string', `symbol', `int', `tnil',`stringtnil.'" 91are: `string', `symbol', `int', `tnil',`stringtnil.'"
92 :type '(repeat (list (string :tag "Regular expression") 92 :type '(repeat (list (string :tag "Regular expression")
93 (integer :tag "Sub-expression") 93 (integer :tag "Sub-expression")
94 (symbol :tag "Attribute (e.g. :foreground)") 94 (symbol :tag "Attribute (e.g. :foreground)")
95 (choice (const string :tag "A string") 95 (choice (const string :tag "A string")
96 (const symbol :tag "A symbol") 96 (const symbol :tag "A symbol")
97 (const int :tag "An integer") 97 (const int :tag "An integer")
98 (const tnil :tag "`t' or `nil'") 98 (const tnil :tag "`t' or `nil'")
99 (const stringtnil 99 (const stringtnil
100 :tag "A string, `t', or `nil'")))) 100 :tag "A string, `t', or `nil'"))))
101 :group 'diary) 101 :group 'diary)
102 102
103(defcustom diary-glob-file-regexp-prefix "^\\#" 103(defcustom diary-glob-file-regexp-prefix "^\\#"
@@ -177,8 +177,8 @@ to cull relevant entries. You can use either or both of
177describes the style of such diary entries." 177describes the style of such diary entries."
178 :type 'hook 178 :type 'hook
179 :options '(list-hebrew-diary-entries 179 :options '(list-hebrew-diary-entries
180 list-islamic-diary-entries 180 list-islamic-diary-entries
181 diary-bahai-list-entries) 181 diary-bahai-list-entries)
182 :group 'diary) 182 :group 'diary)
183 183
184(defcustom nongregorian-diary-marking-hook nil 184(defcustom nongregorian-diary-marking-hook nil
@@ -190,8 +190,8 @@ to cull relevant entries. You can use either or both of
190describes the style of such diary entries." 190describes the style of such diary entries."
191 :type 'hook 191 :type 'hook
192 :options '(mark-hebrew-diary-entries 192 :options '(mark-hebrew-diary-entries
193 mark-islamic-diary-entries 193 mark-islamic-diary-entries
194 diary-bahai-mark-entries) 194 diary-bahai-mark-entries)
195 :group 'diary) 195 :group 'diary)
196 196
197(defcustom print-diary-entries-hook 'lpr-buffer 197(defcustom print-diary-entries-hook 'lpr-buffer
@@ -278,10 +278,10 @@ If the template is actually a function, it is called with the message
278body text as argument, and may use `match-string' etc. to make a 278body text as argument, and may use `match-string' etc. to make a
279template following the rules above." 279template following the rules above."
280 :type '(alist :key-type (regexp :tag "Regexp matching time/place") 280 :type '(alist :key-type (regexp :tag "Regexp matching time/place")
281 :value-type (choice 281 :value-type (choice
282 (string :tag "Template for entry") 282 (string :tag "Template for entry")
283 (function :tag 283 (function :tag
284 "Unary function providing template"))) 284 "Unary function providing template")))
285 :version "22.1" 285 :version "22.1"
286 :group 'diary) 286 :group 'diary)
287 287
@@ -345,13 +345,13 @@ syntax of `*' and `:' changed to be word constituents.")
345 "Convert string ATTRVALUE to TYPE appropriate for a face description. 345 "Convert string ATTRVALUE to TYPE appropriate for a face description.
346Valid TYPEs are: string, symbol, int, stringtnil, tnil." 346Valid TYPEs are: string, symbol, int, stringtnil, tnil."
347 (cond ((eq type 'string) attrvalue) 347 (cond ((eq type 'string) attrvalue)
348 ((eq type 'symbol) (read attrvalue)) ; FIXME intern-soft? 348 ((eq type 'symbol) (read attrvalue)) ; FIXME intern-soft?
349 ((eq type 'int) (string-to-number attrvalue)) 349 ((eq type 'int) (string-to-number attrvalue))
350 ((eq type 'stringtnil) 350 ((eq type 'stringtnil)
351 (cond ((string-equal "t" attrvalue) t) 351 (cond ((string-equal "t" attrvalue) t)
352 ((string-equal "nil" attrvalue) nil) 352 ((string-equal "nil" attrvalue) nil)
353 (t attrvalue))) 353 (t attrvalue)))
354 ((eq type 'tnil) (string-equal "t" attrvalue)))) 354 ((eq type 'tnil) (string-equal "t" attrvalue))))
355 355
356(defun diary-pull-attrs (entry fileglobattrs) 356(defun diary-pull-attrs (entry fileglobattrs)
357 "Search for matches for regexps from `diary-face-attrs'. 357 "Search for matches for regexps from `diary-face-attrs'.
@@ -363,34 +363,34 @@ When ENTRY is non-nil, FILEGLOBATTRS forms the start of the (ATTRIBUTE VALUE)
363pairs." 363pairs."
364 (let (regexp regnum attrname attrname attrvalue type ret-attr) 364 (let (regexp regnum attrname attrname attrvalue type ret-attr)
365 (if (null entry) 365 (if (null entry)
366 (save-excursion 366 (save-excursion
367 (dolist (attr diary-face-attrs) 367 (dolist (attr diary-face-attrs)
368 ;; FIXME inefficient searching. 368 ;; FIXME inefficient searching.
369 (goto-char (point-min)) 369 (goto-char (point-min))
370 (setq regexp (concat diary-glob-file-regexp-prefix (car attr)) 370 (setq regexp (concat diary-glob-file-regexp-prefix (car attr))
371 regnum (cadr attr) 371 regnum (cadr attr)
372 attrname (nth 2 attr) 372 attrname (nth 2 attr)
373 type (nth 3 attr) 373 type (nth 3 attr)
374 attrvalue (if (re-search-forward regexp nil t) 374 attrvalue (if (re-search-forward regexp nil t)
375 (match-string-no-properties regnum))) 375 (match-string-no-properties regnum)))
376 (and attrvalue 376 (and attrvalue
377 (setq attrvalue (diary-attrtype-convert attrvalue type)) 377 (setq attrvalue (diary-attrtype-convert attrvalue type))
378 (setq ret-attr (append ret-attr 378 (setq ret-attr (append ret-attr
379 (list attrname attrvalue)))))) 379 (list attrname attrvalue))))))
380 (setq ret-attr fileglobattrs) 380 (setq ret-attr fileglobattrs)
381 (dolist (attr diary-face-attrs) 381 (dolist (attr diary-face-attrs)
382 (setq regexp (car attr) 382 (setq regexp (car attr)
383 regnum (cadr attr) 383 regnum (cadr attr)
384 attrname (nth 2 attr) 384 attrname (nth 2 attr)
385 type (nth 3 attr) 385 type (nth 3 attr)
386 attrvalue nil) 386 attrvalue nil)
387 ;; FIXME multiple matches? 387 ;; FIXME multiple matches?
388 (if (string-match regexp entry) 388 (if (string-match regexp entry)
389 (setq attrvalue (match-string-no-properties regnum entry) 389 (setq attrvalue (match-string-no-properties regnum entry)
390 entry (replace-match "" t t entry))) 390 entry (replace-match "" t t entry)))
391 (and attrvalue 391 (and attrvalue
392 (setq attrvalue (diary-attrtype-convert attrvalue type)) 392 (setq attrvalue (diary-attrtype-convert attrvalue type))
393 (setq ret-attr (append ret-attr (list attrname attrvalue)))))) 393 (setq ret-attr (append ret-attr (list attrname attrvalue))))))
394 (list entry ret-attr))) 394 (list entry ret-attr)))
395 395
396;;;###cal-autoload 396;;;###cal-autoload
@@ -471,14 +471,14 @@ This variable does not affect the diary display with the `d' command
471from the calendar; in that case, the prefix argument controls the 471from the calendar; in that case, the prefix argument controls the
472number of days of diary entries displayed." 472number of days of diary entries displayed."
473 :type '(choice (integer :tag "Entries") 473 :type '(choice (integer :tag "Entries")
474 (vector :value [0 0 0 0 0 0 0] 474 (vector :value [0 0 0 0 0 0 0]
475 (integer :tag "Sunday") 475 (integer :tag "Sunday")
476 (integer :tag "Monday") 476 (integer :tag "Monday")
477 (integer :tag "Tuesday") 477 (integer :tag "Tuesday")
478 (integer :tag "Wednesday") 478 (integer :tag "Wednesday")
479 (integer :tag "Thursday") 479 (integer :tag "Thursday")
480 (integer :tag "Friday") 480 (integer :tag "Friday")
481 (integer :tag "Saturday"))) 481 (integer :tag "Saturday")))
482 :initialize 'custom-initialize-default 482 :initialize 'custom-initialize-default
483 :set 'diary-set-maybe-redraw 483 :set 'diary-set-maybe-redraw
484 :group 'diary) 484 :group 'diary)
@@ -490,7 +490,7 @@ Can be used by programs integrating a diary list into other buffers (e.g.
490org.el and planner.el) to modify the string or add properties to it. 490org.el and planner.el) to modify the string or add properties to it.
491The function takes a string argument and must return a string.") 491The function takes a string argument and must return a string.")
492 492
493(defvar diary-entries-list) ; bound in diary-list-entries 493(defvar diary-entries-list) ; bound in diary-list-entries
494 494
495(defun add-to-diary-list (date string specifier &optional marker 495(defun add-to-diary-list (date string specifier &optional marker
496 globcolor literal) 496 globcolor literal)
@@ -513,8 +513,8 @@ FILENAME being the file containing the diary entry."
513 (or (string-equal prefix "") 513 (or (string-equal prefix "")
514 (setq string (format "[%s] %s" prefix string))))) 514 (setq string (format "[%s] %s" prefix string)))))
515 (and diary-modify-entry-list-string-function 515 (and diary-modify-entry-list-string-function
516 (setq string (funcall diary-modify-entry-list-string-function 516 (setq string (funcall diary-modify-entry-list-string-function
517 string))) 517 string)))
518 (setq diary-entries-list 518 (setq diary-entries-list
519 (append diary-entries-list 519 (append diary-entries-list
520 (list (list date string specifier 520 (list (list date string specifier
@@ -567,7 +567,7 @@ If LIST-ONLY is non-nil don't modify or display the buffer, only return a list."
567 (aref number-of-diary-entries (calendar-day-of-week date)) 567 (aref number-of-diary-entries (calendar-day-of-week date))
568 number-of-diary-entries))) 568 number-of-diary-entries)))
569 (when (> number 0) 569 (when (> number 0)
570 (let ((original-date date) ; save for possible use in the hooks 570 (let ((original-date date) ; save for possible use in the hooks
571 diary-entries-list 571 diary-entries-list
572 file-glob-attrs 572 file-glob-attrs
573 (date-string (calendar-date-string date)) 573 (date-string (calendar-date-string date))
@@ -611,58 +611,58 @@ If LIST-ONLY is non-nil don't modify or display the buffer, only return a list."
611 (entry-found (list-sexp-diary-entries date))) 611 (entry-found (list-sexp-diary-entries date)))
612 (dolist (date-form diary-date-forms) 612 (dolist (date-form diary-date-forms)
613 (let* ((backup (when (eq (car date-form) 'backup) 613 (let* ((backup (when (eq (car date-form) 'backup)
614 (setq date-form (cdr date-form)) 614 (setq date-form (cdr date-form))
615 t)) 615 t))
616 (dayname 616 (dayname
617 (format "%s\\|%s\\.?" 617 (format "%s\\|%s\\.?"
618 (calendar-day-name date) 618 (calendar-day-name date)
619 (calendar-day-name date 'abbrev))) 619 (calendar-day-name date 'abbrev)))
620 (monthname 620 (monthname
621 (format "\\*\\|%s\\|%s\\.?" 621 (format "\\*\\|%s\\|%s\\.?"
622 (calendar-month-name month) 622 (calendar-month-name month)
623 (calendar-month-name month 'abbrev))) 623 (calendar-month-name month 'abbrev)))
624 (month (concat "\\*\\|0*" (int-to-string month))) 624 (month (concat "\\*\\|0*" (int-to-string month)))
625 (day (concat "\\*\\|0*" (int-to-string day))) 625 (day (concat "\\*\\|0*" (int-to-string day)))
626 (year 626 (year
627 (concat 627 (concat
628 "\\*\\|0*" (int-to-string year) 628 "\\*\\|0*" (int-to-string year)
629 (if abbreviated-calendar-year 629 (if abbreviated-calendar-year
630 (concat "\\|" (format "%02d" (% year 100))) 630 (concat "\\|" (format "%02d" (% year 100)))
631 ""))) 631 "")))
632 (regexp 632 (regexp
633 (concat 633 (concat
634 "^" mark "?\\(" 634 "^" mark "?\\("
635 ;; This must be let* so that date-form 635 ;; This must be let* so that date-form
636 ;; can use day etc. 636 ;; can use day etc.
637 (mapconcat 'eval date-form "\\)\\(?:") 637 (mapconcat 'eval date-form "\\)\\(?:")
638 "\\)")) 638 "\\)"))
639 (case-fold-search t)) 639 (case-fold-search t))
640 (goto-char (point-min)) 640 (goto-char (point-min))
641 (while (re-search-forward regexp nil t) 641 (while (re-search-forward regexp nil t)
642 (if backup (re-search-backward "\\<" nil t)) 642 (if backup (re-search-backward "\\<" nil t))
643 (if (and (bolp) (not (looking-at "[ \t]"))) 643 (if (and (bolp) (not (looking-at "[ \t]")))
644 ;; Diary entry that consists only of date. 644 ;; Diary entry that consists only of date.
645 (backward-char 1) 645 (backward-char 1)
646 ;; Found a nonempty diary entry--make it 646 ;; Found a nonempty diary entry--make it
647 ;; visible and add it to the list. 647 ;; visible and add it to the list.
648 (setq entry-found t) 648 (setq entry-found t)
649 (if (looking-at "[ \t]*\n[ \t]") (forward-line 1)) 649 (if (looking-at "[ \t]*\n[ \t]") (forward-line 1))
650 (let ((entry-start (point)) 650 (let ((entry-start (point))
651 date-start temp) 651 date-start temp)
652 (setq date-start 652 (setq date-start
653 (line-end-position 653 (line-end-position
654 (if (and (bolp) (> number 1)) -1 0))) 654 (if (and (bolp) (> number 1)) -1 0)))
655 (forward-line 1) 655 (forward-line 1)
656 (while (looking-at "[ \t]") 656 (while (looking-at "[ \t]")
657 (forward-line 1)) 657 (forward-line 1))
658 (unless (and (eobp) (not (bolp))) 658 (unless (and (eobp) (not (bolp)))
659 (backward-char 1)) 659 (backward-char 1))
660 (unless list-only 660 (unless list-only
661 (remove-overlays date-start (point) 661 (remove-overlays date-start (point)
662 'invisible 'diary)) 662 'invisible 'diary))
663 (setq temp (diary-pull-attrs 663 (setq temp (diary-pull-attrs
664 (buffer-substring entry-start (point)) 664 (buffer-substring entry-start (point))
665 file-glob-attrs)) 665 file-glob-attrs))
666 (add-to-diary-list 666 (add-to-diary-list
667 date 667 date
668 (car temp) 668 (car temp)
@@ -681,8 +681,8 @@ If LIST-ONLY is non-nil don't modify or display the buffer, only return a list."
681 'list-diary-entries-hook) 681 'list-diary-entries-hook)
682 (unless list-only 682 (unless list-only
683 (if diary-display-hook 683 (if diary-display-hook
684 (run-hooks 'diary-display-hook) 684 (run-hooks 'diary-display-hook)
685 (simple-diary-display))) 685 (simple-diary-display)))
686 (run-hooks 'diary-hook) 686 (run-hooks 'diary-hook)
687 diary-entries-list)))))) 687 diary-entries-list))))))
688 688
@@ -692,7 +692,7 @@ If LIST-ONLY is non-nil don't modify or display the buffer, only return a list."
692 (remove-overlays (point-min) (point-max) 'invisible 'diary) 692 (remove-overlays (point-min) (point-max) 'invisible 'diary)
693 (kill-local-variable 'mode-line-format)) 693 (kill-local-variable 'mode-line-format))
694 694
695(defvar original-date) ; bound in diary-list-entries 695(defvar original-date) ; bound in diary-list-entries
696(defvar number) 696(defvar number)
697 697
698(defun include-other-diary-files () 698(defun include-other-diary-files ()
@@ -712,11 +712,11 @@ changing the variable `diary-include-string'."
712 " \"\\([^\"]*\\)\"") 712 " \"\\([^\"]*\\)\"")
713 nil t) 713 nil t)
714 (let ((diary-file (substitute-in-file-name 714 (let ((diary-file (substitute-in-file-name
715 (match-string-no-properties 1))) 715 (match-string-no-properties 1)))
716 (diary-list-include-blanks nil) 716 (diary-list-include-blanks nil)
717 (list-diary-entries-hook 'include-other-diary-files) 717 (list-diary-entries-hook 'include-other-diary-files)
718 (diary-display-hook 'ignore) 718 (diary-display-hook 'ignore)
719 (diary-hook nil)) 719 (diary-hook nil))
720 (if (file-exists-p diary-file) 720 (if (file-exists-p diary-file)
721 (if (file-readable-p diary-file) 721 (if (file-readable-p diary-file)
722 (unwind-protect 722 (unwind-protect
@@ -731,7 +731,7 @@ changing the variable `diary-include-string'."
731 (beep) 731 (beep)
732 (message "Can't find included diary file %s" diary-file) 732 (message "Can't find included diary file %s" diary-file)
733 (sleep-for 2)))) 733 (sleep-for 2))))
734 (goto-char (point-min))) 734 (goto-char (point-min)))
735 735
736;; Bound in diary-list-entries. 736;; Bound in diary-list-entries.
737(defvar date-string) 737(defvar date-string)
@@ -775,7 +775,7 @@ changing the variable `diary-include-string'."
775 (message "Preparing diary...done")))) 775 (message "Preparing diary...done"))))
776 776
777(defface diary-button '((((type pc) (class color)) 777(defface diary-button '((((type pc) (class color))
778 (:foreground "lightblue"))) 778 (:foreground "lightblue")))
779 "Default face used for buttons." 779 "Default face used for buttons."
780 :version "22.1" 780 :version "22.1"
781 :group 'diary) 781 :group 'diary)
@@ -845,7 +845,7 @@ This function is provided for optional use as the `diary-display-hook'."
845 (holiday-list-last-month 1) 845 (holiday-list-last-month 1)
846 (holiday-list-last-year 1) 846 (holiday-list-last-year 1)
847 (date (list 0 0 0))) 847 (date (list 0 0 0)))
848 (dolist (entry entry-list) 848 (dolist (entry entry-list)
849 (if (not (calendar-date-equal date (car entry))) 849 (if (not (calendar-date-equal date (car entry)))
850 (progn 850 (progn
851 (setq date (car entry)) 851 (setq date (car entry))
@@ -860,7 +860,7 @@ This function is provided for optional use as the `diary-display-hook'."
860 ;; We need to get the holidays for the next 3 months. 860 ;; We need to get the holidays for the next 3 months.
861 (setq holiday-list-last-month 861 (setq holiday-list-last-month
862 (extract-calendar-month date) 862 (extract-calendar-month date)
863 holiday-list-last-year 863 holiday-list-last-year
864 (extract-calendar-year date)) 864 (extract-calendar-year date))
865 (progn 865 (progn
866 (increment-calendar-month 866 (increment-calendar-month
@@ -873,62 +873,62 @@ This function is provided for optional use as the `diary-display-hook'."
873 (increment-calendar-month 873 (increment-calendar-month
874 holiday-list-last-month holiday-list-last-year 1)) 874 holiday-list-last-month holiday-list-last-year 1))
875 (let (date-holiday-list) 875 (let (date-holiday-list)
876 ;; Make a list of all holidays for date. 876 ;; Make a list of all holidays for date.
877 (dolist (h holiday-list) 877 (dolist (h holiday-list)
878 (if (calendar-date-equal date (car h)) 878 (if (calendar-date-equal date (car h))
879 (setq date-holiday-list (append date-holiday-list 879 (setq date-holiday-list (append date-holiday-list
880 (cdr h))))) 880 (cdr h)))))
881 (insert (if (bobp) "" ?\n) (calendar-date-string date)) 881 (insert (if (bobp) "" ?\n) (calendar-date-string date))
882 (if date-holiday-list (insert ": ")) 882 (if date-holiday-list (insert ": "))
883 (let ((l (current-column)) 883 (let ((l (current-column))
884 (longest 0)) 884 (longest 0))
885 (insert (mapconcat (lambda (x) 885 (insert (mapconcat (lambda (x)
886 (if (< longest (length x)) 886 (if (< longest (length x))
887 (setq longest (length x))) 887 (setq longest (length x)))
888 x) 888 x)
889 date-holiday-list 889 date-holiday-list
890 (concat "\n" (make-string l ? )))) 890 (concat "\n" (make-string l ? ))))
891 (insert ?\n (make-string (+ l longest) ?=) ?\n))))) 891 (insert ?\n (make-string (+ l longest) ?=) ?\n)))))
892 (let ((this-entry (cadr entry)) 892 (let ((this-entry (cadr entry))
893 this-loc) 893 this-loc)
894 (unless (zerop (length this-entry)) 894 (unless (zerop (length this-entry))
895 (if (setq this-loc (nth 3 entry)) 895 (if (setq this-loc (nth 3 entry))
896 (insert-button (concat this-entry "\n") 896 (insert-button (concat this-entry "\n")
897 ;; (MARKER FILENAME SPECIFIER LITERAL) 897 ;; (MARKER FILENAME SPECIFIER LITERAL)
898 'locator (list (car this-loc) 898 'locator (list (car this-loc)
899 (cadr this-loc) 899 (cadr this-loc)
900 (nth 2 entry) 900 (nth 2 entry)
901 (or (nth 2 this-loc) 901 (or (nth 2 this-loc)
902 (nth 1 entry))) 902 (nth 1 entry)))
903 :type 'diary-entry) 903 :type 'diary-entry)
904 (insert this-entry ?\n)) 904 (insert this-entry ?\n))
905 (save-excursion 905 (save-excursion
906 (let* ((marks (nth 4 entry)) 906 (let* ((marks (nth 4 entry))
907 (faceinfo marks) 907 (faceinfo marks)
908 temp-face) 908 temp-face)
909 (when marks 909 (when marks
910 (setq temp-face (make-symbol 910 (setq temp-face (make-symbol
911 (apply 911 (apply
912 'concat "temp-face-" 912 'concat "temp-face-"
913 (mapcar (lambda (sym) 913 (mapcar (lambda (sym)
914 (if (stringp sym) 914 (if (stringp sym)
915 sym 915 sym
916 (symbol-name sym))) 916 (symbol-name sym)))
917 marks)))) 917 marks))))
918 (make-face temp-face) 918 (make-face temp-face)
919 ;; Remove :face info from the marks, 919 ;; Remove :face info from the marks,
920 ;; copy the face info into temp-face 920 ;; copy the face info into temp-face
921 (while (setq faceinfo (memq :face faceinfo)) 921 (while (setq faceinfo (memq :face faceinfo))
922 (copy-face (read (nth 1 faceinfo)) temp-face) 922 (copy-face (read (nth 1 faceinfo)) temp-face)
923 (setcar faceinfo nil) 923 (setcar faceinfo nil)
924 (setcar (cdr faceinfo) nil)) 924 (setcar (cdr faceinfo) nil))
925 (setq marks (delq nil marks)) 925 (setq marks (delq nil marks))
926 ;; Apply the font aspects. 926 ;; Apply the font aspects.
927 (apply 'set-face-attribute temp-face nil marks) 927 (apply 'set-face-attribute temp-face nil marks)
928 (search-backward this-entry) 928 (search-backward this-entry)
929 (overlay-put 929 (overlay-put
930 (make-overlay (match-beginning 0) (match-end 0)) 930 (make-overlay (match-beginning 0) (match-end 0))
931 'face temp-face)))))))) 931 'face temp-face))))))))
932 (set-buffer-modified-p nil) 932 (set-buffer-modified-p nil)
933 (goto-char (point-min)) 933 (goto-char (point-min))
934 (setq buffer-read-only t) 934 (setq buffer-read-only t)
@@ -1166,11 +1166,11 @@ diary entries."
1166 (+ y 100) 1166 (+ y 100)
1167 y))) 1167 y)))
1168 (string-to-number y-str))))) 1168 (string-to-number y-str)))))
1169 (setq marks (nth 1 1169 (setq marks (nth 1
1170 (diary-pull-attrs 1170 (diary-pull-attrs
1171 (buffer-substring-no-properties 1171 (buffer-substring-no-properties
1172 (point) (line-end-position)) 1172 (point) (line-end-position))
1173 file-glob-attrs))) 1173 file-glob-attrs)))
1174 (if dd-name 1174 (if dd-name
1175 (mark-calendar-days-named 1175 (mark-calendar-days-named
1176 (cdr (assoc-string 1176 (cdr (assoc-string
@@ -1192,7 +1192,7 @@ diary entries."
1192 'mark-diary-entries-hook)) 1192 'mark-diary-entries-hook))
1193 (message "Marking diary entries...done"))))) 1193 (message "Marking diary entries...done")))))
1194 1194
1195(defvar displayed-year) ; bound in generate-calendar 1195(defvar displayed-year) ; bound in generate-calendar
1196(defvar displayed-month) 1196(defvar displayed-month)
1197 1197
1198(defun mark-sexp-diary-entries () 1198(defun mark-sexp-diary-entries ()
@@ -1226,7 +1226,7 @@ is marked. See the documentation for the function `list-sexp-diary-entries'."
1226 (setq sexp (buffer-substring-no-properties sexp-start (point))) 1226 (setq sexp (buffer-substring-no-properties sexp-start (point)))
1227 (forward-char 1) 1227 (forward-char 1)
1228 (if (and (bolp) (not (looking-at "[ \t]"))) 1228 (if (and (bolp) (not (looking-at "[ \t]")))
1229 ;; Diary entry consists only of the sexp. 1229 ;; Diary entry consists only of the sexp.
1230 (progn 1230 (progn
1231 (backward-char 1) 1231 (backward-char 1)
1232 (setq entry "")) 1232 (setq entry ""))
@@ -1238,17 +1238,17 @@ is marked. See the documentation for the function `list-sexp-diary-entries'."
1238 (if (bolp) (backward-char 1)) 1238 (if (bolp) (backward-char 1))
1239 (setq entry (buffer-substring-no-properties entry-start (point)))) 1239 (setq entry (buffer-substring-no-properties entry-start (point))))
1240 (calendar-for-loop date from first-date to last-date do 1240 (calendar-for-loop date from first-date to last-date do
1241 (if (setq mark (diary-sexp-entry sexp entry 1241 (if (setq mark (diary-sexp-entry sexp entry
1242 (calendar-gregorian-from-absolute date))) 1242 (calendar-gregorian-from-absolute date)))
1243 (progn 1243 (progn
1244 (setq marks (diary-pull-attrs entry file-glob-attrs) 1244 (setq marks (diary-pull-attrs entry file-glob-attrs)
1245 marks (nth 1 (diary-pull-attrs entry file-glob-attrs))) 1245 marks (nth 1 (diary-pull-attrs entry file-glob-attrs)))
1246 (mark-visible-calendar-date 1246 (mark-visible-calendar-date
1247 (calendar-gregorian-from-absolute date) 1247 (calendar-gregorian-from-absolute date)
1248 (if (< 0 (length marks)) 1248 (if (< 0 (length marks))
1249 marks 1249 marks
1250 (if (consp mark) 1250 (if (consp mark)
1251 (car mark))))))))))) 1251 (car mark)))))))))))
1252 1252
1253(defun mark-included-diary-files () 1253(defun mark-included-diary-files ()
1254 "Mark the diary entries from other diary files with those of the diary file. 1254 "Mark the diary entries from other diary files with those of the diary file.
@@ -1299,11 +1299,11 @@ Optional argument COLOR is passed to `mark-visible-calendar-date' as MARK."
1299 (increment-calendar-month prev-month prev-year -1) 1299 (increment-calendar-month prev-month prev-year -1)
1300 (setq day (calendar-absolute-from-gregorian 1300 (setq day (calendar-absolute-from-gregorian
1301 (calendar-nth-named-day 1 dayname prev-month prev-year)) 1301 (calendar-nth-named-day 1 dayname prev-month prev-year))
1302 last-day (calendar-absolute-from-gregorian 1302 last-day (calendar-absolute-from-gregorian
1303 (calendar-nth-named-day -1 dayname succ-month succ-year))) 1303 (calendar-nth-named-day -1 dayname succ-month succ-year)))
1304 (while (<= day last-day) 1304 (while (<= day last-day)
1305 (mark-visible-calendar-date (calendar-gregorian-from-absolute day) 1305 (mark-visible-calendar-date (calendar-gregorian-from-absolute day)
1306 color) 1306 color)
1307 (setq day (+ day 7)))))) 1307 (setq day (+ day 7))))))
1308 1308
1309(defun mark-calendar-date-pattern (month day year &optional color) 1309(defun mark-calendar-date-pattern (month day year &optional color)
@@ -1328,8 +1328,8 @@ Optional argument COLOR is passed to `mark-visible-calendar-date' as MARK."
1328 (or (zerop p-year) (= year p-year)))) 1328 (or (zerop p-year) (= year p-year))))
1329 (if (zerop p-day) 1329 (if (zerop p-day)
1330 (calendar-for-loop 1330 (calendar-for-loop
1331 i from 1 to (calendar-last-day-of-month month year) do 1331 i from 1 to (calendar-last-day-of-month month year) do
1332 (mark-visible-calendar-date (list month i year) color)) 1332 (mark-visible-calendar-date (list month i year) color))
1333 (mark-visible-calendar-date (list month p-day year) color)))) 1333 (mark-visible-calendar-date (list month p-day year) color))))
1334 1334
1335(defun sort-diary-entries () 1335(defun sort-diary-entries ()
@@ -1355,23 +1355,23 @@ The recognized forms are XXXX, X:XX, or XX:XX (military time), and XXam,
1355XXAM, XXpm, XXPM, XX:XXam, XX:XXAM XX:XXpm, or XX:XXPM. A period (.) can 1355XXAM, XXpm, XXPM, XX:XXam, XX:XXAM XX:XXpm, or XX:XXPM. A period (.) can
1356be used instead of a colon (:) to separate the hour and minute parts." 1356be used instead of a colon (:) to separate the hour and minute parts."
1357 (let ((case-fold-search nil)) 1357 (let ((case-fold-search nil))
1358 (cond ((string-match ; military time 1358 (cond ((string-match ; military time
1359 "\\`[ \t\n]*\\([0-9]?[0-9]\\)[:.]?\\([0-9][0-9]\\)\\(\\>\\|[^ap]\\)" 1359 "\\`[ \t\n]*\\([0-9]?[0-9]\\)[:.]?\\([0-9][0-9]\\)\\(\\>\\|[^ap]\\)"
1360 s) 1360 s)
1361 (+ (* 100 (string-to-number (match-string 1 s))) 1361 (+ (* 100 (string-to-number (match-string 1 s)))
1362 (string-to-number (match-string 2 s)))) 1362 (string-to-number (match-string 2 s))))
1363 ((string-match ; hour only (XXam or XXpm) 1363 ((string-match ; hour only (XXam or XXpm)
1364 "\\`[ \t\n]*\\([0-9]?[0-9]\\)\\([ap]\\)m\\>" s) 1364 "\\`[ \t\n]*\\([0-9]?[0-9]\\)\\([ap]\\)m\\>" s)
1365 (+ (* 100 (% (string-to-number (match-string 1 s)) 12)) 1365 (+ (* 100 (% (string-to-number (match-string 1 s)) 12))
1366 (if (equal ?a (downcase (aref s (match-beginning 2)))) 1366 (if (equal ?a (downcase (aref s (match-beginning 2))))
1367 0 1200))) 1367 0 1200)))
1368 ((string-match ; hour and minute (XX:XXam or XX:XXpm) 1368 ((string-match ; hour and minute (XX:XXam or XX:XXpm)
1369 "\\`[ \t\n]*\\([0-9]?[0-9]\\)[:.]\\([0-9][0-9]\\)\\([ap]\\)m\\>" s) 1369 "\\`[ \t\n]*\\([0-9]?[0-9]\\)[:.]\\([0-9][0-9]\\)\\([ap]\\)m\\>" s)
1370 (+ (* 100 (% (string-to-number (match-string 1 s)) 12)) 1370 (+ (* 100 (% (string-to-number (match-string 1 s)) 12))
1371 (string-to-number (match-string 2 s)) 1371 (string-to-number (match-string 2 s))
1372 (if (equal ?a (downcase (aref s (match-beginning 3)))) 1372 (if (equal ?a (downcase (aref s (match-beginning 3))))
1373 0 1200))) 1373 0 1200)))
1374 (t diary-unknown-time)))) ; unrecognizable 1374 (t diary-unknown-time)))) ; unrecognizable
1375 1375
1376(defun list-sexp-diary-entries (date) 1376(defun list-sexp-diary-entries (date)
1377 "Add sexp entries for DATE from the diary file to `diary-entries-list'. 1377 "Add sexp entries for DATE from the diary file to `diary-entries-list'.
@@ -1557,7 +1557,7 @@ best if they are nonmarking."
1557 entry-start (1+ line-start)) 1557 entry-start (1+ line-start))
1558 (forward-char 1) 1558 (forward-char 1)
1559 (if (and (bolp) (not (looking-at "[ \t]"))) 1559 (if (and (bolp) (not (looking-at "[ \t]")))
1560 ;; Diary entry consists only of the sexp. 1560 ;; Diary entry consists only of the sexp.
1561 (progn 1561 (progn
1562 (backward-char 1) 1562 (backward-char 1)
1563 (setq entry "")) 1563 (setq entry ""))
@@ -1604,9 +1604,9 @@ best if they are nonmarking."
1604 diary-file sexp) 1604 diary-file sexp)
1605 (sleep-for 2)))))) 1605 (sleep-for 2))))))
1606 (cond ((stringp result) result) 1606 (cond ((stringp result) result)
1607 ((and (consp result) 1607 ((and (consp result)
1608 (stringp (cdr result))) result) 1608 (stringp (cdr result))) result)
1609 (result entry) 1609 (result entry)
1610 (t nil)))) 1610 (t nil))))
1611 1611
1612(defvar date) 1612(defvar date)
@@ -1676,15 +1676,15 @@ backward from the end of the month.
1676An optional parameter DAY means the Nth DAYNAME on or after/before MONTH DAY. 1676An optional parameter DAY means the Nth DAYNAME on or after/before MONTH DAY.
1677Optional MARK specifies a face or single-character string to use when 1677Optional MARK specifies a face or single-character string to use when
1678highlighting the day in the calendar." 1678highlighting the day in the calendar."
1679;; This is messy because the diary entry may apply, but the date on which it 1679 ;; This is messy because the diary entry may apply, but the date on which it
1680;; is based can be in a different month/year. For example, asking for the 1680 ;; is based can be in a different month/year. For example, asking for the
1681;; first Monday after December 30. For large values of |n| the problem is 1681 ;; first Monday after December 30. For large values of |n| the problem is
1682;; more grotesque. 1682 ;; more grotesque.
1683 (and (= dayname (calendar-day-of-week date)) 1683 (and (= dayname (calendar-day-of-week date))
1684 (let* ((m (extract-calendar-month date)) 1684 (let* ((m (extract-calendar-month date))
1685 (d (extract-calendar-day date)) 1685 (d (extract-calendar-day date))
1686 (y (extract-calendar-year date)) 1686 (y (extract-calendar-year date))
1687 ;; Last (n>0) or first (n<0) possible base date for entry. 1687 ;; Last (n>0) or first (n<0) possible base date for entry.
1688 (limit 1688 (limit
1689 (calendar-nth-named-absday (- n) dayname m y d)) 1689 (calendar-nth-named-absday (- n) dayname m y d))
1690 (last-abs (if (> n 0) limit (+ limit 6))) 1690 (last-abs (if (> n 0) limit (+ limit 6)))
@@ -1699,38 +1699,38 @@ highlighting the day in the calendar."
1699 (m2 (extract-calendar-month last)) 1699 (m2 (extract-calendar-month last))
1700 (d2 (extract-calendar-day last)) 1700 (d2 (extract-calendar-day last))
1701 (y2 (extract-calendar-year last))) 1701 (y2 (extract-calendar-year last)))
1702 (if (or (and (= m1 m2) ; only possible base dates in one month 1702 (if (or (and (= m1 m2) ; only possible base dates in one month
1703 (or (eq month t) 1703 (or (eq month t)
1704 (if (listp month) 1704 (if (listp month)
1705 (memq m1 month) 1705 (memq m1 month)
1706 (= m1 month))) 1706 (= m1 month)))
1707 (let ((d (or day (if (> n 0) 1707 (let ((d (or day (if (> n 0)
1708 1 1708 1
1709 (calendar-last-day-of-month m1 y1))))) 1709 (calendar-last-day-of-month m1 y1)))))
1710 (and (<= d1 d) (<= d d2)))) 1710 (and (<= d1 d) (<= d d2))))
1711 ;; Only possible base dates straddle two months. 1711 ;; Only possible base dates straddle two months.
1712 (and (or (< y1 y2) 1712 (and (or (< y1 y2)
1713 (and (= y1 y2) (< m1 m2))) 1713 (and (= y1 y2) (< m1 m2)))
1714 (or 1714 (or
1715 ;; m1, d1 works as a base date. 1715 ;; m1, d1 works as a base date.
1716 (and 1716 (and
1717 (or (eq month t) 1717 (or (eq month t)
1718 (if (listp month) 1718 (if (listp month)
1719 (memq m1 month) 1719 (memq m1 month)
1720 (= m1 month))) 1720 (= m1 month)))
1721 (<= d1 (or day (if (> n 0) 1721 (<= d1 (or day (if (> n 0)
1722 1 1722 1
1723 (calendar-last-day-of-month m1 y1))))) 1723 (calendar-last-day-of-month m1 y1)))))
1724 ;; m2, d2 works as a base date. 1724 ;; m2, d2 works as a base date.
1725 (and (or (eq month t) 1725 (and (or (eq month t)
1726 (if (listp month) 1726 (if (listp month)
1727 (memq m2 month) 1727 (memq m2 month)
1728 (= m2 month))) 1728 (= m2 month)))
1729 (<= (or day (if (> n 0) 1729 (<= (or day (if (> n 0)
1730 1 1730 1
1731 (calendar-last-day-of-month m2 y2))) 1731 (calendar-last-day-of-month m2 y2)))
1732 d2))))) 1732 d2)))))
1733 (cons mark entry))))) 1733 (cons mark entry)))))
1734 1734
1735;; To be called from diary-sexp-entry, where DATE, ENTRY are bound. 1735;; To be called from diary-sexp-entry, where DATE, ENTRY are bound.
1736(defun diary-anniversary (month day &optional year mark) 1736(defun diary-anniversary (month day &optional year mark)
@@ -1818,7 +1818,7 @@ marked on the calendar."
1818 diary-entry) 1818 diary-entry)
1819 ;; Diary entry may apply to `days' before date. 1819 ;; Diary entry may apply to `days' before date.
1820 ((and (integerp days) 1820 ((and (integerp days)
1821 (not diary-entry) ; diary entry does not apply to date 1821 (not diary-entry) ; diary entry does not apply to date
1822 (or (not marking-diary-entries) marking)) 1822 (or (not marking-diary-entries) marking))
1823 (let ((date (calendar-gregorian-from-absolute 1823 (let ((date (calendar-gregorian-from-absolute
1824 (+ (calendar-absolute-from-gregorian date) days)))) 1824 (+ (calendar-absolute-from-gregorian date) days))))
@@ -1926,21 +1926,21 @@ Prefix argument ARG makes the entry nonmarking."
1926 (if european-calendar-style 1926 (if european-calendar-style
1927 '(day " " month " " year) 1927 '(day " " month " " year)
1928 '(month " " day " " year))) 1928 '(month " " day " " year)))
1929 (cursor (calendar-cursor-to-date t)) 1929 (cursor (calendar-cursor-to-date t))
1930 (mark (or (car calendar-mark-ring) 1930 (mark (or (car calendar-mark-ring)
1931 (error "No mark set in this buffer"))) 1931 (error "No mark set in this buffer")))
1932 start end) 1932 start end)
1933 (if (< (calendar-absolute-from-gregorian mark) 1933 (if (< (calendar-absolute-from-gregorian mark)
1934 (calendar-absolute-from-gregorian cursor)) 1934 (calendar-absolute-from-gregorian cursor))
1935 (setq start mark 1935 (setq start mark
1936 end cursor) 1936 end cursor)
1937 (setq start cursor 1937 (setq start cursor
1938 end mark)) 1938 end mark))
1939 (make-diary-entry 1939 (make-diary-entry
1940 (format "%s(diary-block %s %s)" 1940 (format "%s(diary-block %s %s)"
1941 sexp-diary-entry-symbol 1941 sexp-diary-entry-symbol
1942 (calendar-date-string start nil t) 1942 (calendar-date-string start nil t)
1943 (calendar-date-string end nil t)) 1943 (calendar-date-string end nil t))
1944 arg))) 1944 arg)))
1945 1945
1946;;;###cal-autoload 1946;;;###cal-autoload
@@ -2065,13 +2065,13 @@ Needed to handle multiline keyword in `fancy-diary-font-lock-keywords'."
2065 "?\\(" (regexp-quote sexp-diary-entry-symbol) "\\)") 2065 "?\\(" (regexp-quote sexp-diary-entry-symbol) "\\)")
2066 limit t) 2066 limit t)
2067 (condition-case nil 2067 (condition-case nil
2068 (save-restriction 2068 (save-restriction
2069 (narrow-to-region (point-min) limit) 2069 (narrow-to-region (point-min) limit)
2070 (let ((start (point))) 2070 (let ((start (point)))
2071 (forward-sexp 1) 2071 (forward-sexp 1)
2072 (store-match-data (list start (point))) 2072 (store-match-data (list start (point)))
2073 t)) 2073 t))
2074 (error t)))) 2074 (error t))))
2075 2075
2076(defun diary-font-lock-date-forms (month-array &optional symbol abbrev-array) 2076(defun diary-font-lock-date-forms (month-array &optional symbol abbrev-array)
2077 "Create font-lock patterns for `diary-date-forms' using MONTH-ARRAY. 2077 "Create font-lock patterns for `diary-date-forms' using MONTH-ARRAY.
@@ -2088,21 +2088,21 @@ names."
2088 (day "\\([0-9]+\\|\\*\\)") 2088 (day "\\([0-9]+\\|\\*\\)")
2089 (year "-?\\([0-9]+\\|\\*\\)")) 2089 (year "-?\\([0-9]+\\|\\*\\)"))
2090 (mapcar (lambda (x) 2090 (mapcar (lambda (x)
2091 (cons 2091 (cons
2092 (concat "^" (regexp-quote diary-nonmarking-symbol) "?" 2092 (concat "^" (regexp-quote diary-nonmarking-symbol) "?"
2093 (if symbol (regexp-quote symbol) "") "\\(" 2093 (if symbol (regexp-quote symbol) "") "\\("
2094 (mapconcat 'eval 2094 (mapconcat 'eval
2095 ;; If backup, omit first item (backup) 2095 ;; If backup, omit first item (backup)
2096 ;; and last item (not part of date). 2096 ;; and last item (not part of date).
2097 (if (equal (car x) 'backup) 2097 (if (equal (car x) 'backup)
2098 (nreverse (cdr (reverse (cdr x)))) 2098 (nreverse (cdr (reverse (cdr x))))
2099 x) 2099 x)
2100 "") 2100 "")
2101 ;; With backup, last item is not part of date. 2101 ;; With backup, last item is not part of date.
2102 (if (equal (car x) 'backup) 2102 (if (equal (car x) 'backup)
2103 (concat "\\)" (eval (car (reverse x)))) 2103 (concat "\\)" (eval (car (reverse x))))
2104 "\\)")) 2104 "\\)"))
2105 '(1 diary-face))) 2105 '(1 diary-face)))
2106 diary-date-forms))) 2106 diary-date-forms)))
2107 2107
2108(defvar calendar-hebrew-month-name-array-leap-year) 2108(defvar calendar-hebrew-month-name-array-leap-year)
@@ -2130,9 +2130,9 @@ names."
2130 (diary-font-lock-date-forms 2130 (diary-font-lock-date-forms
2131 calendar-islamic-month-name-array islamic-diary-entry-symbol)) 2131 calendar-islamic-month-name-array islamic-diary-entry-symbol))
2132 (when (or (memq 'diary-bahai-mark-entries 2132 (when (or (memq 'diary-bahai-mark-entries
2133 nongregorian-diary-marking-hook) 2133 nongregorian-diary-marking-hook)
2134 (memq 'diary-bahai-list-entries 2134 (memq 'diary-bahai-list-entries
2135 nongregorian-diary-marking-hook)) 2135 nongregorian-diary-marking-hook))
2136 (require 'cal-bahai) 2136 (require 'cal-bahai)
2137 (diary-font-lock-date-forms 2137 (diary-font-lock-date-forms
2138 calendar-bahai-month-name-array bahai-diary-entry-symbol)) 2138 calendar-bahai-month-name-array bahai-diary-entry-symbol))
@@ -2142,22 +2142,22 @@ names."
2142 'font-lock-keyword-face) 2142 'font-lock-keyword-face)
2143 (cons 2143 (cons
2144 (format "^%s?\\(%s\\)" (regexp-quote diary-nonmarking-symbol) 2144 (format "^%s?\\(%s\\)" (regexp-quote diary-nonmarking-symbol)
2145 (regexp-quote sexp-diary-entry-symbol)) 2145 (regexp-quote sexp-diary-entry-symbol))
2146 '(1 font-lock-reference-face)) 2146 '(1 font-lock-reference-face))
2147 (cons 2147 (cons
2148 (format "^%s" (regexp-quote diary-nonmarking-symbol)) 2148 (format "^%s" (regexp-quote diary-nonmarking-symbol))
2149 'font-lock-reference-face) 2149 'font-lock-reference-face)
2150 (cons 2150 (cons
2151 (format "^%s?%s" (regexp-quote diary-nonmarking-symbol) 2151 (format "^%s?%s" (regexp-quote diary-nonmarking-symbol)
2152 (regexp-opt (mapcar 'regexp-quote 2152 (regexp-opt (mapcar 'regexp-quote
2153 (list hebrew-diary-entry-symbol 2153 (list hebrew-diary-entry-symbol
2154 islamic-diary-entry-symbol 2154 islamic-diary-entry-symbol
2155 bahai-diary-entry-symbol)) 2155 bahai-diary-entry-symbol))
2156 t)) 2156 t))
2157 '(1 font-lock-reference-face)) 2157 '(1 font-lock-reference-face))
2158 '(diary-font-lock-sexps . font-lock-keyword-face) 2158 '(diary-font-lock-sexps . font-lock-keyword-face)
2159 `(,(format "\\(^\\|\\s-\\)%s\\(-%s\\)?" diary-time-regexp 2159 `(,(format "\\(^\\|\\s-\\)%s\\(-%s\\)?" diary-time-regexp
2160 diary-time-regexp) 2160 diary-time-regexp)
2161 . 'diary-time)))) 2161 . 'diary-time))))
2162 2162
2163(defvar diary-font-lock-keywords (diary-font-lock-keywords) 2163(defvar diary-font-lock-keywords (diary-font-lock-keywords)
@@ -2184,23 +2184,23 @@ message contains an appointment, don't make a diary entry."
2184 (catch 'finished 2184 (catch 'finished
2185 (let (format-string) 2185 (let (format-string)
2186 (dotimes (i (length diary-outlook-formats)) 2186 (dotimes (i (length diary-outlook-formats))
2187 (when (eq 0 (string-match (car (nth i diary-outlook-formats)) 2187 (when (eq 0 (string-match (car (nth i diary-outlook-formats))
2188 body)) 2188 body))
2189 (unless test-only 2189 (unless test-only
2190 (setq format-string (cdr (nth i diary-outlook-formats))) 2190 (setq format-string (cdr (nth i diary-outlook-formats)))
2191 (save-excursion 2191 (save-excursion
2192 (save-window-excursion 2192 (save-window-excursion
2193 ;; Fixme: References to optional fields in the format 2193 ;; Fixme: References to optional fields in the format
2194 ;; are treated literally, not replaced by the empty 2194 ;; are treated literally, not replaced by the empty
2195 ;; string. I think this is an Emacs bug. 2195 ;; string. I think this is an Emacs bug.
2196 (make-diary-entry 2196 (make-diary-entry
2197 (format (replace-match (if (functionp format-string) 2197 (format (replace-match (if (functionp format-string)
2198 (funcall format-string body) 2198 (funcall format-string body)
2199 format-string) 2199 format-string)
2200 t nil (match-string 0 body)) 2200 t nil (match-string 0 body))
2201 subject)) 2201 subject))
2202 (save-buffer)))) 2202 (save-buffer))))
2203 (throw 'finished t)))) 2203 (throw 'finished t))))
2204 nil)) 2204 nil))
2205 2205
2206(defun diary-from-outlook (&optional noconfirm) 2206(defun diary-from-outlook (&optional noconfirm)
@@ -2211,11 +2211,11 @@ function is called interactively), then if an entry is found the
2211user is asked to confirm its addition." 2211user is asked to confirm its addition."
2212 (interactive "p") 2212 (interactive "p")
2213 (let ((func (cond 2213 (let ((func (cond
2214 ((eq major-mode 'rmail-mode) 2214 ((eq major-mode 'rmail-mode)
2215 #'diary-from-outlook-rmail) 2215 #'diary-from-outlook-rmail)
2216 ((memq major-mode '(gnus-summary-mode gnus-article-mode)) 2216 ((memq major-mode '(gnus-summary-mode gnus-article-mode))
2217 #'diary-from-outlook-gnus) 2217 #'diary-from-outlook-gnus)
2218 (t (error "Don't know how to snarf in `%s'" major-mode))))) 2218 (t (error "Don't know how to snarf in `%s'" major-mode)))))
2219 (funcall func noconfirm))) 2219 (funcall func noconfirm)))
2220 2220
2221 2221
@@ -2236,17 +2236,17 @@ automatically."
2236 (interactive "p") 2236 (interactive "p")
2237 (with-current-buffer gnus-article-buffer 2237 (with-current-buffer gnus-article-buffer
2238 (let ((subject (gnus-fetch-field "subject")) 2238 (let ((subject (gnus-fetch-field "subject"))
2239 (body (if gnus-article-mime-handles 2239 (body (if gnus-article-mime-handles
2240 ;; We're multipart. Don't get confused by part 2240 ;; We're multipart. Don't get confused by part
2241 ;; buttons &c. Assume info is in first part. 2241 ;; buttons &c. Assume info is in first part.
2242 (mm-get-part (nth 1 gnus-article-mime-handles)) 2242 (mm-get-part (nth 1 gnus-article-mime-handles))
2243 (save-restriction 2243 (save-restriction
2244 (gnus-narrow-to-body) 2244 (gnus-narrow-to-body)
2245 (buffer-string))))) 2245 (buffer-string)))))
2246 (when (diary-from-outlook-internal t) 2246 (when (diary-from-outlook-internal t)
2247 (when (or noconfirm (y-or-n-p "Snarf diary entry? ")) 2247 (when (or noconfirm (y-or-n-p "Snarf diary entry? "))
2248 (diary-from-outlook-internal) 2248 (diary-from-outlook-internal)
2249 (message "Diary entry added")))))) 2249 (message "Diary entry added"))))))
2250 2250
2251(custom-add-option 'gnus-article-prepare-hook 'diary-from-outlook-gnus) 2251(custom-add-option 'gnus-article-prepare-hook 'diary-from-outlook-gnus)
2252 2252
@@ -2261,14 +2261,14 @@ user is asked to confirm its addition."
2261 (interactive "p") 2261 (interactive "p")
2262 (with-current-buffer rmail-buffer 2262 (with-current-buffer rmail-buffer
2263 (let ((subject (mail-fetch-field "subject")) 2263 (let ((subject (mail-fetch-field "subject"))
2264 (body (buffer-substring (save-excursion 2264 (body (buffer-substring (save-excursion
2265 (rfc822-goto-eoh) 2265 (rfc822-goto-eoh)
2266 (point)) 2266 (point))
2267 (point-max)))) 2267 (point-max))))
2268 (when (diary-from-outlook-internal t) 2268 (when (diary-from-outlook-internal t)
2269 (when (or noconfirm (y-or-n-p "Snarf diary entry? ")) 2269 (when (or noconfirm (y-or-n-p "Snarf diary entry? "))
2270 (diary-from-outlook-internal) 2270 (diary-from-outlook-internal)
2271 (message "Diary entry added")))))) 2271 (message "Diary entry added"))))))
2272 2272
2273 2273
2274(provide 'diary-lib) 2274(provide 'diary-lib)
diff --git a/lisp/calendar/lunar.el b/lisp/calendar/lunar.el
index 3d01fbd0ce6..92b146b185c 100644
--- a/lisp/calendar/lunar.el
+++ b/lisp/calendar/lunar.el
@@ -165,14 +165,14 @@ remainder mod 4 gives the phase: 0 new moon, 1 first quarter, 2 full moon,
165 ((= phase 2) (- adjustment adj)) 165 ((= phase 2) (- adjustment adj))
166 (t adjustment))) 166 (t adjustment)))
167 (date (+ date adjustment)) 167 (date (+ date adjustment))
168 (date (+ date (/ (- calendar-time-zone 168 (date (+ date (/ (- calendar-time-zone
169 (solar-ephemeris-correction 169 (solar-ephemeris-correction
170 (extract-calendar-year 170 (extract-calendar-year
171 (calendar-gregorian-from-absolute 171 (calendar-gregorian-from-absolute
172 (truncate date))))) 172 (truncate date)))))
173 60.0 24.0))) 173 60.0 24.0)))
174 (time (* 24 (- date (truncate date)))) 174 (time (* 24 (- date (truncate date))))
175 (date (calendar-gregorian-from-absolute (truncate date))) 175 (date (calendar-gregorian-from-absolute (truncate date)))
176 (adj (dst-adjust-time date time))) 176 (adj (dst-adjust-time date time)))
177 (list (car adj) (apply 'solar-time-string (cdr adj)) phase))) 177 (list (car adj) (apply 'solar-time-string (cdr adj)) phase)))
178 178
@@ -261,103 +261,103 @@ use when highlighting the day in the calendar."
261(defun lunar-new-moon-time (k) 261(defun lunar-new-moon-time (k)
262 "Astronomical (Julian) day number of K th new moon." 262 "Astronomical (Julian) day number of K th new moon."
263 (let* ((T (/ k 1236.85)) 263 (let* ((T (/ k 1236.85))
264 (T2 (* T T)) 264 (T2 (* T T))
265 (T3 (* T T T)) 265 (T3 (* T T T))
266 (T4 (* T2 T2)) 266 (T4 (* T2 T2))
267 (JDE (+ 2451550.09765 267 (JDE (+ 2451550.09765
268 (* 29.530588853 k) 268 (* 29.530588853 k)
269 (* 0.0001337 T2) 269 (* 0.0001337 T2)
270 (* -0.000000150 T3) 270 (* -0.000000150 T3)
271 (* 0.00000000073 T4))) 271 (* 0.00000000073 T4)))
272 (E (- 1 (* 0.002516 T) (* 0.0000074 T2))) 272 (E (- 1 (* 0.002516 T) (* 0.0000074 T2)))
273 (sun-anomaly (+ 2.5534 273 (sun-anomaly (+ 2.5534
274 (* 29.10535669 k) 274 (* 29.10535669 k)
275 (* -0.0000218 T2) 275 (* -0.0000218 T2)
276 (* -0.00000011 T3))) 276 (* -0.00000011 T3)))
277 (moon-anomaly (+ 201.5643 277 (moon-anomaly (+ 201.5643
278 (* 385.81693528 k) 278 (* 385.81693528 k)
279 (* 0.0107438 T2) 279 (* 0.0107438 T2)
280 (* 0.00001239 T3) 280 (* 0.00001239 T3)
281 (* -0.000000058 T4))) 281 (* -0.000000058 T4)))
282 (moon-argument (+ 160.7108 282 (moon-argument (+ 160.7108
283 (* 390.67050274 k) 283 (* 390.67050274 k)
284 (* -0.0016341 T2) 284 (* -0.0016341 T2)
285 (* -0.00000227 T3) 285 (* -0.00000227 T3)
286 (* 0.000000011 T4))) 286 (* 0.000000011 T4)))
287 (omega (+ 124.7746 287 (omega (+ 124.7746
288 (* -1.56375580 k) 288 (* -1.56375580 k)
289 (* 0.0020691 T2) 289 (* 0.0020691 T2)
290 (* 0.00000215 T3))) 290 (* 0.00000215 T3)))
291 (A1 (+ 299.77 (* 0.107408 k) (* -0.009173 T2))) 291 (A1 (+ 299.77 (* 0.107408 k) (* -0.009173 T2)))
292 (A2 (+ 251.88 (* 0.016321 k))) 292 (A2 (+ 251.88 (* 0.016321 k)))
293 (A3 (+ 251.83 (* 26.641886 k))) 293 (A3 (+ 251.83 (* 26.641886 k)))
294 (A4 (+ 349.42 (* 36.412478 k))) 294 (A4 (+ 349.42 (* 36.412478 k)))
295 (A5 (+ 84.66 (* 18.206239 k))) 295 (A5 (+ 84.66 (* 18.206239 k)))
296 (A6 (+ 141.74 (* 53.303771 k))) 296 (A6 (+ 141.74 (* 53.303771 k)))
297 (A7 (+ 207.14 (* 2.453732 k))) 297 (A7 (+ 207.14 (* 2.453732 k)))
298 (A8 (+ 154.84 (* 7.306860 k))) 298 (A8 (+ 154.84 (* 7.306860 k)))
299 (A9 (+ 34.52 (* 27.261239 k))) 299 (A9 (+ 34.52 (* 27.261239 k)))
300 (A10 (+ 207.19 (* 0.121824 k))) 300 (A10 (+ 207.19 (* 0.121824 k)))
301 (A11 (+ 291.34 (* 1.844379 k))) 301 (A11 (+ 291.34 (* 1.844379 k)))
302 (A12 (+ 161.72 (* 24.198154 k))) 302 (A12 (+ 161.72 (* 24.198154 k)))
303 (A13 (+ 239.56 (* 25.513099 k))) 303 (A13 (+ 239.56 (* 25.513099 k)))
304 (A14 (+ 331.55 (* 3.592518 k))) 304 (A14 (+ 331.55 (* 3.592518 k)))
305 (correction 305 (correction
306 (+ (* -0.40720 (solar-sin-degrees moon-anomaly)) 306 (+ (* -0.40720 (solar-sin-degrees moon-anomaly))
307 (* 0.17241 E (solar-sin-degrees sun-anomaly)) 307 (* 0.17241 E (solar-sin-degrees sun-anomaly))
308 (* 0.01608 (solar-sin-degrees (* 2 moon-anomaly))) 308 (* 0.01608 (solar-sin-degrees (* 2 moon-anomaly)))
309 (* 0.01039 (solar-sin-degrees (* 2 moon-argument))) 309 (* 0.01039 (solar-sin-degrees (* 2 moon-argument)))
310 (* 0.00739 E (solar-sin-degrees (- moon-anomaly sun-anomaly))) 310 (* 0.00739 E (solar-sin-degrees (- moon-anomaly sun-anomaly)))
311 (* -0.00514 E (solar-sin-degrees (+ moon-anomaly sun-anomaly))) 311 (* -0.00514 E (solar-sin-degrees (+ moon-anomaly sun-anomaly)))
312 (* 0.00208 E E (solar-sin-degrees (* 2 sun-anomaly))) 312 (* 0.00208 E E (solar-sin-degrees (* 2 sun-anomaly)))
313 (* -0.00111 (solar-sin-degrees 313 (* -0.00111 (solar-sin-degrees
314 (- moon-anomaly (* 2 moon-argument)))) 314 (- moon-anomaly (* 2 moon-argument))))
315 (* -0.00057 (solar-sin-degrees 315 (* -0.00057 (solar-sin-degrees
316 (+ moon-anomaly (* 2 moon-argument)))) 316 (+ moon-anomaly (* 2 moon-argument))))
317 (* 0.00056 E (solar-sin-degrees 317 (* 0.00056 E (solar-sin-degrees
318 (+ (* 2 moon-anomaly) sun-anomaly))) 318 (+ (* 2 moon-anomaly) sun-anomaly)))
319 (* -0.00042 (solar-sin-degrees (* 3 moon-anomaly))) 319 (* -0.00042 (solar-sin-degrees (* 3 moon-anomaly)))
320 (* 0.00042 E (solar-sin-degrees 320 (* 0.00042 E (solar-sin-degrees
321 (+ sun-anomaly (* 2 moon-argument)))) 321 (+ sun-anomaly (* 2 moon-argument))))
322 (* 0.00038 E (solar-sin-degrees 322 (* 0.00038 E (solar-sin-degrees
323 (- sun-anomaly (* 2 moon-argument)))) 323 (- sun-anomaly (* 2 moon-argument))))
324 (* -0.00024 E (solar-sin-degrees 324 (* -0.00024 E (solar-sin-degrees
325 (- (* 2 moon-anomaly) sun-anomaly))) 325 (- (* 2 moon-anomaly) sun-anomaly)))
326 (* -0.00017 (solar-sin-degrees omega)) 326 (* -0.00017 (solar-sin-degrees omega))
327 (* -0.00007 (solar-sin-degrees 327 (* -0.00007 (solar-sin-degrees
328 (+ moon-anomaly (* 2 sun-anomaly)))) 328 (+ moon-anomaly (* 2 sun-anomaly))))
329 (* 0.00004 (solar-sin-degrees 329 (* 0.00004 (solar-sin-degrees
330 (- (* 2 moon-anomaly) (* 2 moon-argument)))) 330 (- (* 2 moon-anomaly) (* 2 moon-argument))))
331 (* 0.00004 (solar-sin-degrees (* 3 sun-anomaly))) 331 (* 0.00004 (solar-sin-degrees (* 3 sun-anomaly)))
332 (* 0.00003 (solar-sin-degrees (+ moon-anomaly sun-anomaly 332 (* 0.00003 (solar-sin-degrees (+ moon-anomaly sun-anomaly
333 (* -2 moon-argument)))) 333 (* -2 moon-argument))))
334 (* 0.00003 (solar-sin-degrees 334 (* 0.00003 (solar-sin-degrees
335 (+ (* 2 moon-anomaly) (* 2 moon-argument)))) 335 (+ (* 2 moon-anomaly) (* 2 moon-argument))))
336 (* -0.00003 (solar-sin-degrees (+ moon-anomaly sun-anomaly 336 (* -0.00003 (solar-sin-degrees (+ moon-anomaly sun-anomaly
337 (* 2 moon-argument)))) 337 (* 2 moon-argument))))
338 (* 0.00003 (solar-sin-degrees (- moon-anomaly sun-anomaly 338 (* 0.00003 (solar-sin-degrees (- moon-anomaly sun-anomaly
339 (* -2 moon-argument)))) 339 (* -2 moon-argument))))
340 (* -0.00002 (solar-sin-degrees (- moon-anomaly sun-anomaly 340 (* -0.00002 (solar-sin-degrees (- moon-anomaly sun-anomaly
341 (* 2 moon-argument)))) 341 (* 2 moon-argument))))
342 (* -0.00002 (solar-sin-degrees 342 (* -0.00002 (solar-sin-degrees
343 (+ (* 3 moon-anomaly) sun-anomaly))) 343 (+ (* 3 moon-anomaly) sun-anomaly)))
344 (* 0.00002 (solar-sin-degrees (* 4 moon-anomaly))))) 344 (* 0.00002 (solar-sin-degrees (* 4 moon-anomaly)))))
345 (additional 345 (additional
346 (+ (* 0.000325 (solar-sin-degrees A1)) 346 (+ (* 0.000325 (solar-sin-degrees A1))
347 (* 0.000165 (solar-sin-degrees A2)) 347 (* 0.000165 (solar-sin-degrees A2))
348 (* 0.000164 (solar-sin-degrees A3)) 348 (* 0.000164 (solar-sin-degrees A3))
349 (* 0.000126 (solar-sin-degrees A4)) 349 (* 0.000126 (solar-sin-degrees A4))
350 (* 0.000110 (solar-sin-degrees A5)) 350 (* 0.000110 (solar-sin-degrees A5))
351 (* 0.000062 (solar-sin-degrees A6)) 351 (* 0.000062 (solar-sin-degrees A6))
352 (* 0.000060 (solar-sin-degrees A7)) 352 (* 0.000060 (solar-sin-degrees A7))
353 (* 0.000056 (solar-sin-degrees A8)) 353 (* 0.000056 (solar-sin-degrees A8))
354 (* 0.000047 (solar-sin-degrees A9)) 354 (* 0.000047 (solar-sin-degrees A9))
355 (* 0.000042 (solar-sin-degrees A10)) 355 (* 0.000042 (solar-sin-degrees A10))
356 (* 0.000040 (solar-sin-degrees A11)) 356 (* 0.000040 (solar-sin-degrees A11))
357 (* 0.000037 (solar-sin-degrees A12)) 357 (* 0.000037 (solar-sin-degrees A12))
358 (* 0.000035 (solar-sin-degrees A13)) 358 (* 0.000035 (solar-sin-degrees A13))
359 (* 0.000023 (solar-sin-degrees A14)))) 359 (* 0.000023 (solar-sin-degrees A14))))
360 (newJDE (+ JDE correction additional))) 360 (newJDE (+ JDE correction additional)))
361 (+ newJDE 361 (+ newJDE
362 (- (solar-ephemeris-correction 362 (- (solar-ephemeris-correction
363 (extract-calendar-year 363 (extract-calendar-year
@@ -377,8 +377,8 @@ calendar-time-zone."
377 (let* ((date (calendar-gregorian-from-absolute 377 (let* ((date (calendar-gregorian-from-absolute
378 (floor (calendar-absolute-from-astro d)))) 378 (floor (calendar-absolute-from-astro d))))
379 (year (+ (extract-calendar-year date) 379 (year (+ (extract-calendar-year date)
380 (/ (calendar-day-number date) 365.25))) 380 (/ (calendar-day-number date) 365.25)))
381 (k (floor (* (- year 2000.0) 12.3685))) 381 (k (floor (* (- year 2000.0) 12.3685)))
382 (date (lunar-new-moon-time k))) 382 (date (lunar-new-moon-time k)))
383 (while (< date d) 383 (while (< date d)
384 (setq k (1+ k)) 384 (setq k (1+ k))