diff options
Diffstat (limited to 'lisp/calendar/cal-dst.el')
| -rw-r--r-- | lisp/calendar/cal-dst.el | 157 |
1 files changed, 68 insertions, 89 deletions
diff --git a/lisp/calendar/cal-dst.el b/lisp/calendar/cal-dst.el index e78f19f803f..567ba9c8a12 100644 --- a/lisp/calendar/cal-dst.el +++ b/lisp/calendar/cal-dst.el @@ -1,4 +1,4 @@ -;;; cal-dst.el --- calendar functions for daylight saving rules +;;; cal-dst.el --- calendar functions for daylight saving rules -*- lexical-binding:t -*- ;; Copyright (C) 1993-1996, 2001-2019 Free Software Foundation, Inc. @@ -97,62 +97,48 @@ If the locale never uses daylight saving time, set this to nil." ;;;###autoload (put 'calendar-current-time-zone-cache 'risky-local-variable t) -(defvar calendar-system-time-basis +(defconst calendar-system-time-basis (calendar-absolute-from-gregorian '(1 1 1970)) "Absolute date of starting date of system clock.") (defun calendar-absolute-from-time (x utc-diff) "Absolute local date of time X; local time is UTC-DIFF seconds from UTC. -X is (HIGH . LOW) or (HIGH LOW . IGNORED) where HIGH and LOW are the -high and low 16 bits, respectively, of the number of seconds since -1970-01-01 00:00:00 UTC, ignoring leap seconds. +X is the number of seconds since 1970-01-01 00:00:00 UTC, +ignoring leap seconds. 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)) - (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))))) + (let ((secsperday 86400) + (local (+ x utc-diff))) + (cons (+ calendar-system-time-basis (floor local secsperday)) + (mod local secsperday)))) (defun calendar-time-from-absolute (abs-date s) "Time of absolute date ABS-DATE, S seconds after midnight. -Returns the list (HIGH LOW) where HIGH and LOW are the high and low -16 bits, respectively, of the number of seconds 1970-01-01 00:00:00 UTC, -ignoring leap seconds, that is the equivalent moment to S seconds after -midnight UTC on absolute date ABS-DATE." - (let* ((a (- abs-date calendar-system-time-basis)) - (u (+ (* 163 (mod a 512)) (floor s 128)))) - ;; Overflow is a terrible thing! - (list - ;; floor((60*60*24*a + s) / 2^16) - (+ a (* 163 (floor a 512)) (floor u 512)) - ;; (60*60*24*a + s) mod 2^16 - (+ (* 128 (mod u 512)) (mod s 128))))) +Return the number of seconds since 1970-01-01 00:00:00 UTC, +ignoring leap seconds, that is the equivalent moment to S seconds +after midnight UTC on absolute date ABS-DATE." + (let ((secsperday 86400)) + (+ s (* secsperday (- abs-date calendar-system-time-basis))))) (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'. 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 + (let* ((time (encode-time time 'integer)) (time-zone (current-time-zone time)) (time-utc-diff (car time-zone)) hi hi-zone (hi-utc-diff time-utc-diff) + (quarter-seconds 7889238) ; Average seconds per 1/4 Gregorian year. (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 (+ time (* (car quarters) quarter-seconds)) hi-zone (current-time-zone hi) hi-utc-diff (car hi-zone) quarters (cdr quarters))) @@ -163,23 +149,16 @@ Return nil if no such transition can be found." ;; Now HI is after the next time zone transition. ;; 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)))) + (let* ((lo time) 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))) + (not (= lo (setq probe (floor (+ lo hi) 2)))) ;; 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))) - (setcdr hi (list (cdr hi))) hi)))) (autoload 'calendar-persian-to-absolute "cal-persia") @@ -220,29 +199,30 @@ The result has the proper form for `calendar-daylight-savings-starts'." '((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 (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 (cadr 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))) + (calendar-dlet* ((year (1+ y))) + ;; Scan through the next few years until only one rule remains. + (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 (cadr 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 @@ -279,14 +259,11 @@ for `calendar-current-time-zone'." (car t2-date-sec) t1-utc-diff)) (t1-time (/ (cdr t1-date-sec) 60)) (t2-time (/ (cdr t2-date-sec) 60))) - (cons - (/ (min t0-utc-diff t1-utc-diff) 60) - (cons - (/ (abs (- t0-utc-diff t1-utc-diff)) 60) - (if (< t0-utc-diff t1-utc-diff) - (list t0-name t1-name t1-rules t2-rules t1-time t2-time) - (list t1-name t0-name t2-rules t1-rules t2-time t1-time) - ))))))))) + (if (nth 7 (decode-time t1)) + (list (/ t0-utc-diff 60) (/ (- t1-utc-diff t0-utc-diff) 60) + t0-name t1-name t1-rules t2-rules t1-time t2-time) + (list (/ t1-utc-diff 60) (/ (- t0-utc-diff t1-utc-diff) 60) + t1-name t0-name t2-rules t1-rules t2-time t1-time)))))))) (defvar calendar-dst-transition-cache nil "Internal cal-dst variable storing date of daylight saving time transitions. @@ -405,7 +382,8 @@ This function respects the value of `calendar-dst-check-each-year-flag'." (or (let ((expr (if calendar-dst-check-each-year-flag (cadr (calendar-dst-find-startend year)) (nth 4 calendar-current-time-zone-cache)))) - (if expr (eval expr))) + (calendar-dlet* ((year year)) + (if expr (eval expr)))) ;; New US rules commencing 2007. https://www.iana.org/time-zones (and (not (zerop calendar-daylight-time-offset)) (calendar-nth-named-day 2 0 3 year)))) @@ -416,7 +394,8 @@ This function respects the value of `calendar-dst-check-each-year-flag'." (or (let ((expr (if calendar-dst-check-each-year-flag (nth 2 (calendar-dst-find-startend year)) (nth 5 calendar-current-time-zone-cache)))) - (if expr (eval expr))) + (calendar-dlet* ((year year)) + (if expr (eval expr)))) ;; New US rules commencing 2007. https://www.iana.org/time-zones (and (not (zerop calendar-daylight-time-offset)) (calendar-nth-named-day 1 0 11 year)))) @@ -425,25 +404,25 @@ This function respects the value of `calendar-dst-check-each-year-flag'." (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." - (let* ((year (calendar-extract-year - (calendar-gregorian-from-absolute (floor date)))) - (dst-starts-gregorian (eval calendar-daylight-savings-starts)) - (dst-ends-gregorian (eval calendar-daylight-savings-ends)) - (dst-starts (and dst-starts-gregorian + (calendar-dlet* ((year (calendar-extract-year + (calendar-gregorian-from-absolute (floor date))))) + (let* ((dst-starts-gregorian (eval calendar-daylight-savings-starts)) + (dst-ends-gregorian (eval calendar-daylight-savings-ends)) + (dst-starts (and dst-starts-gregorian + (+ (calendar-absolute-from-gregorian + dst-starts-gregorian) + (/ calendar-daylight-savings-starts-time + 60.0 24.0)))) + (dst-ends (and dst-ends-gregorian (+ (calendar-absolute-from-gregorian - dst-starts-gregorian) - (/ calendar-daylight-savings-starts-time - 60.0 24.0)))) - (dst-ends (and dst-ends-gregorian - (+ (calendar-absolute-from-gregorian - dst-ends-gregorian) - (/ (- calendar-daylight-savings-ends-time - calendar-daylight-time-offset) - 60.0 24.0))))) - (and dst-starts dst-ends - (if (< dst-starts dst-ends) - (and (<= dst-starts date) (< date dst-ends)) - (or (<= dst-starts date) (< date dst-ends)))))) + dst-ends-gregorian) + (/ (- calendar-daylight-savings-ends-time + calendar-daylight-time-offset) + 60.0 24.0))))) + (and dst-starts dst-ends + (if (< dst-starts dst-ends) + (and (<= dst-starts date) (< date dst-ends)) + (or (<= dst-starts date) (< date dst-ends))))))) ;; used by calc, lunar, solar. (defun dst-adjust-time (date time) |