common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

decode-universal-time: don't do mod and truncate separately

Browse source 
And some other arithmetic rearrangements.
This commit is contained in:
Stas Boukarev 2026-08-20 13:17:46 +03:00
parent 23dedf9150
commit 2e8fa20cbd
2 changed files with 48 additions and 32 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

48
src/code/time.lisp
View file

@ -138,41 +138,41 @@ format."
nine values: second, minute, hour, date, month, year, day of week (0 =
Monday), T (daylight savings time) or NIL (standard time), and timezone.
Completely ignores daylight-savings-time when time-zone is supplied."
(multiple-value-bind (seconds-west daylight)
(multiple-value-bind (seconds-west time-zone daylight)
(if time-zone
(values (* time-zone 60 60) nil)
(sb-unix::get-timezone (truncate-to-unix-range universal-time)))
(values (* time-zone 60 60) time-zone nil)
(multiple-value-bind (seconds-west daylight)
(sb-unix::get-timezone (truncate-to-unix-range universal-time))
(let ((time-zone (/ seconds-west 60 60)))
(values seconds-west
(if daylight
(1+ time-zone)
time-zone)
daylight))))
(declare (fixnum seconds-west))
(multiple-value-bind (weeks secs)
(truncate (+ (- universal-time seconds-west) seconds-offset)
seconds-in-week)
(let ((weeks (+ weeks weeks-offset)))
(multiple-value-bind (t1 second)
(truncate secs 60)
(let ((tday (truncate t1 minutes-per-day)))
(multiple-value-bind (hour minute)
(truncate (- t1 (* tday minutes-per-day)) 60)
(let* ((t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4)))
(tcent (truncate t2 quarter-days-per-century)))
(setq t2 (mod t2 quarter-days-per-century))
(setq t2 (+ (- t2 (mod t2 4)) 3))
(let* ((year (+ (* tcent 100)
(truncate t2 quarter-days-per-year)))
(days-since-mar0
(1+ (truncate (mod t2 quarter-days-per-year) 4)))
(multiple-value-bind (t1 second) (truncate secs 60)
(multiple-value-bind (tday tday-rem) (truncate t1 minutes-per-day)
(multiple-value-bind (hour minute) (truncate tday-rem 60)
(let* ((weeks (+ weeks weeks-offset))
(t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4))))
(multiple-value-bind (tcent t2) (truncate t2 quarter-days-per-century)
(setq t2 (+ (logand t2 -4) 3)) ;; align up
(multiple-value-bind (t2-quarter-days t2-quarter-days-rem)
(truncate t2 quarter-days-per-year)
(let* ((year (+ (* tcent 100) t2-quarter-days))
(days-since-mar0 (truncate t2-quarter-days-rem 4))
(day (mod (+ tday weekday-november-17-1858) 7))
(t3 (+ (* days-since-mar0 5) 456)))
(t3 (+ (* days-since-mar0 5) 5 456)))
(cond ((>= t3 1989)
(setq t3 (- t3 1836))
(setq year (1+ year))))
(multiple-value-bind (month t3)
(truncate t3 153)
(multiple-value-bind (month t3) (truncate t3 153)
(let ((date (1+ (truncate t3 5))))
(values second minute hour date month year day
daylight
(if daylight
(1+ (/ seconds-west 60 60))
(/ seconds-west 60 60))))))))))))))
daylight time-zone)))))))))))))
(defun pick-obvious-year (year)
(declare (type (mod 100) year))

20
tests/time.pure.lisp
View file

@ -14,7 +14,6 @@
(with-test (:name (get-internal-run-time :monotonic))
(checked-compile-and-assert (:optimize nil)
'(lambda (n-seconds)
(declare (type fixnum n-seconds))
(let* ((n-internal-time-units
(* n-seconds
internal-time-units-per-second))
@ -23,7 +22,7 @@
(loop for time = (get-internal-run-time)
while (< time time1)
always (>= time time0))))
((1) t)))
((0.5) t)))
(with-test (:name (time :lambdas-converted))
(let ((output (with-output-to-string (*trace-output*)
@ -32,3 +31,20 @@
;; converted. The exact number depends on the inner workings of
;; the compiler.
(assert (search "converted" output))))
(with-test (:name :encode-decode-time)
(let ((*random-state* (make-random-state t)))
(loop repeat 200
for time = (random (expt 2 (random 80)))
for tz = (* 1/3600
(if (zerop (random 2))
-1
1)
(random (/ 24 1/3600)))
do (multiple-value-bind (second minute hour date month year day daylight-p zone)
(decode-universal-time time tz)
(assert (= day (mod (floor (- time (* tz 3600)) 86400) 7)))
(assert (= zone tz))
(assert (not daylight-p))
(assert (= time
(encode-universal-time second minute hour date month year tz)))))))