Address ENCODE-UNIVERSAL-TIME's effective ignorance TIME-ZONE argument

(Robert Dodier)

Addresses parts of <http://abcl.org/trac/ticket/443>, but the
DECODE-UNIVERSAL-TIME.3, DECODE-UNIVERSAL-TIME.4,
DECODE-UNIVERSAL-TIME.5, ENCODE-UNIVERSAL-TIME.1,
ENCODE-UNIVERSAL-TIME.3 ANSI tests still fail so there is a little
more work to do.

Also fixes an unreported bug in DECODE-UNIVERSAL-TIME: the daylight
saving flag is reported incorrectly because EXT:GET-TIME-ZONE expects
its argument in milliseconds, not seconds.

c.f. <https://mailman.common-lisp.net/pipermail/armedbear-devel/2017-April/003821.html>.
parent 7c87b444
......@@ -55,7 +55,7 @@
(if time-zone
(setf seconds-west (* time-zone 3600)
daylight nil)
(multiple-value-bind (time-zone daylight-p) (ext:get-time-zone universal-time)
(multiple-value-bind (time-zone daylight-p) (ext:get-time-zone (* 1000 universal-time))
(setf seconds-west (* time-zone 3600)
daylight daylight-p)))
(multiple-value-bind (weeks secs)
......@@ -128,12 +128,7 @@
(leap-years-before year))
(* (- year 1900) 365)))
(hours (+ hour (* days 24))))
(cond (time-zone
(let* ((tz-guess (ext:get-time-zone (* hours 3600)))
(guess (+ second (* 60 (+ minute (* 60 (+ hours tz-guess))))))
(tz (get-time-zone guess)))
(+ guess (* 3600 (- tz tz-guess)))))
((> year 2037)
(cond ((> year 2037)
(labels ((leap-year-p (year)
(cond ((zerop (mod year 400)) t)
((zerop (mod year 100)) nil)
......@@ -146,8 +141,13 @@
(* 86400 (+ (* 365 (- year fake-year))
(- (leap-years-before year)
(leap-years-before fake-year))))))))
((not time-zone)
(let* ((tz-guess (ext:get-time-zone (* 1000 (* hours 3600))))
(guess (+ second (* 60 (+ minute (* 60 (+ hours tz-guess))))))
(tz (ext:get-time-zone (* 1000 guess))))
(+ guess (* 3600 (- tz tz-guess)))))
(t
(+ second (* (+ minute (* (+ hours (default-time-zone)) 60)) 60))))))
(+ second (* (+ minute (* (+ hours time-zone) 60)) 60))))))
#|
(intern "GET-TIME-ZONE" (find-package :ext))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment