X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Ftime.lisp;h=0bb18c340b45aad6aaaec43ab4cc3172739b397c;hp=e5281d6b74720d353aef9c46bd2372d5ef267840;hb=HEAD;hpb=33b80bc24835fb26d7a831e99aea3fb9a805b809

diff --git a/sql/time.lisp b/sql/time.lisp
index e5281d6..0bb18c3 100644
--- a/sql/time.lisp
+++ b/sql/time.lisp
@@ -1,8 +1,6 @@
 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
 ;;;; *************************************************************************
 ;;;;
-;;;; $Id$
-;;;;
 ;;;; A variety of structures and function for creating and
 ;;;; manipulating dates, times, durations and intervals for
 ;;;; CLSQL.
@@ -62,11 +60,14 @@
                       (:constructor %make-wall-time)
                       (:print-function %print-wall-time))
   (mjd 0 :type fixnum)
-  (second 0 :type fixnum))
+  (second 0 :type fixnum)
+  (usec 0 :type fixnum))
 
 (defun %print-wall-time (time stream depth)
   (declare (ignore depth))
-  (format stream "#<WALL-TIME: ~a>" (format-time nil time)))
+  (if *print-escape*
+      (format stream "#<WALL-TIME: ~a>" (format-time nil time))
+      (format-time stream time :format :pretty)))
 
 (defstruct (duration (:constructor %make-duration)
                      (:print-function %print-duration))
@@ -75,12 +76,25 @@
   (day 0 :type fixnum)
   (hour 0 :type fixnum)
   (second 0 :type fixnum)
-  (minute 0 :type fixnum))
+  (minute 0 :type fixnum)
+  (usec 0 :type fixnum))
 
 (defun %print-duration (duration stream depth)
   (declare (ignore depth))
-  (format stream "#<DURATION: ~a>"
-          (format-duration nil duration :precision :second)))
+  (if *print-escape*
+      (format stream "#<DURATION: ~a>"
+              (format-duration nil duration :precision :second))
+      (format-duration stream duration :precision :second)))
+
+(defstruct (date (:constructor %make-date)
+                 (:print-function %print-date))
+  (mjd 0 :type fixnum))
+
+(defun %print-date (date stream depth)
+  (declare (ignore depth))
+  (if *print-escape*
+      (format stream "#<DATE: ~a>" (format-date nil date))
+      (format-date stream date :format :pretty)))
 
 );eval-when
 
@@ -88,22 +102,29 @@
   (let ((second (duration-second duration))
         (minute (duration-minute duration))
         (hour (duration-hour duration))
-        (day (duration-day duration)))
-    (format nil "P~dD~dH~dM~dS" day hour minute second)))
+        (day (duration-day duration))
+        (month (duration-month duration))
+        (year (duration-year duration)))
+    (format nil "P~dY~dM~dD~dH~dM~dS" year month day hour minute second)))
 
 
 ;; ------------------------------------------------------------
 ;; Constructors
 
 (defun make-time (&key (year 0) (month 1) (day 1) (hour 0) (minute 0)
-                       (second 0) (offset 0))
+                       (second 0) (usec 0) (offset 0))
   (let ((mjd (gregorian-to-mjd month day year))
         (sec (+ (* hour 60 60)
                 (* minute 60)
                 second (- offset))))
     (multiple-value-bind (day-add raw-sec)
         (floor sec (* 60 60 24))
-      (%make-wall-time :mjd (+ mjd day-add) :second raw-sec))))
+      (%make-wall-time :mjd (+ mjd day-add) :second raw-sec :usec usec))))
+
+(defun make-date (&key (year 0) (month 1) (day 1) (hour 0) (minute 0)
+                       (second 0) (usec 0) (offset 0))
+  (time->date (make-time :year year :month month :day day :hour hour
+                         :minute minute :second second :usec usec :offset offset)))
 
 (defun copy-time (time)
   (%make-wall-time :mjd (time-mjd time)
@@ -116,22 +137,37 @@
     (make-time :year year :month mon :day day :hour hour :minute minute
                :second second)))
 
+(defun date->time (date)
+  "Returns a walltime for the given date"
+  (%make-wall-time :mjd (date-mjd date)))
+
+(defun time->date (time)
+  "Returns a date for the given wall time (obvious loss in resolution)"
+  (%make-date :mjd (time-mjd time)))
+
 (defun get-time ()
   "Return a pair: (GREGORIAN DAY . TIME-OF-DAY)"
   (utime->time (get-universal-time)))
 
+(defun get-date ()
+  "Returns a date for today"
+  (time->date (get-time)))
+
 (defun make-duration (&key (year 0) (month 0) (day 0) (hour 0) (minute 0)
-                           (second 0))
-  (multiple-value-bind (minute-add second-60)
-      (floor second 60)
-    (multiple-value-bind (hour-add minute-60)
-        (floor (+ minute minute-add) 60)
-      (multiple-value-bind (day-add hour-24)
-          (floor (+ hour hour-add) 24)
-        (%make-duration :year year :month month :day (+ day day-add)
-                        :hour hour-24
-                        :minute minute-60
-                        :second second-60)))))
+                      (second 0) (usec 0))
+  (multiple-value-bind (second-add usec-1000000)
+      (floor usec 1000000)
+    (multiple-value-bind (minute-add second-60)
+        (floor (+ second second-add) 60)
+      (multiple-value-bind (hour-add minute-60)
+          (floor (+ minute minute-add) 60)
+        (multiple-value-bind (day-add hour-24)
+            (floor (+ hour hour-add) 24)
+          (%make-duration :year year :month month :day (+ day day-add)
+                          :hour hour-24
+                          :minute minute-60
+                          :second second-60
+                          :usec usec-1000000))))))
 
 
 ;; ------------------------------------------------------------
