diff options
Diffstat (limited to 'third_party/lisp/sclf/time.lisp')
| -rw-r--r-- | third_party/lisp/sclf/time.lisp | 232 |
1 files changed, 116 insertions, 116 deletions
diff --git a/third_party/lisp/sclf/time.lisp b/third_party/lisp/sclf/time.lisp index ca1e1902a9..71b943aa43 100644 --- a/third_party/lisp/sclf/time.lisp +++ b/third_party/lisp/sclf/time.lisp @@ -50,15 +50,15 @@ "Return true if YEAR is a leap year." (and (zerop (mod year 4)) (or (not (zerop (mod year 100))) - (zerop (mod year 400))))) + (zerop (mod year 400))))) (defun last-day-of-month (month year) "Return the last day of the month as integer." (be last (elt #(31 28 31 30 31 30 31 31 30 31 30 31) (1- month)) (if (and (= last 28) - (leap-year-p year)) - (1+ last) - last))) + (leap-year-p year)) + (1+ last) + last))) (defun add-months (months epoch &optional time-zone) "Add MONTHS to EPOCH, which is a universal time. MONTHS can be @@ -66,12 +66,12 @@ negative." (multiple-value-bind (ss mm hh day month year) (decode-universal-time epoch time-zone) (multiple-value-bind (y m) (floor (+ month months -1) 12) (let ((new-month (1+ m)) - (new-year (+ year y))) - (encode-universal-time ss mm hh - (min day (last-day-of-month new-month (year epoch))) - new-month - new-year - time-zone))))) + (new-year (+ year y))) + (encode-universal-time ss mm hh + (min day (last-day-of-month new-month (year epoch))) + new-month + new-year + time-zone))))) (defun add-days (days epoch) "Add DAYS to EPOCH, which is an universal time. DAYS can be @@ -86,7 +86,7 @@ negative." "Return an ISO 8601 string representing TIME. The time zone is included if WITH-TIMEZONE-P is true." (flet ((format-timezone (zone) - (if (zerop zone) + (if (zerop zone) "Z" (multiple-value-bind (h m) (truncate (abs zone) 1.0) ;; Sign of time zone is reversed in ISO 8601 relative @@ -94,82 +94,82 @@ included if WITH-TIMEZONE-P is true." (format nil "~:[+~;-~]~2,'0D:~2,'0D" (> zone 0) h (round m)))))) (multiple-value-bind (second minute hour day month year dow dst zone) - (decode-universal-time time time-zone) + (decode-universal-time time time-zone) (declare (ignore dow dst)) (if basic - (format nil "~4,'0D~2,'0D~2,'0DT~2,'0D~2,'0D~2,'0D~[~*~;~A~]" - year month day hour minute second - with-timezone-p (format-timezone zone)) - (format nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D~:[~*~;~A~]" - year month day hour minute second - with-timezone-p (format-timezone zone)))))) + (format nil "~4,'0D~2,'0D~2,'0DT~2,'0D~2,'0D~2,'0D~[~*~;~A~]" + year month day hour minute second + with-timezone-p (format-timezone zone)) + (format nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D~:[~*~;~A~]" + year month day hour minute second + with-timezone-p (format-timezone zone)))))) (defun parse-iso-time-string (time-string) "Parse an ISO 8601 formated string and return the universal time. It can parse the basic and the extended format, but may not be able to cover all the cases." (labels ((parse-delimited-string (string delimiter n) - ;; Parses a delimited string and returns a list of - ;; n integers found in that string. - (let ((answer (make-list n :initial-element 0))) - (loop - for i upfrom 0 - for start = 0 then (1+ end) - for end = (position delimiter string :start (1+ start)) - do (setf (nth i answer) - (parse-integer (subseq string start end))) - when (null end) return t) - (values-list answer))) - (parse-fixed-field-string (string field-sizes) - ;; Parses a string with fixed length fields and returns - ;; a list of integers found in that string. - (let ((answer (make-list (length field-sizes) :initial-element 0))) - (loop - with len = (length string) - for start = 0 then (+ start field-size) - for field-size in field-sizes - for i upfrom 0 - while (< start len) - do (setf (nth i answer) - (parse-integer (subseq string start (+ start field-size))))) - (values-list answer))) - (parse-iso8601-date (date-string) - (let ((hyphen-pos (position #\- date-string))) - (if hyphen-pos - (parse-delimited-string date-string #\- 3) - (parse-fixed-field-string date-string '(4 2 2))))) - (parse-iso8601-timeonly (time-string) - (let* ((colon-pos (position #\: time-string)) - (zone-pos (or (position #\- time-string) - (position #\+ time-string))) - (timeonly-string (subseq time-string 0 zone-pos)) - (zone-string (when zone-pos (subseq time-string (1+ zone-pos)))) - (time-zone nil)) - (when zone-pos - (multiple-value-bind (zone-h zone-m) - (parse-delimited-string zone-string #\: 2) - (setq time-zone (+ zone-h (/ zone-m 60))) - (when (char= (char time-string zone-pos) #\-) - (setq time-zone (- time-zone))))) - (multiple-value-bind (hh mm ss) - (if colon-pos - (parse-delimited-string timeonly-string #\: 3) - (parse-fixed-field-string timeonly-string '(2 2 2))) - (values hh mm ss time-zone))))) + ;; Parses a delimited string and returns a list of + ;; n integers found in that string. + (let ((answer (make-list n :initial-element 0))) + (loop + for i upfrom 0 + for start = 0 then (1+ end) + for end = (position delimiter string :start (1+ start)) + do (setf (nth i answer) + (parse-integer (subseq string start end))) + when (null end) return t) + (values-list answer))) + (parse-fixed-field-string (string field-sizes) + ;; Parses a string with fixed length fields and returns + ;; a list of integers found in that string. + (let ((answer (make-list (length field-sizes) :initial-element 0))) + (loop + with len = (length string) + for start = 0 then (+ start field-size) + for field-size in field-sizes + for i upfrom 0 + while (< start len) + do (setf (nth i answer) + (parse-integer (subseq string start (+ start field-size))))) + (values-list answer))) + (parse-iso8601-date (date-string) + (let ((hyphen-pos (position #\- date-string))) + (if hyphen-pos + (parse-delimited-string date-string #\- 3) + (parse-fixed-field-string date-string '(4 2 2))))) + (parse-iso8601-timeonly (time-string) + (let* ((colon-pos (position #\: time-string)) + (zone-pos (or (position #\- time-string) + (position #\+ time-string))) + (timeonly-string (subseq time-string 0 zone-pos)) + (zone-string (when zone-pos (subseq time-string (1+ zone-pos)))) + (time-zone nil)) + (when zone-pos + (multiple-value-bind (zone-h zone-m) + (parse-delimited-string zone-string #\: 2) + (setq time-zone (+ zone-h (/ zone-m 60))) + (when (char= (char time-string zone-pos) #\-) + (setq time-zone (- time-zone))))) + (multiple-value-bind (hh mm ss) + (if colon-pos + (parse-delimited-string timeonly-string #\: 3) + (parse-fixed-field-string timeonly-string '(2 2 2))) + (values hh mm ss time-zone))))) (let ((time-separator (position #\T time-string))) (multiple-value-bind (year month date) - (parse-iso8601-date - (subseq time-string 0 time-separator)) - (if time-separator - (multiple-value-bind (hh mm ss zone) - (parse-iso8601-timeonly - (subseq time-string (1+ time-separator))) - (if zone - ;; Sign of time zone is reversed in ISO 8601 - ;; relative to Common Lisp convention! - (encode-universal-time ss mm hh date month year (- zone)) - (encode-universal-time ss mm hh date month year))) - (encode-universal-time 0 0 0 date month year)))))) + (parse-iso8601-date + (subseq time-string 0 time-separator)) + (if time-separator + (multiple-value-bind (hh mm ss zone) + (parse-iso8601-timeonly + (subseq time-string (1+ time-separator))) + (if zone + ;; Sign of time zone is reversed in ISO 8601 + ;; relative to Common Lisp convention! + (encode-universal-time ss mm hh date month year (- zone)) + (encode-universal-time ss mm hh date month year))) + (encode-universal-time 0 0 0 date month year)))))) (defun time-string (time &optional time-zone) "Return a string representing TIME in the form: @@ -177,11 +177,11 @@ cover all the cases." (multiple-value-bind (ss mm hh day month year week-day) (decode-universal-time time time-zone) (format nil "~A ~A ~A ~D:~2,'0D:~2,'0D ~A" - (subseq (week-day->string week-day) 0 3) - (subseq (month->string month) 0 3) - day - hh mm ss - year))) + (subseq (week-day->string week-day) 0 3) + (subseq (month->string month) 0 3) + day + hh mm ss + year))) (defun beginning-of-month (month year &optional time-zone) (encode-universal-time 0 0 0 1 month year time-zone)) @@ -194,7 +194,7 @@ cover all the cases." of the year needs to have Thursday in this YEAR, the returned time can actually fall in the previous year." (let* ((Jan-1st (encode-universal-time 0 0 0 1 1 year time-zone)) - (start (- 4 (week-day (add-days 4 Jan-1st))))) + (start (- 4 (week-day (add-days 4 Jan-1st))))) (add-days start Jan-1st))) (defun beginning-of-week (week year &optional time-zone) @@ -218,7 +218,7 @@ time can fall in the next year." "Return the day within the year of TIME starting from 1 up to 365 (or 366)." (1+ (truncate (seconds-from-beginning-of-the-year time time-zone) - (* 60 60 24)))) + (* 60 60 24)))) (defun week (time &optional time-zone) "Return the number of the week and the year TIME referes to. @@ -226,26 +226,26 @@ Week is an integer from 1 to 52. Due to the way the first week of the year is calculated a day in one year could actually be in the last week of the previous or next year." (let* ((year (year time)) - (start (beginning-of-first-week year time-zone)) - (days-from-start (truncate (- time start) (* 60 60 24))) - (weeks (truncate days-from-start 7)) - (week-number (mod weeks 52))) + (start (beginning-of-first-week year time-zone)) + (days-from-start (truncate (- time start) (* 60 60 24))) + (weeks (truncate days-from-start 7)) + (week-number (mod weeks 52))) (values (1+ week-number) - (cond ((< weeks 0) - (1- year)) - ((> weeks 51) - (1+ year)) - (t year))))) + (cond ((< weeks 0) + (1- year)) + ((> weeks 51) + (1+ year)) + (t year))))) (defun week-day->string (day &optional sunday-first) "Return the weekday string corresponding to DAY number." (elt (if sunday-first - #("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday") - #("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday")) + #("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday") + #("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday")) day)) (defconst +month-names+ #("January" "February" "March" "April" "May" "June" "July" - "August" "September" "October" "November" "December")) + "August" "September" "October" "November" "December")) (defun month->string (month) "Return the month string corresponding to MONTH number." @@ -257,32 +257,32 @@ the last week of the previous or next year." (defun print-time-span (span &optional stream) "Print in English the time SPAN expressed in seconds." (let* ((minute 60) - (hour (* minute 60)) - (day (* hour 24)) - (seconds span)) + (hour (* minute 60)) + (day (* hour 24)) + (seconds span)) (macrolet ((split (divisor) - `(when (>= seconds ,divisor) - (prog1 (truncate seconds ,divisor) - (setf seconds (mod seconds ,divisor)))))) + `(when (>= seconds ,divisor) + (prog1 (truncate seconds ,divisor) + (setf seconds (mod seconds ,divisor)))))) (let* ((days (split day)) - (hours (split hour)) - (minutes (split minute))) - (format stream "~{~A~^ ~}" (remove nil - (list - (when days - (format nil "~D day~:P" days)) - (when hours - (format nil "~D hour~:P" hours)) - (when minutes - (format nil "~D minute~:P" minutes)) - (when (or (> seconds 0) - (= span 0)) - (format nil "~D second~:P" seconds))))))))) + (hours (split hour)) + (minutes (split minute))) + (format stream "~{~A~^ ~}" (remove nil + (list + (when days + (format nil "~D day~:P" days)) + (when hours + (format nil "~D hour~:P" hours)) + (when minutes + (format nil "~D minute~:P" minutes)) + (when (or (> seconds 0) + (= span 0)) + (format nil "~D second~:P" seconds))))))))) (defun next-week-day (epoch week-day &optional time-zone) "Return the universal time of the next WEEK-DAY starting from epoch." (add-days (mod (- week-day (week-day epoch time-zone)) 7) - epoch)) + epoch)) (defun next-monday (epoch &optional time-zone) "Return the universal time of the next Monday starting from |