Index: /trunk/source/lib/time.lisp =================================================================== --- /trunk/source/lib/time.lisp (revision 15303) +++ /trunk/source/lib/time.lisp (revision 15304) @@ -90,52 +90,50 @@ Monday), T (daylight savings time) or NIL (standard time), and timezone. Completely ignores daylight-savings-time when time-zone is supplied." - (multiple-value-bind (weeks secs) - (truncate (+ universal-time seconds-offset) - seconds-in-week) - (let* ((weeks (+ weeks weeks-offset)) - (second NIL) - (minute NIL) - (hour NIL) - (date NIL) - (month NIL) - (year NIL) - (day NIL) - (daylight NIL) - (timezone (if (null time-zone) - (multiple-value-bind - (minwest dst) - (get-timezone (- universal-time - unix-to-universal-time)) - (setf daylight dst) - minwest) - (* time-zone 60)))) - (declare (fixnum timezone)) - (multiple-value-bind (t1 seconds) (truncate secs 60) - (setq second seconds) - (setq t1 (- t1 timezone)) - (let* ((tday (if (< t1 0) - (1- (truncate (1+ t1) minutes-per-day)) - (truncate t1 minutes-per-day)))) - (multiple-value-setq (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)) - (setq year (+ (* tcent 100) (truncate t2 quarter-days-per-year))) - (let ((days-since-mar0 (1+ (truncate (mod t2 quarter-days-per-year) - 4)))) - (setq day (mod (+ tday weekday-november-17-1858) 7)) - (let ((t3 (+ (* days-since-mar0 5) 456))) - (cond ((>= t3 1989) - (setq t3 (- t3 1836)) - (setq year (1+ year)))) - (multiple-value-setq (month t3) (truncate t3 153)) - (setq date (1+ (truncate t3 5)))))))) - (values second minute hour date month year day - daylight - (if daylight - (1+ (/ timezone 60)) - (/ timezone 60)))))) + (let* ((daylight nil) + (timezone (if (null time-zone) + (multiple-value-bind + (minwest dst) + (get-timezone (- universal-time + unix-to-universal-time)) + (declare (fixnum minwest)) + (setf daylight dst) + (the fixnum (* minwest 60))) + (* time-zone 60 60)))) + (declare (fixnum timezone)) + (multiple-value-bind (weeks secs) + (truncate (+ (- universal-time timezone) seconds-offset) + seconds-in-week) + (let* ((weeks (+ weeks weeks-offset)) + (second NIL) + (minute NIL) + (hour NIL) + (date NIL) + (month NIL) + (year NIL) + (day NIL)) + (multiple-value-bind (t1 seconds) (truncate secs 60) + (setq second seconds) + (let* ((tday (truncate t1 minutes-per-day))) + (multiple-value-setq (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)) + (setq year (+ (* tcent 100) (truncate t2 quarter-days-per-year))) + (let ((days-since-mar0 (1+ (truncate (mod t2 quarter-days-per-year) + 4)))) + (setq day (mod (+ tday weekday-november-17-1858) 7)) + (let ((t3 (+ (* days-since-mar0 5) 456))) + (cond ((>= t3 1989) + (setq t3 (- t3 1836)) + (setq year (1+ year)))) + (multiple-value-setq (month t3) (truncate t3 153)) + (setq date (1+ (truncate t3 5)))))))) + (values second minute hour date month year day + daylight + (if daylight + (1+ (/ timezone 60 60)) + (/ timezone 60 60))))))) (defun get-decoded-time () @@ -162,42 +160,70 @@ (coerce (nreverse results) 'vector))) +(defun check-valid-date (year month day) + (declare (fixnum year month day)) + (let* ((limit (if (and (eql month 2) + (not (logtest year 3)) + (or (eql 0 (mod year 400)) + (not (eql 0 (mod year 100))))) + 29 + (svref #(31 28 31 30 31 30 31 31 30 31 30 31) (1- month))))) + (declare (fixnum limit)) + (unless (<= day limit) + (report-bad-arg day `(integer 1 ,limit))))) + (defun encode-universal-time (second minute hour date month year - &optional time-zone) + &optional (time-zone nil tz-p)) "The time values specified in decoded format are converted to universal time, which is returned." - (declare (type (mod 60) second) - (type (mod 60) minute) - (type (mod 24) hour) - (type (integer 1 31) date) - (type (integer 1 12) month) - (type unsigned-byte year) - (type (or null rational) time-zone)) - (when (< year 100) - (let* ((this (current-year)) - (past (- this 50)) - (future (+ this 49)) - (maybe-past (+ (- past (mod past 100)) year)) - (maybe-future (+ (- future (mod future 100)) year))) - (if (>= maybe-past past) - (setq year maybe-past) - (setq year maybe-future)))) - - (let* ((days (+ (1- date) - (aref *days-before-month* month) - (if (> month 2) - (leap-years-before (1+ year)) - (leap-years-before year)) - (* (- year 1900) 365))) - (hours (+ hour (* days 24)))) - (if time-zone - (+ second (* (+ minute (* (+ hours time-zone) 60)) 60)) - (let* ((minwest-guess - (get-timezone (- (* hours 60 60) - unix-to-universal-time))) - (guess (+ minute (* hours 60) minwest-guess)) - (minwest - (get-timezone (- (* guess 60) - unix-to-universal-time)))) - (+ second (* (+ guess (- minwest minwest-guess)) 60)))))) + (check-type second (mod 60)) + (check-type minute (mod 60)) + (check-type hour (mod 24)) + (check-type date (integer 1 31)) + (check-type month (integer 1 12)) + (check-type year unsigned-byte) + (when time-zone + (check-type time-zone (rational -24 24))) + (locally + (declare (type (mod 60) second) + (type (mod 60) minute) + (type (mod 24) hour) + (type (integer 1 31) date) + (type (integer 1 12) month) + (type unsigned-byte year) + (type (or null rational) time-zone)) + (when (< year 100) + (let* ((this (current-year)) + (past (- this 50)) + (future (+ this 49)) + (maybe-past (+ (- past (mod past 100)) year)) + (maybe-future (+ (- future (mod future 100)) year))) + (if (>= maybe-past past) + (setq year maybe-past) + (setq year maybe-future)))) + ;; 12/31/1899 in some time zones might yield a date after + ;; the start of the epoch in UTC. + (check-type year (integer 1899)) + (check-valid-date year month date) + (let* ((days (+ (1- date) + (aref *days-before-month* month) + (if (> month 2) + (leap-years-before (1+ year)) + (leap-years-before year)) + (* (- year 1900) 365))) + (hours (+ hour (* days 24))) + (result + (if time-zone + (+ second (* (+ minute (* (+ hours time-zone) 60)) 60)) + (let* ((minwest-guess + (get-timezone (- (* hours 60 60) + unix-to-universal-time))) + (guess (+ minute (* hours 60) minwest-guess)) + (minwest + (get-timezone (- (* guess 60) + unix-to-universal-time)))) + (+ second (* (+ guess (- minwest minwest-guess)) 60)))))) + (if (< result 0) + (error "Universal time for MM/DD/YYYY ~2,'0d/~2,'0d/~4,'0d ~2,'0d:~2,'0d:~2,'0d ~%with ~a time zone would be negative." month date year hour minute second (if tz-p "specified" "current")) + result))))