@@ -154,54 +190,72 @@
   (mod (+ 3 (time-mjd time)) 7))
 
 (defun decode-time (time)
-  "returns the decoded time as multiple values: second, minute, hour, day,
-month, year, integer day-of-week"
+  "returns the decoded time as multiple values: usec, second, minute, hour,
+  day, month, year, integer day-of-week"
   (multiple-value-bind (year month day)
       (time-ymd time)
     (multiple-value-bind (hour minute second)
         (time-hms time)
-      (values second minute hour day month year (mod (+ (time-mjd time) 3) 7)))))
+      (values (time-usec time) second minute hour day month year (mod (+ (time-mjd time) 3) 7)))))
+
+(defun date-ymd (date)
+  (time-ymd (date->time date)))
+
+(defun date-dow (date)
+  (time-dow (date->time date)))
+
+(defun decode-date (date)
+  "returns the decoded date as multiple values: day month year integer day-of-week"
+  (multiple-value-bind (year month day)
+      (time-ymd (date->time date))
+    (values day month year (date-dow date))))
 
 ;; duration specific
 (defun duration-reduce (duration precision &optional round)
   (ecase precision
+    (:usec
+     (+ (duration-usec duration)
+        (* (duration-reduce duration :second) 1000000)))
     (:second
-     (+ (duration-second duration)
-	(* (duration-reduce duration :minute) 60)))
+     (+ (if round
+            (floor (duration-usec duration) 500000)
+            0)
+        (duration-second duration)
+        (* (duration-reduce duration :minute) 60)))
     (:minute
      (+ (if round
-	    (floor (duration-second duration) 30)
-	    0)
-	(duration-minute duration)
-	(* (duration-reduce duration :hour) 60)))
+            (floor (duration-second duration) 30)
+            0)
+        (duration-minute duration)
+        (* (duration-reduce duration :hour) 60)))
     (:hour
      (+ (if round
-	    (floor (duration-minute duration) 30)
-	    0)
-	(duration-hour duration)
-	(* (duration-reduce duration :day) 24)))
+            (floor (duration-minute duration) 30)
+            0)
+        (duration-hour duration)
+        (* (duration-reduce duration :day) 24)))
     (:day
      (+ (if round
-	    (floor (duration-hour duration) 12)
-	    0)
-	(duration-day duration)))))
+            (floor (duration-hour duration) 12)
+            0)
+        (duration-day duration)))))
 
 
 ;; ------------------------------------------------------------
 ;; Arithemetic and comparators
 
 (defun duration= (duration-a duration-b)
-  (= (duration-reduce duration-a :second)
-     (duration-reduce duration-b :second)))
+  (= (duration-reduce duration-a :usec)
+     (duration-reduce duration-b :usec)))
 
 (defun duration< (duration-a duration-b)
-  (< (duration-reduce duration-a :second)
-     (duration-reduce duration-b :second)))
+  (< (duration-reduce duration-a :usec)
+     (duration-reduce duration-b :usec)))
 
 (defun duration<= (duration-a duration-b)
-  (<= (duration-reduce duration-a :second)
-     (duration-reduce duration-b :second)))
-							      
+  (<= (duration-reduce duration-a :usec)
+      (duration-reduce duration-b :usec)))
+
 (defun duration>= (x y)
   (duration<= y x))
 
@@ -213,26 +267,35 @@ month, year, integer day-of-week"
         (mjd-y (time-mjd y)))
     (if (/= mjd-x mjd-y)
         (< mjd-x mjd-y)
-        (< (time-second x) (time-second y)))))
-  
+        (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))
-      (>= (time-second x) (time-second y))))
+      (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))
-      (<= (time-second x) (time-second y))))
+      (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))
-      (> (time-second x) (time-second y))))
+      (if (/= (time-second x) (time-second y))
+          (> (time-second x) (time-second y))
+          (> (time-usec x) (time-usec y)))))
 
 (defun %time= (x y)
   (and (= (time-mjd x) (time-mjd y))
-       (= (time-second x) (time-second y))))
+       (= (time-second x) (time-second y))
+       (= (time-usec x) (time-usec y))))
 
 (defun time= (number &rest more-numbers)
   "Returns T if all of its arguments are numerically equal, NIL otherwise."
@@ -244,19 +307,19 @@ month, year, integer day-of-week"
 (defun time/= (number &rest more-numbers)
   "Returns T if no two of its arguments are numerically equal, NIL otherwise."
   (do* ((head number (car nlist))
-	(nlist more-numbers (cdr nlist)))
+        (nlist more-numbers (cdr nlist)))
        ((atom nlist) t)
      (declare (list nlist))
      (unless (do* ((nl nlist (cdr nl)))
-		  ((atom nl) t)
-	       (declare (list nl))
-	       (if (%time= head (car nl)) (return nil)))
+                  ((atom nl) t)
+               (declare (list nl))
+               (if (%time= head (car nl)) (return nil)))
        (return nil))))
 
 (defun time< (number &rest more-numbers)
   "Returns T if its arguments are in strictly increasing order, NIL otherwise."
   (do* ((n number (car nlist))
-	(nlist more-numbers (cdr nlist)))
+        (nlist more-numbers (cdr nlist)))
        ((atom nlist) t)
      (declare (list nlist))
      (if (not (%time< n (car nlist))) (return nil))))
