X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Ftime.lisp;h=e04525889f54d301f4a428488d304e1cb37a7395;hp=95a7a683de6d7caa9bb0a154493419ab8b64dcfd;hb=6b34e2293a52b03e8611c85e4e53a0ab5c8a3c1a;hpb=e11daa653dbf4bdb74068995b79c22ad42325aa5 diff --git a/sql/time.lisp b/sql/time.lisp index 95a7a68..e045258 100644 --- a/sql/time.lisp +++ b/sql/time.lisp @@ -255,7 +255,7 @@ (defun duration<= (duration-a duration-b) (<= (duration-reduce duration-a :usec) (duration-reduce duration-b :usec))) - + (defun duration>= (x y) (duration<= y x)) @@ -270,7 +270,7 @@ (if (/= (time-second x) (time-second y)) (< (time-second x) (time-second y)) (< (time-usec x) (time-usec y)))))) - + (defun %time>= (x y) (if (/= (time-mjd x) (time-mjd y)) (>= (time-mjd x) (time-mjd y)) @@ -490,7 +490,7 @@ (defstruct interval (start nil) (end nil) - (name nil) + (name nil) (contained nil) (type nil) (data nil)) @@ -563,17 +563,17 @@ (append sorted-list (list interval)))) ;; interval lists - + (defun interval-match (list time) "Return the index of the first interval in list containing time" ;; this depends on ordering of intervals! - (let ((list (sort-interval-list list))) + (let ((list (sort-interval-list list))) (dotimes (x (length list)) (let ((elt (nth x list))) (when (and (time<= (interval-start elt) time) (time< time (interval-end elt))) (return-from interval-match x)))))) - + (defun interval-clear (list time) (dotimes (x (length list)) (let ((elt (nth x list))) @@ -594,7 +594,7 @@ "Attempts to modify the most deeply nested interval in list which begins at time. If no changes are made, returns nil." ;; function required sorted interval list - (let ((list (sort-interval-list list))) + (let ((list (sort-interval-list list))) (if (null list) nil (dotimes (x (length list)) (let ((elt (nth x list))) @@ -790,7 +790,7 @@ it as separate calculations will not, as the time is chopped to a date before be "Returns a DURATION representing the difference between TIME1 and TIME2." (flet ((do-diff (time1 time2) - + (let (day-diff sec-diff) (setf day-diff (- (time-mjd time2) (time-mjd time1))) @@ -853,7 +853,7 @@ with the given options" year date-separator month date-separator day internal-separator hour time-separator minute time-separator second usec)))))) - + (defun pretty-time (hour minute) (cond ((eq hour 0) @@ -914,7 +914,7 @@ with the given options" (push (subseq input start x) output) (setf start (1+ x)))) (nreverse (push (subseq input start) output)))) - + (defun merged-time (day time-of-day) (%make-wall-time :mjd (time-mjd day) :second (time-second time-of-day))) @@ -938,9 +938,9 @@ with the given options" (print-date time style))) (defun print-date (time &optional (style :daytime)) - (multiple-value-bind (second minute hour day month year dow) + (multiple-value-bind (usec second minute hour day month year dow) (decode-time time) - (declare (ignore second)) + (declare (ignore usec second)) (multiple-value-bind (hours meridian) (time-meridian hour) (ecase style @@ -973,8 +973,9 @@ with the given options" (format nil "~d/~d/~d" month day year)))))) (defun time-element (time element) - (multiple-value-bind (second minute hour day month year dow) + (multiple-value-bind (usec second minute hour day month year dow) (decode-time time) + (declare (ignore usec)) (ecase element (:seconds second) @@ -1045,11 +1046,16 @@ with the given options" (unless (= 0 year month) (multiple-value-bind (year-orig month-orig day-orig) (time-ymd date) - (setf date (make-time :year (+ year year-orig) - :month (+ month month-orig) - :day day-orig - :second (time-second date) - :usec usec)))) + (multiple-value-bind (new-year new-month) + (floor (+ month month-orig (* 12 (+ year year-orig))) 12) + (let ((new-date (make-time :year new-year + :month new-month + :day day-orig + :second (time-second date) + :usec usec))) + (if destructive + (setf (time-mjd date) (time-mjd new-date)) + (setq date new-date)))))) (let ((mjd (time-mjd date)) (sec (time-second date)) (usec (time-usec date))) @@ -1060,9 +1066,8 @@ with the given options" (* 60 minute) (* 60 60 hour)))) 1000000) - (declare (ignore sec-new)) (multiple-value-bind (mjd-new sec-new) - (floor sec (* 60 60 24)) + (floor sec-new (* 60 60 24)) (if destructive (progn (setf (time-mjd date) (+ mjd mjd-new day) @@ -1138,7 +1143,7 @@ rules" doy)) (defun parse-yearstring (string) - (let ((year (or (parse-integer-insensitively string) + (let ((year (or (parse-integer-insensitively string) (extract-roman string)))) (when (and year (< 1500 year 2500)) (make-time :year year)))) @@ -1168,7 +1173,7 @@ rules" ;; ------------------------------------------------------------ -;; Parsing iso-8601 timestrings +;; Parsing iso-8601 timestrings (define-condition iso-8601-syntax-error (sql-user-error) ((bad-component;; year, month whatever @@ -1181,7 +1186,7 @@ rules" "parse a timestring and return the corresponding wall-time. If the timestring starts with P, read a duration; otherwise read an ISO 8601 formatted date string." - (declare (ignore junk-allowed)) + (declare (ignore junk-allowed)) (let ((string (subseq timestring start end))) (if (char= (aref string 0) #\P) (parse-iso-8601-duration string) @@ -1274,7 +1279,7 @@ Will throw a hissy fit if the date string is a duration. Will ignore any precisi (char= #\. (char string 19)))) (multiple-value-bind (parsed-usec usec-end) (parse-integer string :start 20 :junk-allowed t) - (setf usec parsed-usec + (setf usec (or parsed-usec 0) gmt-sec-offset (if (<= (+ 3 usec-end) strlen) (let ((skip-to (or (position #\+ string :start 19) (position #\- string :start 19))))