about summary refs log tree commit diff
path: root/third_party/lisp/sclf/time.lisp
diff options
context:
space:
mode:
Diffstat (limited to 'third_party/lisp/sclf/time.lisp')
-rw-r--r--third_party/lisp/sclf/time.lisp311
1 files changed, 0 insertions, 311 deletions
diff --git a/third_party/lisp/sclf/time.lisp b/third_party/lisp/sclf/time.lisp
deleted file mode 100644
index 71b943aa431a..000000000000
--- a/third_party/lisp/sclf/time.lisp
+++ /dev/null
@@ -1,311 +0,0 @@
-;;;  time.lisp --- time primitives
-
-;;;  Copyright (C) 2006, 2007, 2009 by Walter C. Pelissero
-
-;;;  Author: Walter C. Pelissero <walter@pelissero.de>
-;;;  Project: sclf
-
-#+cmu (ext:file-comment "$Module: time.lisp $")
-
-;;; This library is free software; you can redistribute it and/or
-;;; modify it under the terms of the GNU Lesser General Public License
-;;; as published by the Free Software Foundation; either version 2.1
-;;; of the License, or (at your option) any later version.
-;;; This library is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
-;;; Lesser General Public License for more details.
-;;; You should have received a copy of the GNU Lesser General Public
-;;; License along with this library; if not, write to the Free
-;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
-;;; 02111-1307 USA
-
-(in-package :sclf)
-
-(defun year (epoch &optional time-zone)
-  "Return the year of EPOCH."
-  (sixth (multiple-value-list (decode-universal-time epoch time-zone))))
-
-(defun month (epoch &optional time-zone)
-  "Return the month of EPOCH."
-  (fifth (multiple-value-list (decode-universal-time epoch time-zone))))
-
-(defun day (epoch &optional time-zone)
-  "Return the day of EPOCH."
-  (fourth (multiple-value-list (decode-universal-time epoch time-zone))))
-
-(defun week-day (epoch &optional time-zone)
-  "Return the day of the week of EPOCH."
-  (seventh (multiple-value-list (decode-universal-time epoch time-zone))))
-
-(defun hour (epoch &optional time-zone)
-  "Return the hour of EPOCH."
-  (third (multiple-value-list (decode-universal-time epoch time-zone))))
-
-(defun minute (epoch &optional time-zone)
-  "Return the minute of EPOCH."
-  (second (multiple-value-list (decode-universal-time epoch time-zone))))
-
-(defun leap-year-p (year)
-  "Return true if YEAR is a leap year."
-  (and (zerop (mod year 4))
-       (or (not (zerop (mod year 100)))
-           (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)))
-
-(defun add-months (months epoch &optional time-zone)
-  "Add MONTHS to EPOCH, which is a universal time.  MONTHS can be
-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)))))
-
-(defun add-days (days epoch)
-  "Add DAYS to EPOCH, which is an universal time.  DAYS can be
-negative."
-  (+ (* 60 60 24 days) epoch))
-
-;; The following two functions are based on Thomas Russ <tar@isi.edu>
-;; code which didn't carry any copyright notice, so I assume it was in
-;; the public domain.
-
-(defun iso-time-string (time &key time-zone with-timezone-p basic)
-  "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)
-               "Z"
-               (multiple-value-bind (h m) (truncate (abs zone) 1.0)
-                 ;; Sign of time zone is reversed in ISO 8601 relative
-                 ;; to Common Lisp convention!
-                 (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)
-      (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))))))
-
-(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)))))
-    (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))))))
-
-(defun time-string (time &optional time-zone)
-  "Return a string representing TIME in the form:
-  Tue Jan 25 12:55:40 2005"
-  (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)))
-
-(defun beginning-of-month (month year &optional time-zone)
-  (encode-universal-time 0 0 0 1 month year time-zone))
-
-(defun end-of-month (month year &optional time-zone)
-  (1- (add-months 1 (encode-universal-time 0 0 0 1 month year time-zone))))
-
-(defun beginning-of-first-week (year &optional time-zone)
-  "Return the epoch of the first week of YEAR.  As the first week
-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)))))
-    (add-days start Jan-1st)))
-
-(defun beginning-of-week (week year &optional time-zone)
-  "Return the epoch of the beginning of WEEK of YEAR."
-  (add-days (* (1- week) 7) (beginning-of-first-week year time-zone)))
-
-(defun end-of-week (week year &optional time-zone)
-  "Return the epoch of the beginning of WEEK of YEAR."
-  (1- (beginning-of-week (1+ week) year time-zone)))
-
-(defun end-of-last-week (year &optional time-zone)
-  "Return the epoch of the last week of YEAR.  As the last week
-of the year needs to have Thursday in this YEAR, the returned
-time can fall in the next year."
-  (1- (beginning-of-first-week (1+ year) time-zone)))
-
-(defun seconds-from-beginning-of-the-year (time &optional time-zone)
-  (- time (encode-universal-time 0 0 0 1 1 (year time) time-zone)))
-
-(defun day-of-the-year (time &optional time-zone)
-  "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))))
-
-(defun week (time &optional time-zone)
-  "Return the number of the week and the year TIME referes to.
-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)))
-    (values (1+ week-number)
-            (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"))
-       day))
-
-(defconst +month-names+  #("January" "February" "March" "April" "May" "June" "July"
-                           "August" "September" "October" "November" "December"))
-
-(defun month->string (month)
-  "Return the month string corresponding to MONTH number."
-  (elt +month-names+ (1- month)))
-
-(defun month-string->number (month)
-  (1+ (position month +month-names+ :test #'string-equal)))
-
-(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))
-    (macrolet ((split (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)))))))))
-
-(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))
-
-(defun next-monday (epoch &optional time-zone)
-  "Return the universal time of the next Monday starting from
-EPOCH."
-  (next-week-day epoch 0 time-zone))
-
-(defun full-weeks-in-span (start end &optional time-zone)
-  "Return the number of full weeks in time span START to END.  A
-full week starts on Monday and ends on Sunday."
-  (be first-monday (next-monday start time-zone)
-    (truncate (- end first-monday) (* 7 24 60 60))))
-
-(defconst +unix-lisp-time-difference+
-  (encode-universal-time 0 0 0 1 1 1970 0)
-  "Time difference between Unix epoch and Common Lisp epoch.  The
-former is 1st January 1970, while the latter is the beginning of the
-XX century.")
-
-(defun universal->unix-time (time)
-  (- time +unix-lisp-time-difference+))
-
-(defun unix->universal-time (time)
-  (+ time +unix-lisp-time-difference+))
-
-(defun get-unix-time ()
-  (universal->unix-time (get-universal-time)))