@@ -264,7 +327,7 @@ month, year, integer day-of-week"
 (defun time> (number &rest more-numbers)
   "Returns T if its arguments are in strictly decreasing order, NIL otherwise."
   (do* ((n number (car nlist))
-	(nlist more-numbers (cdr nlist)))
+        (nlist more-numbers (cdr nlist)))
        ((atom nlist) t)
      (declare (list nlist))
      (if (not (%time> n (car nlist))) (return nil))))
@@ -272,7 +335,7 @@ month, year, integer day-of-week"
 (defun time<= (number &rest more-numbers)
   "Returns T if arguments are in strictly non-decreasing order, NIL otherwise."
   (do* ((n number (car nlist))
-	(nlist more-numbers (cdr nlist)))
+        (nlist more-numbers (cdr nlist)))
        ((atom nlist) t)
      (declare (list nlist))
      (if (not (%time<= n (car nlist))) (return nil))))
@@ -280,7 +343,7 @@ month, year, integer day-of-week"
 (defun time>= (number &rest more-numbers)
   "Returns T if arguments are in strictly non-increasing order, NIL otherwise."
   (do* ((n number (car nlist))
-	(nlist more-numbers (cdr nlist)))
+        (nlist more-numbers (cdr nlist)))
        ((atom nlist) t)
      (declare (list nlist))
      (if (not (%time>= n (car nlist))) (return nil))))
@@ -305,10 +368,16 @@ month, year, integer day-of-week"
   (let ((mjd-a (time-mjd time-a))
         (mjd-b (time-mjd time-b))
         (sec-a (time-second time-a))
-        (sec-b (time-second time-b)))
+        (sec-b (time-second time-b))
+        (usec-a (time-usec time-a))
+        (usec-b (time-usec time-b)))
     (if (= mjd-a mjd-b)
         (if (= sec-a sec-b)
-            :equal
+            (if (= usec-a usec-b)
+                :equal
+                (if (< usec-a usec-b)
+                    :less-than
+                    :greater-than))
             (if (< sec-a sec-b)
                 :less-than
                 :greater-than))
@@ -316,61 +385,98 @@ month, year, integer day-of-week"
             :less-than
             :greater-than))))
 
