;;; cal-dst.el --- calendar functions for daylight saving rules
;; Copyright (C) 1993, 1994, 1995, 1996, 2001, 2002, 2003, 2004, 2005,
-;; 2006, 2007 Free Software Foundation, Inc.
+;; 2006, 2007, 2008 Free Software Foundation, Inc.
;; Author: Paul Eggert <eggert@twinsun.com>
-;; Edward M. Reingold <reingold@cs.uiuc.edu>
+;; Edward M. Reingold <reingold@cs.uiuc.edu>
;; Maintainer: Glenn Morris <rgm@gnu.org>
;; Keywords: calendar
;; Human-Keywords: daylight saving time, calendar, diary, holidays
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
+;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;;; Commentary:
-;; This collection of functions implements the features of calendar.el and
-;; holiday.el that deal with daylight saving time.
+;; See calendar.el.
;;; Code:
(require 'calendar)
-(require 'cal-persia)
+
+
+(defgroup calendar-dst nil
+ "Options related to Daylight Saving Time."
+ :prefix "calendar-"
+ :group 'calendar)
+
(defcustom calendar-dst-check-each-year-flag t
"Non-nil means to check each year for DST transitions as needed.
:version "22.1"
:group 'calendar)
+;;;###autoload
+(put 'calendar-daylight-savings-starts 'risky-local-variable t)
+(defcustom calendar-daylight-savings-starts '(calendar-dst-starts year)
+ "Sexp giving the date on which daylight saving time starts.
+This is an expression in the variable `year' whose value gives the Gregorian
+date in the form (month day year) on which daylight saving time starts. It is
+used to determine the starting date of daylight saving time for the holiday
+list and for correcting times of day in the solar and lunar calculations.
+
+For example, if daylight saving time is mandated to start on October 1,
+you would set `calendar-daylight-savings-starts' to
+
+ '(10 1 year)
+
+If it starts on the first Sunday in April, you would set it to
+
+ '(calendar-nth-named-day 1 0 4 year)
+
+If the locale never uses daylight saving time, set this to nil."
+ :type 'sexp
+ :group 'calendar-dst)
+
+;;;###autoload
+(put 'calendar-daylight-savings-ends 'risky-local-variable t)
+(defcustom calendar-daylight-savings-ends '(calendar-dst-ends year)
+ "Sexp giving the date on which daylight saving time ends.
+This is an expression in the variable `year' whose value gives the Gregorian
+date in the form (month day year) on which daylight saving time ends. It is
+used to determine the starting date of daylight saving time for the holiday
+list and for correcting times of day in the solar and lunar calculations.
+
+For example, if daylight saving time ends on the last Sunday in October:
+
+ '(calendar-nth-named-day -1 0 10 year)
+
+If the locale never uses daylight saving time, set this to nil."
+ :type 'sexp
+ :group 'calendar-dst)
+
+;;; More defcustoms below.
+
+
(defvar calendar-current-time-zone-cache nil
"Cache for result of `calendar-current-time-zone'.")
-(put 'calendar-current-time-zone-cache 'risky-local-variable t)
+(put 'calendar-current-time-zone-cache 'risky-local-variable t) ; why?
(defvar calendar-system-time-basis
(calendar-absolute-from-gregorian '(1 1 1970))
Returns the pair (ABS-DATE . SECONDS) where SECONDS after local midnight on
absolute date ABS-DATE is the equivalent moment to X."
(let* ((h (car x))
- (xtail (cdr x))
+ (xtail (cdr x))
(l (+ utc-diff (if (numberp xtail) xtail (car xtail))))
(u (+ (* 512 (mod h 675)) (floor l 128))))
;; Overflow is a terrible thing!
(cons (+ calendar-system-time-basis
- ;; floor((2^16 h +l) / (60*60*24))
- (* 512 (floor h 675)) (floor u 675))
- ;; (2^16 h +l) mod (60*60*24)
- (+ (* (mod u 675) 128) (mod l 128)))))
+ ;; floor((2^16 h +l) / (60*60*24))
+ (* 512 (floor h 675)) (floor u 675))
+ ;; (2^16 h +l) mod (60*60*24)
+ (+ (* (mod u 675) 128) (mod l 128)))))
(defun calendar-time-from-absolute (abs-date s)
"Time of absolute date ABS-DATE, S seconds after midnight.
(defun calendar-next-time-zone-transition (time)
"Return the time of the next time zone transition after TIME.
-Both TIME and the result are acceptable arguments to current-time-zone.
+Both TIME and the result are acceptable arguments to `current-time-zone'.
Return nil if no such transition can be found."
- (let* ((base 65536);; 2^16 = base of current-time output
- (quarter-multiple 120);; approx = (seconds per quarter year) / base
- (time-zone (current-time-zone time))
- (time-utc-diff (car time-zone))
+ (let* ((base 65536) ; 2^16 = base of current-time output
+ (quarter-multiple 120) ; approx = (seconds per quarter year) / base
+ (time-zone (current-time-zone time))
+ (time-utc-diff (car time-zone))
hi
- hi-zone
+ hi-zone
(hi-utc-diff time-utc-diff)
(quarters '(2 1 3)))
;; Heuristic: probe the time zone offset in the next three calendar
;; quarters, looking for a time zone offset different from TIME.
(while (and quarters (eq time-utc-diff hi-utc-diff))
- (setq hi (cons (+ (car time) (* (car quarters) quarter-multiple)) 0))
- (setq hi-zone (current-time-zone hi))
- (setq hi-utc-diff (car hi-zone))
- (setq quarters (cdr quarters)))
+ (setq hi (cons (+ (car time) (* (car quarters) quarter-multiple)) 0)
+ hi-zone (current-time-zone hi)
+ hi-utc-diff (car hi-zone)
+ quarters (cdr quarters)))
(and
time-utc-diff
hi-utc-diff
;; Set LO to TIME, and then binary search to increase LO and decrease HI
;; until LO is just before and HI is just after the time zone transition.
(let* ((tail (cdr time))
- (lo (cons (car time) (if (numberp tail) tail (car tail))))
- probe)
+ (lo (cons (car time) (if (numberp tail) tail (car tail))))
+ probe)
(while
- ;; Set PROBE to halfway between LO and HI, rounding down.
- ;; If PROBE equals LO, we are done.
- (let* ((lsum (+ (cdr lo) (cdr hi)))
- (hsum (+ (car lo) (car hi) (/ lsum base)))
- (hsumodd (logand 1 hsum)))
- (setq probe (cons (/ (- hsum hsumodd) 2)
- (/ (+ (* hsumodd base) (% lsum base)) 2)))
- (not (equal lo probe)))
- ;; Set either LO or HI to PROBE, depending on probe results.
- (if (eq (car (current-time-zone probe)) hi-utc-diff)
- (setq hi probe)
- (setq lo probe)))
+ ;; Set PROBE to halfway between LO and HI, rounding down.
+ ;; If PROBE equals LO, we are done.
+ (let* ((lsum (+ (cdr lo) (cdr hi)))
+ (hsum (+ (car lo) (car hi) (/ lsum base)))
+ (hsumodd (logand 1 hsum)))
+ (setq probe (cons (/ (- hsum hsumodd) 2)
+ (/ (+ (* hsumodd base) (% lsum base)) 2)))
+ (not (equal lo probe)))
+ ;; Set either LO or HI to PROBE, depending on probe results.
+ (if (eq (car (current-time-zone probe)) hi-utc-diff)
+ (setq hi probe)
+ (setq lo probe)))
hi))))
+(autoload 'calendar-persian-to-absolute "cal-persia")
+
(defun calendar-time-zone-daylight-rules (abs-date utc-diff)
"Return daylight transition rule for ABS-DATE, UTC-DIFF sec offset from UTC.
ABS-DATE must specify a day that contains a daylight saving transition.
The result has the proper form for `calendar-daylight-savings-starts'."
(let* ((date (calendar-gregorian-from-absolute abs-date))
- (weekday (% abs-date 7))
- (m (extract-calendar-month date))
- (d (extract-calendar-day date))
- (y (extract-calendar-year date))
+ (weekday (% abs-date 7))
+ (m (extract-calendar-month date))
+ (d (extract-calendar-day date))
+ (y (extract-calendar-year date))
(last (calendar-last-day-of-month m y))
- (candidate-rules
- (append
- ;; Day D of month M.
- (list (list 'list m d 'year))
- ;; The first WEEKDAY of month M.
+ j rlist
+ (candidate-rules ; these return Gregorian dates
+ (append
+ ;; Day D of month M.
+ `((list ,m ,d year))
+ ;; The first WEEKDAY of month M.
(if (< d 8)
- (list (list 'calendar-nth-named-day 1 weekday m 'year)))
- ;; The last WEEKDAY of month M.
+ `((calendar-nth-named-day 1 ,weekday ,m year)))
+ ;; The last WEEKDAY of month M.
(if (> d (- last 7))
- (list (list 'calendar-nth-named-day -1 weekday m 'year)))
- ;; The first WEEKDAY after day J of month M, for D-6 < J <= D.
- (let (l)
- (calendar-for-loop j from (max 2 (- d 6)) to (min d (- last 8)) do
- (setq l
- (cons
- (list 'calendar-nth-named-day 1 weekday m 'year j)
- l)))
- l)
- ;; 01-01 and 07-01 for this year's Persian calendar.
- (if (and (= m 3) (<= 20 d) (<= d 21))
- '((calendar-gregorian-from-absolute
- (calendar-absolute-from-persian
- (list 1 1 (- year 621))))))
- (if (and (= m 9) (<= 22 d) (<= d 23))
- '((calendar-gregorian-from-absolute
- (calendar-absolute-from-persian
- (list 7 1 (- year 621))))))))
- (prevday-sec (- -1 utc-diff)) ;; last sec of previous local day
- (year (1+ y)))
+ `((calendar-nth-named-day -1 ,weekday ,m year)))
+ (progn
+ ;; The first WEEKDAY after day J of month M, for D-6 < J <= D.
+ (setq j (1- (max 2 (- d 6))))
+ (while (<= (setq j (1+ j)) (min d (- last 8)))
+ (push `(calendar-nth-named-day 1 ,weekday ,m year ,j) rlist))
+ rlist)
+ ;; 01-01 and 07-01 for this year's Persian calendar.
+ ;; FIXME what does the Persian calendar have to do with this?
+ (if (and (= m 3) (<= 20 d) (<= d 21))
+ '((calendar-gregorian-from-absolute
+ (calendar-persian-to-absolute `(1 1 ,(- year 621))))))
+ (if (and (= m 9) (<= 22 d) (<= d 23))
+ '((calendar-gregorian-from-absolute
+ (calendar-persian-to-absolute `(7 1 ,(- year 621))))))))
+ (prevday-sec (- -1 utc-diff)) ; last sec of previous local day
+ (year (1+ y))
+ new-rules)
;; Scan through the next few years until only one rule remains.
- (while
- (let ((rules candidate-rules)
- new-rules)
- (while
- (let*
- ((rule (car rules))
- (date
- ;; The following is much faster than
- ;; (calendar-absolute-from-gregorian (eval rule)).
- (cond ((eq (car rule) 'calendar-nth-named-day)
- (eval (cons 'calendar-nth-named-absday (cdr rule))))
- ((eq (car rule) 'calendar-gregorian-from-absolute)
- (eval (car (cdr rule))))
- (t (let ((g (eval rule)))
- (calendar-absolute-from-gregorian g))))))
- (or (equal
- (current-time-zone
- (calendar-time-from-absolute date prevday-sec))
- (current-time-zone
- (calendar-time-from-absolute (1+ date) prevday-sec)))
- (setq new-rules (cons rule new-rules)))
- (setq rules (cdr rules))))
- ;; If no rules remain, just use the first candidate rule;
- ;; it's wrong in general, but it's right for at least one year.
- (setq candidate-rules (if new-rules (nreverse new-rules)
- (list (car candidate-rules))))
- (setq year (1+ year))
- (cdr candidate-rules)))
+ (while (cdr candidate-rules)
+ (dolist (rule candidate-rules)
+ ;; The rule we return should give a Gregorian date, but here
+ ;; we require an absolute date. The following is for efficiency.
+ (setq date (cond ((eq (car rule) 'calendar-nth-named-day)
+ (eval (cons 'calendar-nth-named-absday (cdr rule))))
+ ((eq (car rule) 'calendar-gregorian-from-absolute)
+ (eval (cdr rule)))
+ (t (calendar-absolute-from-gregorian (eval rule)))))
+ (or (equal (current-time-zone
+ (calendar-time-from-absolute date prevday-sec))
+ (current-time-zone
+ (calendar-time-from-absolute (1+ date) prevday-sec)))
+ (setq new-rules (cons rule new-rules))))
+ ;; If no rules remain, just use the first candidate rule;
+ ;; it's wrong in general, but it's right for at least one year.
+ (setq candidate-rules (if new-rules (nreverse new-rules)
+ (list (car candidate-rules)))
+ new-rules nil
+ year (1+ year)))
(car candidate-rules)))
;; TODO it might be better to extract this information directly from
(let* ((t0 (or time (current-time)))
(t0-zone (current-time-zone t0))
(t0-utc-diff (car t0-zone))
- (t0-name (car (cdr t0-zone))))
+ (t0-name (cadr t0-zone)))
(if (not t0-utc-diff)
;; Little or no time zone information is available.
(list nil nil t0-name t0-name nil nil nil nil)
;; Use heuristics to find daylight saving parameters.
(let* ((t1-zone (current-time-zone t1))
(t1-utc-diff (car t1-zone))
- (t1-name (car (cdr t1-zone)))
+ (t1-name (cadr t1-zone))
(t1-date-sec (calendar-absolute-from-time t1 t0-utc-diff))
(t2-date-sec (calendar-absolute-from-time t2 t1-utc-diff))
;; TODO When calendar-dst-check-each-year-flag is non-nil,
"Internal cal-dst variable storing date of daylight saving time transitions.
Value is a list with elements of the form (YEAR START END), where
START and END are expressions that when evaluated return the
-start and end dates (respectively) for DST in YEAR. Used by the
+start and end dates (respectively) for DST in YEAR. Used by the
function `calendar-dst-find-startend'.")
(defun calendar-dst-find-startend (year)
(unless calendar-current-time-zone-cache
(setq calendar-current-time-zone-cache (calendar-dst-find-data))))
-;;; The following eight defvars relating to daylight saving time should NOT be
-;;; marked to go into loaddefs.el where they would be evaluated when Emacs is
-;;; dumped. These variables' appropriate values depend on the conditions under
-;;; which the code is INVOKED; so it's inappropriate to initialize them when
-;;; Emacs is dumped---they should be initialized when calendar.el is loaded.
-;;; They default to US Eastern time if time zone info is not available.
-
-(calendar-current-time-zone)
-(defvar calendar-time-zone (or (car calendar-current-time-zone-cache) -300)
- "*Number of minutes difference between local standard time at
-`calendar-location-name' and Coordinated Universal (Greenwich) Time. For
-example, -300 for New York City, -480 for Los Angeles.")
+;; Following options should be set based on conditions when the code
+;; is invoked, so are not suitable for dumping into loaddefs.el. They
+;; default to US Eastern time if time zone info is not available.
-(defvar calendar-daylight-time-offset
- (or (car (cdr calendar-current-time-zone-cache)) 60)
- "*Number of minutes difference between daylight saving and standard time.
-
-If the locale never uses daylight saving time, set this to 0.")
-
-(defvar calendar-standard-time-zone-name
- (or (car (nthcdr 2 calendar-current-time-zone-cache)) "EST")
- "*Abbreviated name of standard time zone at `calendar-location-name'.
-For example, \"EST\" in New York City, \"PST\" for Los Angeles.")
+(calendar-current-time-zone)
-(defvar calendar-daylight-time-zone-name
- (or (car (nthcdr 3 calendar-current-time-zone-cache)) "EDT")
- "*Abbreviated name of daylight saving time zone at `calendar-location-name'.
-For example, \"EDT\" in New York City, \"PDT\" for Los Angeles.")
+(defcustom calendar-time-zone (or (car calendar-current-time-zone-cache) -300)
+ "Number of minutes difference between local standard time and UTC.
+For example, -300 for New York City, -480 for Los Angeles."
+ :type 'integer
+ :group 'calendar-dst)
+
+(defcustom calendar-daylight-time-offset
+ (or (cadr calendar-current-time-zone-cache) 60)
+ "Number of minutes difference between daylight saving and standard time.
+If the locale never uses daylight saving time, set this to 0."
+ :type 'integer
+ :group 'calendar-dst)
+
+(defcustom calendar-standard-time-zone-name
+ (or (nth 2 calendar-current-time-zone-cache) "EST")
+ "Abbreviated name of standard time zone at `calendar-location-name'.
+For example, \"EST\" in New York City, \"PST\" for Los Angeles."
+ :type 'string
+ :group 'calendar-dst)
+
+(defcustom calendar-daylight-time-zone-name
+ (or (nth 3 calendar-current-time-zone-cache) "EDT")
+ "Abbreviated name of daylight saving time zone at `calendar-location-name'.
+For example, \"EDT\" in New York City, \"PDT\" for Los Angeles."
+ :type 'string
+ :group 'calendar-dst)
+
+(defcustom calendar-daylight-savings-starts-time
+ (or (nth 6 calendar-current-time-zone-cache) 120)
+ "Number of minutes after midnight that daylight saving time starts."
+ :type 'integer
+ :group 'calendar-dst)
+
+(defcustom calendar-daylight-savings-ends-time
+ (or (nth 7 calendar-current-time-zone-cache)
+ calendar-daylight-savings-starts-time)
+ "Number of minutes after midnight that daylight saving time ends."
+ :type 'integer
+ :group 'calendar-dst)
(defun calendar-dst-starts (year)
(cadr (calendar-dst-find-startend year))
(nth 4 calendar-current-time-zone-cache))))
(if expr (eval expr)))
- ;; New US rules commencing 2007. ftp://elsie.nci.nih.gov/pub/.
+ ;; New US rules commencing 2007. ftp://elsie.nci.nih.gov/pub/.
(and (not (zerop calendar-daylight-time-offset))
(calendar-nth-named-day 2 0 3 year))))
(nth 2 (calendar-dst-find-startend year))
(nth 5 calendar-current-time-zone-cache))))
(if expr (eval expr)))
- ;; New US rules commencing 2007. ftp://elsie.nci.nih.gov/pub/.
+ ;; New US rules commencing 2007. ftp://elsie.nci.nih.gov/pub/.
(and (not (zerop calendar-daylight-time-offset))
(calendar-nth-named-day 1 0 11 year))))
-
-;;;###autoload
-(put 'calendar-daylight-savings-starts 'risky-local-variable t)
-(defvar calendar-daylight-savings-starts
- '(calendar-dst-starts year)
- "*Sexp giving the date on which daylight saving time starts.
-This is an expression in the variable `year' whose value gives the Gregorian
-date in the form (month day year) on which daylight saving time starts. It is
-used to determine the starting date of daylight saving time for the holiday
-list and for correcting times of day in the solar and lunar calculations.
-
-For example, if daylight saving time is mandated to start on October 1,
-you would set `calendar-daylight-savings-starts' to
-
- '(10 1 year)
-
-If it starts on the first Sunday in April, you would set it to
-
- '(calendar-nth-named-day 1 0 4 year)
-
-If the locale never uses daylight saving time, set this to nil.")
-
-;;;###autoload
-(put 'calendar-daylight-savings-ends 'risky-local-variable t)
-(defvar calendar-daylight-savings-ends
- '(calendar-dst-ends year)
- "*Sexp giving the date on which daylight saving time ends.
-This is an expression in the variable `year' whose value gives the Gregorian
-date in the form (month day year) on which daylight saving time ends. It is
-used to determine the starting date of daylight saving time for the holiday
-list and for correcting times of day in the solar and lunar calculations.
-
-For example, if daylight saving time ends on the last Sunday in October:
-
- '(calendar-nth-named-day -1 0 10 year)
-
-If the locale never uses daylight saving time, set this to nil.")
-
-(defvar calendar-daylight-savings-starts-time
- (or (car (nthcdr 6 calendar-current-time-zone-cache)) 120)
- "*Number of minutes after midnight that daylight saving time starts.")
-
-(defvar calendar-daylight-savings-ends-time
- (or (car (nthcdr 7 calendar-current-time-zone-cache))
- calendar-daylight-savings-starts-time)
- "*Number of minutes after midnight that daylight saving time ends.")
-
(defun dst-in-effect (date)
"True if on absolute DATE daylight saving time is in effect.
Fractional part of DATE is local standard time of day."
Conversion to daylight saving time is done according to
`calendar-daylight-savings-starts', `calendar-daylight-savings-ends',
`calendar-daylight-savings-starts-time',
-`calendar-daylight-savings-ends-time', and
-`calendar-daylight-savings-offset'."
+`calendar-daylight-savings-ends-time', and `calendar-daylight-time-offset'."
(let* ((rounded-abs-date (+ (calendar-absolute-from-gregorian date)
- (/ (round (* 60 time)) 60.0 24.0)))
+ (/ (round (* 60 time)) 60.0 24.0)))
(dst (dst-in-effect rounded-abs-date))
- (time-zone (if dst
- calendar-daylight-time-zone-name
- calendar-standard-time-zone-name))
- (time (+ rounded-abs-date
+ (time-zone (if dst
+ calendar-daylight-time-zone-name
+ calendar-standard-time-zone-name))
+ (time (+ rounded-abs-date
(if dst (/ calendar-daylight-time-offset 24.0 60.0) 0))))
(list (calendar-gregorian-from-absolute (truncate time))
(* 24.0 (- time (truncate time)))
(provide 'cal-dst)
-;;; arch-tag: a141d204-213c-4ca5-bdc6-f9df3aa92aad
+;; arch-tag: a141d204-213c-4ca5-bdc6-f9df3aa92aad
;;; cal-dst.el ends here
HCoop / bpt / emacs.git / blobdiff