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

60
src/code/time.lisp
View file

@ -138,41 +138,41 @@ format."
nine values: second, minute, hour, date, month, year, day of week (0 = nine values: second, minute, hour, date, month, year, day of week (0 =
Monday), T (daylight savings time) or NIL (standard time), and timezone. Monday), T (daylight savings time) or NIL (standard time), and timezone.
Completely ignores daylight-savings-time when time-zone is supplied." 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 (if time-zone
(values (* time-zone 60 60) nil) (values (* time-zone 60 60) time-zone nil)
(sb-unix::get-timezone (truncate-to-unix-range universal-time))) (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)) (declare (fixnum seconds-west))
(multiple-value-bind (weeks secs) (multiple-value-bind (weeks secs)
(truncate (+ (- universal-time seconds-west) seconds-offset) (truncate (+ (- universal-time seconds-west) seconds-offset)
seconds-in-week) seconds-in-week)
(let ((weeks (+ weeks weeks-offset))) (multiple-value-bind (t1 second) (truncate secs 60)
(multiple-value-bind (t1 second) (multiple-value-bind (tday tday-rem) (truncate t1 minutes-per-day)
(truncate secs 60) (multiple-value-bind (hour minute) (truncate tday-rem 60)
(let ((tday (truncate t1 minutes-per-day))) (let* ((weeks (+ weeks weeks-offset))
(multiple-value-bind (hour minute) (t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4))))
(truncate (- t1 (* tday minutes-per-day)) 60) (multiple-value-bind (tcent t2) (truncate t2 quarter-days-per-century)
(let* ((t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4))) (setq t2 (+ (logand t2 -4) 3)) ;; align up
(tcent (truncate t2 quarter-days-per-century))) (multiple-value-bind (t2-quarter-days t2-quarter-days-rem)
(setq t2 (mod t2 quarter-days-per-century)) (truncate t2 quarter-days-per-year)
(setq t2 (+ (- t2 (mod t2 4)) 3)) (let* ((year (+ (* tcent 100) t2-quarter-days))
(let* ((year (+ (* tcent 100) (days-since-mar0 (truncate t2-quarter-days-rem 4))
(truncate t2 quarter-days-per-year))) (day (mod (+ tday weekday-november-17-1858) 7))
(days-since-mar0 (t3 (+ (* days-since-mar0 5) 5 456)))
(1+ (truncate (mod t2 quarter-days-per-year) 4))) (cond ((>= t3 1989)
(day (mod (+ tday weekday-november-17-1858) 7)) (setq t3 (- t3 1836))
(t3 (+ (* days-since-mar0 5) 456))) (setq year (1+ year))))
(cond ((>= t3 1989) (multiple-value-bind (month t3) (truncate t3 153)
(setq t3 (- t3 1836)) (let ((date (1+ (truncate t3 5))))
(setq year (1+ year)))) (values second minute hour date month year day
(multiple-value-bind (month t3) daylight time-zone)))))))))))))
(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))))))))))))))
(defun pick-obvious-year (year) (defun pick-obvious-year (year)
(declare (type (mod 100) 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)) (with-test (:name (get-internal-run-time :monotonic))
(checked-compile-and-assert (:optimize nil) (checked-compile-and-assert (:optimize nil)
'(lambda (n-seconds) '(lambda (n-seconds)
(declare (type fixnum n-seconds))
(let* ((n-internal-time-units (let* ((n-internal-time-units
(* n-seconds (* n-seconds
internal-time-units-per-second)) internal-time-units-per-second))
@ -23,7 +22,7 @@
(loop for time = (get-internal-run-time) (loop for time = (get-internal-run-time)
while (< time time1) while (< time time1)
always (>= time time0)))) always (>= time time0))))
((1) t))) ((0.5) t)))
(with-test (:name (time :lambdas-converted)) (with-test (:name (time :lambdas-converted))
(let ((output (with-output-to-string (*trace-output*) (let ((output (with-output-to-string (*trace-output*)
@ -32,3 +31,20 @@
;; converted. The exact number depends on the inner workings of ;; converted. The exact number depends on the inner workings of
;; the compiler. ;; the compiler.
(assert (search "converted" output)))) (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)))))))