+; now the same for dates
+(eval-when (:compile-toplevel :load-toplevel)
+(defun replace-string (string1 search-string replace-string &key (test #'string=))
+  "Search within string1 for search-string, replace with replace-string, non-destructively."
+  (let ((replace-string-length (length replace-string))
+        (search-string-length  (length search-string)))
+    (labels ((sub-replace-string (current-string position)
+               (let ((found-position (search search-string current-string :test test :start2 position)))
+                 (if (null found-position)
+                     current-string
+                     (sub-replace-string (concatenate 'string
+                                                      (subseq current-string 0 found-position)
+                                                      replace-string
+                                                      (subseq current-string (+ found-position search-string-length)))
+                                         (+ position replace-string-length))))))
+      (sub-replace-string string1 0))))
+);eval-when
+
+(defmacro wrap-time-for-date (time-func &key (result-func))
+  (let ((date-func (intern (replace-string (symbol-name time-func)
+                                           (symbol-name-default-case "TIME")
+                                           (symbol-name-default-case "DATE")))))
+    `(defun ,date-func (number &rest more-numbers)
+      (let ((result (apply #',time-func (mapcar #'date->time (cons number more-numbers)))))
+        ,(if result-func
+             `(funcall #',result-func result)
+             'result)))))
+
+(wrap-time-for-date time=)
+(wrap-time-for-date time/=)
+(wrap-time-for-date time<)
+(wrap-time-for-date time>)
+(wrap-time-for-date time<=)
+(wrap-time-for-date time>=)
+(wrap-time-for-date time-max :result-func time->date)
+(wrap-time-for-date time-min :result-func time->date)
+
+(defun date-compare (date-a date-b)
+  (time-compare (date->time date-a) (date->time date-b)))
 
 ;; ------------------------------------------------------------
 ;; Formatting and output
-
-(defvar +decimal-printer+ #(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
-
-(defun db-timestring (time)
-  "return the string to store the given time in the database"
-  (declare (optimize (speed 3)))
-  (let ((output (copy-seq "'XXXX-XX-XX XX:XX:XX'")))
-    (flet ((inscribe-base-10 (output offset size decimal)
-             (declare (type fixnum offset size decimal)
-                      (type (simple-vector 10) +decimal-printer+))
-             (dotimes (x size)
-               (declare (type fixnum x)
-                        (optimize (safety 0)))
-               (multiple-value-bind (next this)
-                   (floor decimal 10)
-                 (setf (aref output (+ (- size x 1) offset))
-                       (aref +decimal-printer+ this))
-                 (setf decimal next)))))
-      (multiple-value-bind (second minute hour day month year)
-          (decode-time time)
-        (inscribe-base-10 output 1 4 year)
-        (inscribe-base-10 output 6 2 month)
-        (inscribe-base-10 output 9 2 day)
-        (inscribe-base-10 output 12 2 hour)
-        (inscribe-base-10 output 15 2 minute)
-        (inscribe-base-10 output 18 2 second)
-        output))))
-
-(defun iso-timestring (time)
+(defun db-timestring (time &key stream)
   "return the string to store the given time in the database"
-  (declare (optimize (speed 3)))
-  (let ((output (copy-seq "XXXX-XX-XX XX:XX:XX")))
-    (flet ((inscribe-base-10 (output offset size decimal)
-             (declare (type fixnum offset size decimal)
-                      (type (simple-vector 10) +decimal-printer+))
-             (dotimes (x size)
-               (declare (type fixnum x)
-                        (optimize (safety 0)))
-               (multiple-value-bind (next this)
-                   (floor decimal 10)
-                 (setf (aref output (+ (- size x 1) offset))
-                       (aref +decimal-printer+ this))
-                 (setf decimal next)))))
-      (multiple-value-bind (second minute hour day month year)
-          (decode-time time)
-        (inscribe-base-10 output 0 4 year)
-        (inscribe-base-10 output 5 2 month)
-        (inscribe-base-10 output 8 2 day)
-        (inscribe-base-10 output 11 2 hour)
-        (inscribe-base-10 output 14 2 minute)
-        (inscribe-base-10 output 17 2 second)
-        output))))
+  (if stream
+      (progn (write-char #\' stream) (iso-timestring time :stream stream) (write-char #\' stream))
+      (concatenate 'string "'" (iso-timestring time) "'")))
+
+(defun iso-timestring (time &key stream)
+  (multiple-value-bind (usec sec min hour day month year dow)
+      (decode-time time)
+    (declare (ignore dow))
+    (flet ((fmt (stream)
+	     (when (< year 1000) (princ #\0 stream))
+	     (when (< year 100) (princ #\0 stream))
+	     (when (< year 10) (princ #\0 stream))
+	     (princ year stream)
+	     (princ #\- stream)
+	     (when (< month 10) (princ #\0 stream))
+	     (princ month stream)
+	     (princ #\- stream)
+	     (when (< day 10) (princ #\0 stream))
+	     (princ day stream)
+	     (princ #\T stream) ;strict ISO says T here isn't optional.
+	     (when (< hour 10) (princ #\0 stream))
+	     (princ hour stream)
+	     (princ #\: stream)
+	     (when (< min 10) (princ #\0 stream))
+	     (princ min stream)
+	     (princ #\: stream)
+	     (when (< sec 10) (princ #\0 stream))
+	     (princ sec stream)
+	     (when (and usec (plusp usec))
+	       ;; we dont do this because different dbs support differnt precision levels
+	       (princ #\. stream)
+	       (loop for i from 5 downto 0
+		     for x10 = (expt 10 i)
+		     do (multiple-value-bind (quo rem)
+			    (floor (/ usec x10))
+			  (setf usec (- usec (* quo x10)))
+			  (princ quo stream)
+			  (when (= rem 0) (return)))))
+	     nil))
+      (if stream
+	  (fmt stream)
+	  (with-output-to-string (stream)
+	    (fmt stream))))))
+
+(defun db-datestring (date)
+  (db-timestring (date->time date)))
+(defun iso-datestring (date)
+  (iso-timestring (date->time date)))
 
 
 ;; ------------------------------------------------------------
@@ -379,7 +485,7 @@ month, year, integer day-of-week"
 (defstruct interval
   (start nil)
   (end nil)
-  (name nil) 
+  (name nil)
   (contained nil)
   (type nil)
   (data nil))
@@ -426,9 +532,9 @@ month, year, integer day-of-week"
 
 (defun sort-interval-list (list)
   (sort list (lambda (x y)
-	       (case (interval-relation x y)
-		 ((:precedes :contains) t)
-		 ((:follows :overlaps :contained) nil)))))
+               (case (interval-relation x y)
+                 ((:precedes :contains) t)
+                 ((:follows :overlaps :contained) nil)))))
 
 ;; interval push will return its list of intervals in strict order.
 (defun interval-push (interval-list interval &optional container-rule)
@@ -436,33 +542,33 @@ month, year, integer day-of-week"
   (let ((sorted-list (sort-interval-list interval-list)))
     (dotimes (x (length sorted-list))
       (let ((elt (nth x sorted-list)))
-	(case (interval-relation elt interval)
-	  (:follows
-	   (return-from interval-push (insert-at-index x sorted-list interval)))
-	  (:contains
-	   (return-from interval-push
-	     (replace-at-index x sorted-list
-			       (make-interval :start (interval-start elt)
-					      :end (interval-end elt)
-					      :type (interval-type elt)
-					      :contained (interval-push (interval-contained elt) interval)
-					      :data (interval-data elt)))))
-	  ((:overlaps :contained)
-	   (error "Overlap")))))
+        (case (interval-relation elt interval)
+          (:follows
+           (return-from interval-push (insert-at-index x sorted-list interval)))
+          (:contains
+           (return-from interval-push
+             (replace-at-index x sorted-list
+                               (make-interval :start (interval-start elt)
+                                              :end (interval-end elt)
+                                              :type (interval-type elt)
+                                              :contained (interval-push (interval-contained elt) interval)
+                                              :data (interval-data elt)))))
+          ((:overlaps :contained)
+           (error "Overlap")))))
     (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))))))
-  
+        (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)))
@@ -471,7 +577,7 @@ month, year, integer day-of-week"
         (if (interval-match (interval-contained elt) time)
             (return-from interval-clear
               (replace-at-index x list
-				(make-interval :start (interval-start elt)
+                                (make-interval :start (interval-start elt)
                                                :end (interval-end elt)
                                                :type (interval-type elt)
                                                :contained (interval-clear (interval-contained elt) time)
@@ -483,27 +589,27 @@ month, year, integer day-of-week"
   "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)))
-	  (when (and (time<= (interval-start elt) time)
-		     (time< time (interval-end elt)))
-	    (or (interval-edit (interval-contained elt) time start end tag)
-		(cond ((and (< 0 x)
-			    (time< start (interval-end (nth (1- x) list))))
-		       (error "Overlap of previous interval"))
-		      ((and (< x (1- (length list)))
-			    (time< (interval-start (nth (1+ x) list)) end))
-		       (error "~S ~S ~S ~S Overlap of next interval" x (length list) (interval-start (nth (1+ x) list)) end ))
-		      ((time= (interval-start elt) time)
-		       (return-from interval-edit
-			 (replace-at-index x list
-					   (make-interval :start start
-							  :end end
-							  :type (interval-type elt)
-							  :contained (restrict-intervals (interval-contained elt) start end)
-							  :data (or tag (interval-data elt))))))))))))))
+        (let ((elt (nth x list)))
+          (when (and (time<= (interval-start elt) time)
+                     (time< time (interval-end elt)))
+            (or (interval-edit (interval-contained elt) time start end tag)
+                (cond ((and (< 0 x)
+                            (time< start (interval-end (nth (1- x) list))))
+                       (error "Overlap of previous interval"))
+                      ((and (< x (1- (length list)))
+                            (time< (interval-start (nth (1+ x) list)) end))
+                       (error "~S ~S ~S ~S Overlap of next interval" x (length list) (interval-start (nth (1+ x) list)) end ))
+                      ((time= (interval-start elt) time)
+                       (return-from interval-edit
+                         (replace-at-index x list
+                                           (make-interval :start start
+                                                          :end end
+                                                          :type (interval-type elt)
+                                                          :contained (restrict-intervals (interval-contained elt) start end)
+                                                          :data (or tag (interval-data elt))))))))))))))
 
 (defun restrict-intervals (list start end &aux newlist)
   (let ((test-interval (make-interval :start start :end end)))
@@ -598,16 +704,18 @@ begins at time.  If no changes are made, returns nil."
         (day    (duration-day time))
         (hour   (duration-hour time))
         (minute (duration-minute time))
-        (second (duration-second time)))
+        (second (duration-second time))
+        (usec   (duration-usec time)))
     (dolist (duration durations)
       (incf year    (duration-year duration))
       (incf month   (duration-month duration))
       (incf day     (duration-day duration))
       (incf hour    (duration-hour duration))
       (incf minute  (duration-minute duration))
-      (incf second  (duration-second duration)))
+      (incf second  (duration-second duration))
+      (incf usec    (duration-usec duration)))
     (make-duration :year year :month month :day day :hour hour :minute minute
-                   :second second)))
+                   :second second :usec usec)))
 
 (defun duration- (duration &rest durations)
     "Subtract each DURATION from TIME, returning a new duration value."
@@ -616,16 +724,18 @@ begins at time.  If no changes are made, returns nil."
         (day    (duration-day duration))
         (hour   (duration-hour duration))
         (minute (duration-minute duration))
-        (second (duration-second duration)))
+        (second (duration-second duration))
+        (usec   (duration-usec duration)))
     (dolist (duration durations)
       (decf year    (duration-year duration))
       (decf month   (duration-month duration))
       (decf day     (duration-day duration))
       (decf hour    (duration-hour duration))
       (decf minute  (duration-minute duration))
-      (decf second  (duration-second duration)))
+      (decf second  (duration-second duration))
+      (decf usec    (duration-usec duration)))
     (make-duration :year year :month month :day day :hour hour :minute minute
-                   :second second)))
+                   :second second :usec usec)))
 
 ;; Date + Duration
 
@@ -640,9 +750,16 @@ begins at time.  If no changes are made, returns nil."
             :hour (duration-hour duration)
             :minute (duration-minute duration)
             :second (duration-second duration)
+            :usec (duration-usec duration)
             :destructive t))
     new-time))
 
+(defun date+ (date &rest durations)
+  "Add each DURATION to DATE, returning a new date value.
+Note that (barring daylight saving time) 12h + 12h will result in a new day, but doing
+it as separate calculations will not, as the time is chopped to a date before being returned."
+  (time->date (apply #'time+ (cons (date->time date) durations))))
+
 (defun time- (time &rest durations)
   "Subtract each DURATION from TIME, returning a new wall-time value."
   (let ((new-time (copy-time time)))
@@ -654,30 +771,52 @@ begins at time.  If no changes are made, returns nil."
             :hour (- (duration-hour duration))
             :minute (- (duration-minute duration))
             :second (- (duration-second duration))
+            :usec (- (duration-usec duration))
             :destructive t))
     new-time))
 
+(defun date- (date &rest durations)
+  "Subtract each DURATION to DATE, returning a new date value.
+Note that (barring daylight saving time) 12h + 12h will result in a new day, but doing
+it as separate calculations will not, as the time is chopped to a date before being returned."
+  (time->date (apply #'time- (cons (date->time date) durations))))
+
 (defun time-difference (time1 time2)
   "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)))
+                      (time-mjd time1)))
     (if (> day-diff 0)
-	(progn (decf day-diff)
-	       (setf sec-diff (+ (time-second time2)
-				 (- (* 60 60 24)
-				    (time-second time1)))))
+        (progn (decf day-diff)
+               (setf sec-diff (+ (time-second time2)
+                                 (- (* 60 60 24)
+                                    (time-second time1)))))
       (setf sec-diff (- (time-second time2)
-			(time-second time1))))
+                        (time-second time1))))
      (make-duration :day day-diff
                    :second sec-diff))))
     (if (time< time1 time2)
-	(do-diff time1 time2)
+        (do-diff time1 time2)
       (do-diff time2 time1))))
 
+(defun date-difference (date1 date2)
+  "Returns a DURATION representing the difference between TIME1 and
+TIME2."
+  (time-difference (date->time date1) (date->time date2)))
+
+(defun format-date (stream date &key format
+                    (date-separator "-")
+                    (internal-separator " "))
+  "produces on stream the datestring corresponding to the date
+with the given options"
+  (format-time stream (date->time date)
+               :format format
+               :date-separator date-separator
+               :internal-separator internal-separator))
+
 (defun format-time (stream time &key format
                     (date-separator "-")
                     (time-separator ":")
@@ -685,31 +824,27 @@ TIME2."
   "produces on stream the timestring corresponding to the wall-time
 with the given options"
   (let ((*print-circle* nil))
-    (multiple-value-bind (second minute hour day month year dow)
-	(decode-time time)
+    (multiple-value-bind (usec second minute hour day month year dow)
+        (decode-time time)
       (case format
-	(:pretty
-	 (format stream "~A ~A, ~A ~D, ~D"
-		 (pretty-time hour minute)
-		 (day-name dow)
-		 (month-name month)
-		 day
-		 year))
-	(:short-pretty
-	 (format stream "~A, ~D/~D/~D"
-		 (pretty-time hour minute)
-		 month day year))
-	(:iso
-	 (let ((string (iso-timestring time)))
-	   (if stream
-	       (write-string string stream)
-             string)))
-	(t
-	 (format stream "~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D"
-		 year date-separator month date-separator day
-		 internal-separator hour time-separator minute time-separator
-		 second))))))
-  
+        (:pretty
+	   (format stream "~A ~A, ~A ~D, ~D"
+		   (pretty-time hour minute)
+		   (day-name dow)
+		   (month-name month)
+		   day
+		   year))
+        (:short-pretty
+	   (format stream "~A, ~D/~D/~D"
+		   (pretty-time hour minute)
+		   month day year))
+        ((:iso :iso8601) (iso-timestring time :stream stream))
+        (t (format stream "~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D.~6,'0D"
+		   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)
@@ -734,10 +869,10 @@ with the given options"
   (third (mjd-to-gregorian (time-mjd (get-time)))))
 
 (defun current-month ()
-  (second (mjd-to-gregorian (time-mjd (get-time)))))
+  (first (mjd-to-gregorian (time-mjd (get-time)))))
 
 (defun current-day ()
-  (first (mjd-to-gregorian (time-mjd (get-time)))))
+  (second (mjd-to-gregorian (time-mjd (get-time)))))
 
 (defun parse-date-time (string)
   "parses date like 08/08/01, 8.8.2001, eg"
@@ -770,7 +905,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)))
@@ -794,9 +929,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
@@ -829,8 +964,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)
@@ -849,11 +985,16 @@ with the given options"
       (:year
        year))))
 
+(defun date-element (date element)
+  (time-element (date->time date) element))
+
 (defun format-duration (stream duration &key (precision :minute))
   (let ((second (duration-second duration))
         (minute (duration-minute duration))
         (hour (duration-hour duration))
         (day (duration-day duration))
+        (month (duration-month duration))
+        (year (duration-year duration))
         (return (null stream))
         (stream (or stream (make-string-output-stream))))
     (ecase precision
@@ -865,10 +1006,20 @@ with the given options"
        (setf second 0))
       (:second
        t))
-    (if (= 0 day hour minute)
+    (if (= 0 year month day hour minute)
         (format stream "0 minutes")
         (let ((sent? nil))
+          (when (< 0 year)
+            (format stream "~d year~p" year year)
+            (setf sent? t))
+          (when (< 0 month)
+            (when sent?
+              (write-char #\Space stream))
+            (format stream "~d month~p" month month)
+            (setf sent? t))
           (when (< 0 day)
+            (when sent?
+              (write-char #\Space stream))
             (format stream "~d day~p" day day)
             (setf sent? t))
           (when (< 0 hour)
@@ -894,27 +1045,40 @@ with the given options"
   (%make-wall-time :mjd (time-mjd self)))
 
 (defun roll (date &key (year 0) (month 0) (day 0) (second 0) (hour 0)
-                  (minute 0) (destructive nil))
+             (minute 0) (usec 0) (destructive nil))
   (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)))))
+      (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)))
-    (multiple-value-bind (mjd-new sec-new)
-        (floor (+ sec second
-                  (* 60 minute)
-                  (* 60 60 hour)) (* 60 60 24))
-      (if destructive
-          (progn
-            (setf (time-mjd date) (+ mjd mjd-new day)
-                  (time-second date) sec-new)
-            date)
-          (%make-wall-time :mjd (+ mjd mjd-new day)
-                           :second sec-new)))))
+    (multiple-value-bind (sec-new usec-new)
+        (floor (+ usec (time-usec date)
+                  (* 1000000
+                     (+ sec second
+                        (* 60 minute)
+                        (* 60 60 hour))))
+               1000000)
+      (multiple-value-bind (mjd-new sec-new)
+          (floor sec-new (* 60 60 24))
+        (if destructive
+            (progn
+              (setf (time-mjd date) (+ mjd mjd-new day)
+                    (time-second date) sec-new
+                    (time-usec date) usec-new)
+              date)
+            (%make-wall-time :mjd (+ mjd mjd-new day)
+                             :second sec-new
+                             :usec usec-new))))))
 
 (defun roll-to (date size position)
   (ecase size
@@ -981,8 +1145,8 @@ rules"
     doy))
 
 (defun parse-yearstring (string)
-  (let ((year (or (parse-integer-insensitively string) 
-		  (extract-roman string))))
+  (let ((year (or (parse-integer-insensitively string)
+                  (extract-roman string))))
     (when (and year (< 1500 year 2500))
       (make-time :year year))))
 
@@ -1011,69 +1175,111 @@ rules"
 
 
 ;; ------------------------------------------------------------
-;; Parsing iso-8601 timestrings 
+;; Parsing iso-8601 timestrings
 
 (define-condition iso-8601-syntax-error (sql-user-error)
   ((bad-component;; year, month whatever
     :initarg :bad-component
     :reader bad-component))
   (:report (lambda (c stream)
-	     (format stream "Bad component: ~A " (bad-component c)))))
+             (format stream "Bad component: ~A " (bad-component c)))))
 
 (defun parse-timestring (timestring &key (start 0) end junk-allowed)
   "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))  
-  (let ((string (subseq timestring start end)))
-    (if (char= (aref string 0) #\P)
-	(parse-iso-8601-duration string)
-      (parse-iso-8601-time string))))
+  (declare (ignore junk-allowed))
+  (etypecase timestring
+    (wall-time timestring)
+    (date (date->time timestring))
+    (string
+     (let ((string (subseq timestring start end)))
+       (if (char= (aref string 0) #\P)
+           (parse-iso-8601-duration string)
+           (parse-iso-8601-time string))))))
+
+(defun parse-datestring (datestring &key (start 0) end junk-allowed)
+  "parse a ISO 8601 timestring and return the corresponding date.
+Will throw a hissy fit if the date string is a duration. Will ignore any precision beyond day (hour/min/sec/usec)."
+  (etypecase datestring
+    (date datestring)
+    (wall-time (time->date datestring))
+    (string
+     (let ((parsed-value
+             (parse-timestring
+              datestring :start start :end end :junk-allowed junk-allowed)))
+       (etypecase parsed-value
+         (date parsed-value)
+         (wall-time (time->date parsed-value)))))))
+
 
 (defvar *iso-8601-duration-delimiters*
-  '((#\D . :days)
+  '((#\Y . :years)
+    (#\D . :days)
     (#\H . :hours)
-    (#\M . :minutes)
+    (#\M . :months/minutes)
     (#\S . :seconds)))
 
 (defun iso-8601-delimiter (elt)
   (cdr (assoc elt *iso-8601-duration-delimiters*)))
 
-(defun iso-8601-duration-subseq (string start)
-  (let* ((pos (position-if #'iso-8601-delimiter string :start start))
-	 (number (when pos (parse-integer (subseq string start pos)
-                                          :junk-allowed t))))
+(defun iso-8601-duration-subseq (string end)
+  (let* ((pos (position-if #'iso-8601-delimiter string :end end :from-end t))
+         (pos2 (when pos
+                 (position-if-not #'digit-char-p string :end pos :from-end t)))
+         (number (when pos2
+                   (parse-integer
+                    (subseq string (1+ pos2) pos) :junk-allowed t))))
     (when number
       (values number
-	      (1+ pos)
-	      (iso-8601-delimiter (aref string pos))))))
+              (1+ pos)
+              (1+ pos2)
+              (iso-8601-delimiter (aref string pos))))))
 
 (defun parse-iso-8601-duration (string)
   "return a wall-time from a duration string"
   (block parse
-    (let ((days 0) (secs 0) (hours 0) (minutes 0) (index 1))
+    (let ((years 0)
+          (months 0)
+          (days 0)
+          (secs 0)
+          (hours 0)
+          (minutes 0)
+          (index (length string))
+          (months/minutes nil))
       (loop
-       (multiple-value-bind (duration next-index duration-type)
+       (multiple-value-bind (duration end next-index duration-type)
            (iso-8601-duration-subseq string index)
+         (declare (ignore end))
          (case duration-type
+           (:years
+            (incf years duration))
+           (:months/minutes
+            (if months/minutes
+                (incf months duration)
+                (progn
+                  (setq months/minutes t)
+                  (incf minutes duration))))
+           (:days
+            (setq months/minutes t)
+            (incf days duration))
            (:hours
+            (setq months/minutes t)
             (incf hours duration))
-           (:minutes
-            (incf minutes duration))
            (:seconds
             (incf secs duration))
-           (:days
-            (incf days duration))
            (t
-            (return-from parse (make-duration :day days :hour hours
-                                              :minute minutes :second secs))))
+            (return-from parse
+              (make-duration
+               :year years :month months :day days :hour hours
+               :minute minutes :second secs))))
          (setf index next-index))))))
 
 ;; e.g. 2000-11-11 00:00:00-06
 
 (defun parse-iso-8601-time (string)
   "return the wall-time corresponding to the given ISO 8601 datestring"
-  (multiple-value-bind (year month day hour minute second offset)
+  (multiple-value-bind (year month day hour minute second usec offset)
       (syntax-parse-iso-8601 string)
     (make-time :year year
                :month month
@@ -1081,36 +1287,57 @@ formatted date string."
                :hour hour
                :minute minute
                :second second
+               :usec usec
                :offset offset)))
 
 
 (defun syntax-parse-iso-8601 (string)
   ;; use strlen to determine if fractional seconds are present in timestamp
   (let ((strlen (length string))
-	year month day hour minute second gmt-sec-offset)
+        year month day hour minute second usec gmt-sec-offset)
     (handler-case
         (progn
-	  (setf year           (parse-integer string :start 0 :end 4)
+          (setf year           (parse-integer string :start 0 :end 4)
                 month          (parse-integer string :start 5 :end 7)
                 day            (parse-integer string :start 8 :end 10)
                 hour           (if (<= 13 strlen)
                                    (parse-integer string :start 11 :end 13)
-				   0)
+                                   0)
                 minute         (if (<= 16 strlen)
                                    (parse-integer string :start 14 :end 16)
-				   0)
+                                   0)
                 second         (if (<= 19 strlen)
                                    (parse-integer string :start 17 :end 19)
-				   0)
-                gmt-sec-offset (if (<= 20 strlen)
-                                   (let ((skip-to (or (position #\+ string :start 19)
-                                                      (position #\- string :start 19))))
-                                     (if skip-to
-                                         (* 60 60
-                                            (parse-integer string :start skip-to
-							   :end (+ skip-to 3)))
-					 0))
-				   0))
+                                   0))
+          (cond
+            ((and (> strlen 19)
+                  (or (char= #\, (char string 19))
+                      (char= #\. (char string 19))))
+             (multiple-value-bind (parsed-usec usec-end)
+                 (parse-integer string :start 20 :junk-allowed t)
+               (let ((parsed-usec (and parsed-usec
+				       (floor (* parsed-usec (expt 10 (+ 6 (- usec-end) 20)))))))
+		 (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))))
+					    (if skip-to
+						(* 60 60
+						   (parse-integer string :start skip-to
+								  :end (+ skip-to 3)))
+						0))
+					  0)))))
+            (t
+             (setf usec           0
+                   gmt-sec-offset (if (<= 22  strlen)
+                                      (let ((skip-to (or (position #\+ string :start 19)
+                                                         (position #\- string :start 19))))
+                                        (if skip-to
+                                            (* 60 60
+                                               (parse-integer string :start skip-to
+                                                              :end (+ skip-to 3)))
+                                            0))
+                                      0))))
           (unless (< 0 year)
             (error 'iso-8601-syntax-error
                    :bad-component '(year . 0)))
@@ -1120,12 +1347,13 @@ formatted date string."
           (unless (< 0 day)
             (error 'iso-8601-syntax-error
                    :bad-component '(month . 0)))
-          (values year month day hour minute second gmt-sec-offset))
+          (values year month day hour minute second usec gmt-sec-offset))
       (simple-error ()
         (error 'iso-8601-syntax-error
                :bad-component
                (car (find-if (lambda (pair) (null (cdr pair)))
                              `((year . ,year) (month . ,month)
-                               (day . ,day) (hour ,hour)
-                               (minute ,minute) (second ,second)
-                               (timezone ,gmt-sec-offset)))))))))
+                               (day . ,day) (hour . ,hour)
+                               (minute . ,minute) (second . ,second)
+                               (usec . ,usec)
+                               (timezone . ,gmt-sec-offset)))))))))