sql/time.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;;
   4 ;;;; A variety of structures and function for creating and
   5 ;;;; manipulating dates, times, durations and intervals for
   6 ;;;; CLSQL.
   7 ;;;;
   8 ;;;; This file was originally part of ODCL and is Copyright (c) 2002 -
   9 ;;;; 2003 onShore Development, Inc.
  10 ;;;;
  11 ;;;; CLSQL users are granted the rights to distribute and use this software
  12 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  13 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  14 ;;;; *************************************************************************
  15
  16 (in-package #:clsql-sys)
  17
  18 ;; ------------------------------------------------------------
  19 ;; Months
  20
  21 (defvar *month-keywords*
  22   '(:january :february :march :april :may :june :july :august :september
  23     :october :november :december))
  24
  25 (defvar *month-names*
  26   '("" "January" "February" "March" "April" "May" "June" "July" "August"
  27     "September" "October" "November" "December"))
  28
  29 (defun month-name (month-index)
  30   (nth month-index *month-names*))
  31
  32 (defun ordinal-month (month-keyword)
  33   "Return the zero-based month number for the given MONTH keyword."
  34   (position month-keyword *month-keywords*))
  35
  36
  37 ;; ------------------------------------------------------------
  38 ;; Days
  39
  40 (defvar *day-keywords*
  41   '(:sunday :monday :tuesday :wednesday :thursday :friday :saturday))
  42
  43 (defvar *day-names*
  44   '("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"))
  45
  46 (defun day-name (day-index)
  47   (nth day-index *day-names*))
  48
  49 (defun ordinal-day (day-keyword)
  50   "Return the zero-based day number for the given DAY keyword."
  51   (position day-keyword *day-keywords*))
  52
  53
  54 ;; ------------------------------------------------------------
  55 ;; time classes: wall-time, duration
  56
  57
  58 (eval-when (:compile-toplevel :load-toplevel)
  59 (defstruct (wall-time (:conc-name time-)
  60                       (:constructor %make-wall-time)
  61                       (:print-function %print-wall-time))
  62   (mjd 0 :type fixnum)
  63   (second 0 :type fixnum)
  64   (usec 0 :type fixnum)
  65   (is-utc? nil :type boolean))
  66
  67 (defun %print-wall-time (time stream depth)
  68   (declare (ignore depth))
  69   (if *print-escape*
  70       (format stream "#<WALL-TIME: ~a>" (format-time nil time))
  71       (format-time stream time :format :pretty)))
  72
  73 (defstruct (duration (:constructor %make-duration)
  74                      (:print-function %print-duration))
  75   (year 0 :type fixnum)
  76   (month 0 :type fixnum)
  77   (day 0 :type fixnum)
  78   (hour 0 :type fixnum)
  79   (second 0 :type fixnum)
  80   (minute 0 :type fixnum)
  81   (usec 0 :type fixnum))
  82
  83 (defun %print-duration (duration stream depth)
  84   (declare (ignore depth))
  85   (if *print-escape*
  86       (format stream "#<DURATION: ~a>"
  87               (format-duration nil duration :precision :second))
  88       (format-duration stream duration :precision :second)))
  89
  90 (defstruct (date (:constructor %make-date)
  91                  (:print-function %print-date))
  92   (mjd 0 :type fixnum))
  93
  94 (defun %print-date (date stream depth)
  95   (declare (ignore depth))
  96   (if *print-escape*
  97       (format stream "#<DATE: ~a>" (format-date nil date))
  98       (format-date stream date :format :pretty)))
  99
 100 );eval-when
 101
 102 (defun duration-timestring (duration)
 103   (let ((second (duration-second duration))
 104         (minute (duration-minute duration))
 105         (hour (duration-hour duration))
 106         (day (duration-day duration))
 107         (month (duration-month duration))
 108         (year (duration-year duration)))
 109     (format nil "P~dY~dM~dD~dH~dM~dS" year month day hour minute second)))
 110
 111
 112 ;; ------------------------------------------------------------
 113 ;; Constructors
 114
 115 (defun %localtime-timestamp-offset (time)
 116   (when (time-is-utc? time)
 117     (return-from %localtime-timestamp-offset 0))
 118   (multiple-value-bind (tusec tsec tmin thour tday tmonth tyear)
 119       (decode-time time)
 120     (multiple-value-bind (_nsec _sec _min _hour _day _month _year
 121                           _day-of-week _daylight-saving-time-p
 122                           offset)
 123         (local-time:decode-timestamp
 124          (local-time:encode-timestamp
 125           (* 1000 (or tusec 0)) tsec tmin thour tday tmonth tyear))
 126       (declare (ignore _nsec _sec _min _hour _day _month _year
 127                        _day-of-week _daylight-saving-time-p))
 128       offset)))
 129
 130 (defun time-to-utc (in)
 131   "Ensures that if we have a time thats not in UTC, treat it as a localtime,
 132    and convert to UTC"
 133   (if (time-is-utc? in)
 134       in
 135       (let ((newt
 136               (time+ in (make-duration :second (%localtime-timestamp-offset in)))))
 137         (setf (time-is-utc? newt) T)
 138         newt)))
 139
 140 (defun make-time (&key (year 0) (month 1) (day 1) (hour 0) (minute 0)
 141                   (second 0) (usec 0) (offset nil))
 142   (let* ((mjd (gregorian-to-mjd month day year))
 143          (sec (+ (* hour 60 60)
 144                  (* minute 60)
 145                  second (or offset 0)))
 146          (time (multiple-value-bind (day-add raw-sec)
 147                    (floor sec (* 60 60 24))
 148                  (%make-wall-time :mjd (+ mjd day-add)
 149                                   :second raw-sec :usec (or usec 0)
 150                                   :is-utc? (if offset t nil)))))
 151     time))
 152
 153 (defun make-date (&key (year 0) (month 1) (day 1) (hour 0) (minute 0)
 154                        (second 0) (usec 0) (offset nil))
 155   (time->date (make-time :year year :month month :day day :hour hour
 156                          :minute minute :second second :usec usec
 157                          :offset offset)))
 158
 159 (defun copy-time (time)
 160   (%make-wall-time :mjd (time-mjd time)
 161                    :second (time-second time)
 162                    :usec (time-usec time)
 163                    :is-utc? (time-is-utc? time)))
 164
 165 (defun utime->time (utime)
 166   "Return a pair: (GREGORIAN DAY . TIME-OF-DAY)"
 167   (multiple-value-bind (second minute hour day mon year)
 168       (decode-universal-time utime)
 169     (make-time :year year :month mon :day day :hour hour :minute minute
 170                :second second)))
 171
 172 (defun date->time (date)
 173   "Returns a walltime for the given date"
 174   (%make-wall-time :mjd (date-mjd date)))
 175
 176 (defun time->date (time)
 177   "Returns a date for the given wall time (obvious loss in resolution)"
 178   (%make-date :mjd (time-mjd time)))
 179
 180 (defun get-time ()
 181   "Return a pair: (GREGORIAN DAY . TIME-OF-DAY)"
 182   (utime->time (get-universal-time)))
 183
 184 (defun get-date ()
 185   "Returns a date for today"
 186   (time->date (get-time)))
 187
 188 (defun make-duration (&key (year 0) (month 0) (day 0) (hour 0) (minute 0)
 189                       (second 0) (usec 0))
 190   (multiple-value-bind (second-add usec-1000000)
 191       (floor usec 1000000)
 192     (multiple-value-bind (minute-add second-60)
 193         (floor (+ second second-add) 60)
 194       (multiple-value-bind (hour-add minute-60)
 195           (floor (+ minute minute-add) 60)
 196         (multiple-value-bind (day-add hour-24)
 197             (floor (+ hour hour-add) 24)
 198           (%make-duration :year year :month month :day (+ day day-add)
 199                           :hour hour-24
 200                           :minute minute-60
 201                           :second second-60
 202                           :usec usec-1000000))))))
 203
 204
 205 ;; ------------------------------------------------------------
 206 ;; Accessors
 207
 208 (defun time-hms (time)
 209   (multiple-value-bind (hourminute second)
 210       (floor (time-second time) 60)
 211     (multiple-value-bind (hour minute)
 212         (floor hourminute 60)
 213       (values hour minute second))))
 214
 215 (defun time-ymd (time)
 216   (destructuring-bind (month day year)
 217       (mjd-to-gregorian (time-mjd time))
 218     (values year month day)))
 219
 220 (defun time-dow (time)
 221   "Return the 0 indexed Day of the week starting with Sunday"
 222   (mod (+ 3 (time-mjd time)) 7))
 223
 224 (defun decode-time (time)
 225   "returns the decoded time as multiple values: usec, second, minute, hour,
 226   day, month, year, integer day-of-week"
 227   (multiple-value-bind (year month day)
 228       (time-ymd time)
 229     (multiple-value-bind (hour minute second)
 230         (time-hms time)
 231       (values (time-usec time) second minute hour day month year
 232               (mod (+ (time-mjd time) 3) 7)
 233               (time-is-utc? time)))))
 234
 235 (defun date-ymd (date)
 236   (time-ymd (date->time date)))
 237
 238 (defun date-dow (date)
 239   (time-dow (date->time date)))
 240
 241 (defun decode-date (date)
 242   "returns the decoded date as multiple values: day month year integer day-of-week"
 243   (multiple-value-bind (year month day)
 244       (time-ymd (date->time date))
 245     (values day month year (date-dow date))))
 246
 247 ;; duration specific
 248 (defun duration-reduce (duration precision &optional round)
 249   (ecase precision
 250     (:usec
 251      (+ (duration-usec duration)
 252         (* (duration-reduce duration :second) 1000000)))
 253     (:second
 254      (+ (if round
 255             (floor (duration-usec duration) 500000)
 256             0)
 257         (duration-second duration)
 258         (* (duration-reduce duration :minute) 60)))
 259     (:minute
 260      (+ (if round
 261             (floor (duration-second duration) 30)
 262             0)
 263         (duration-minute duration)
 264         (* (duration-reduce duration :hour) 60)))
 265     (:hour
 266      (+ (if round
 267             (floor (duration-minute duration) 30)
 268             0)
 269         (duration-hour duration)
 270         (* (duration-reduce duration :day) 24)))
 271     (:day
 272      (+ (if round
 273             (floor (duration-hour duration) 12)
 274             0)
 275         (duration-day duration)))))
 276
 277
 278 ;; ------------------------------------------------------------
 279 ;; Arithemetic and comparators
 280
 281 (defun duration= (duration-a duration-b)
 282   (= (duration-reduce duration-a :usec)
 283      (duration-reduce duration-b :usec)))
 284
 285 (defun duration< (duration-a duration-b)
 286   (< (duration-reduce duration-a :usec)
 287      (duration-reduce duration-b :usec)))
 288
 289 (defun duration<= (duration-a duration-b)
 290   (<= (duration-reduce duration-a :usec)
 291       (duration-reduce duration-b :usec)))
 292
 293 (defun duration>= (x y)
 294   (duration<= y x))
 295
 296 (defun duration> (x y)
 297   (duration< y x))
 298
 299 (defun %time< (x y)
 300   (setf x (time-to-utc x)
 301         y (time-to-utc y))
 302   (let ((mjd-x (time-mjd x))
 303         (mjd-y (time-mjd y)))
 304     (if (/= mjd-x mjd-y)
 305         (< mjd-x mjd-y)
 306         (if (/= (time-second x) (time-second y))
 307             (< (time-second x) (time-second y))
 308             (< (time-usec x) (time-usec y))))))
 309
 310 (defun %time>= (x y)
 311   (setf x (time-to-utc x)
 312         y (time-to-utc y))
 313   (if (/= (time-mjd x) (time-mjd y))
 314       (>= (time-mjd x) (time-mjd y))
 315       (if (/= (time-second x) (time-second y))
 316           (>= (time-second x) (time-second y))
 317           (>= (time-usec x) (time-usec y)))))
 318
 319 (defun %time<= (x y)
 320   (setf x (time-to-utc x)
 321         y (time-to-utc y))
 322   (if (/= (time-mjd x) (time-mjd y))
 323       (<= (time-mjd x) (time-mjd y))
 324       (if (/= (time-second x) (time-second y))
 325           (<= (time-second x) (time-second y))
 326           (<= (time-usec x) (time-usec y)))))
 327
 328 (defun %time> (x y)
 329   (setf x (time-to-utc x)
 330         y (time-to-utc y))
 331   (if (/= (time-mjd x) (time-mjd y))
 332       (> (time-mjd x) (time-mjd y))
 333       (if (/= (time-second x) (time-second y))
 334           (> (time-second x) (time-second y))
 335           (> (time-usec x) (time-usec y)))))
 336
 337 (defun %time= (x y)
 338   (setf x (time-to-utc x)
 339         y (time-to-utc y))
 340   (and (= (time-mjd x) (time-mjd y))
 341        (= (time-second x) (time-second y))
 342        (= (time-usec x) (time-usec y))))
 343
 344 (defun time= (number &rest more-numbers)
 345   "Returns T if all of its arguments are numerically equal, NIL otherwise."
 346   (do ((nlist more-numbers (cdr nlist)))
 347       ((atom nlist) t)
 348      (declare (list nlist))
 349      (if (not (%time= (car nlist) number)) (return nil))))
 350
 351 (defun time/= (number &rest more-numbers)
 352   "Returns T if no two of its arguments are numerically equal, NIL otherwise."
 353   (do* ((head number (car nlist))
 354         (nlist more-numbers (cdr nlist)))
 355        ((atom nlist) t)
 356      (declare (list nlist))
 357      (unless (do* ((nl nlist (cdr nl)))
 358                   ((atom nl) t)
 359                (declare (list nl))
 360                (if (%time= head (car nl)) (return nil)))
 361        (return nil))))
 362
 363 (defun time< (number &rest more-numbers)
 364   "Returns T if its arguments are in strictly increasing order, NIL otherwise."
 365   (do* ((n number (car nlist))
 366         (nlist more-numbers (cdr nlist)))
 367        ((atom nlist) t)
 368      (declare (list nlist))
 369      (if (not (%time< n (car nlist))) (return nil))))
 370
 371 (defun time> (number &rest more-numbers)
 372   "Returns T if its arguments are in strictly decreasing order, NIL otherwise."
 373   (do* ((n number (car nlist))
 374         (nlist more-numbers (cdr nlist)))
 375        ((atom nlist) t)
 376      (declare (list nlist))
 377      (if (not (%time> n (car nlist))) (return nil))))
 378
 379 (defun time<= (number &rest more-numbers)
 380   "Returns T if arguments are in strictly non-decreasing order, NIL otherwise."
 381   (do* ((n number (car nlist))
 382         (nlist more-numbers (cdr nlist)))
 383        ((atom nlist) t)
 384      (declare (list nlist))
 385      (if (not (%time<= n (car nlist))) (return nil))))
 386
 387 (defun time>= (number &rest more-numbers)
 388   "Returns T if arguments are in strictly non-increasing order, NIL otherwise."
 389   (do* ((n number (car nlist))
 390         (nlist more-numbers (cdr nlist)))
 391        ((atom nlist) t)
 392      (declare (list nlist))
 393      (if (not (%time>= n (car nlist))) (return nil))))
 394
 395 (defun time-max (number &rest more-numbers)
 396   "Returns the greatest of its arguments."
 397   (do ((nlist more-numbers (cdr nlist))
 398        (result number))
 399       ((null nlist) (return result))
 400      (declare (list nlist))
 401      (if (%time> (car nlist) result) (setf result (car nlist)))))
 402
 403 (defun time-min (number &rest more-numbers)
 404   "Returns the least of its arguments."
 405   (do ((nlist more-numbers (cdr nlist))
 406        (result number))
 407       ((null nlist) (return result))
 408      (declare (list nlist))
 409      (if (%time< (car nlist) result) (setf result (car nlist)))))
 410
 411 (defun time-compare (time-a time-b)
 412   (let ((mjd-a (time-mjd time-a))
 413         (mjd-b (time-mjd time-b))
 414         (sec-a (time-second time-a))
 415         (sec-b (time-second time-b))
 416         (usec-a (time-usec time-a))
 417         (usec-b (time-usec time-b)))
 418     (if (= mjd-a mjd-b)
 419         (if (= sec-a sec-b)
 420             (if (= usec-a usec-b)
 421                 :equal
 422                 (if (< usec-a usec-b)
 423                     :less-than
 424                     :greater-than))
 425             (if (< sec-a sec-b)
 426                 :less-than
 427                 :greater-than))
 428         (if (< mjd-a mjd-b)
 429             :less-than
 430             :greater-than))))
 431
 432 ; now the same for dates
 433 (eval-when (:compile-toplevel :load-toplevel)
 434 (defun replace-string (string1 search-string replace-string &key (test #'string=))
 435   "Search within string1 for search-string, replace with replace-string, non-destructively."
 436   (let ((replace-string-length (length replace-string))
 437         (search-string-length  (length search-string)))
 438     (labels ((sub-replace-string (current-string position)
 439                (let ((found-position (search search-string current-string :test test :start2 position)))
 440                  (if (null found-position)
 441                      current-string
 442                      (sub-replace-string (concatenate 'string
 443                                                       (subseq current-string 0 found-position)
 444                                                       replace-string
 445                                                       (subseq current-string (+ found-position search-string-length)))
 446                                          (+ position replace-string-length))))))
 447       (sub-replace-string string1 0))))
 448 );eval-when
 449
 450 (defmacro wrap-time-for-date (time-func &key (result-func))
 451   (let ((date-func (intern (replace-string (symbol-name time-func)
 452                                            (symbol-name-default-case "TIME")
 453                                            (symbol-name-default-case "DATE")))))
 454     `(defun ,date-func (number &rest more-numbers)
 455       (let ((result (apply #',time-func (mapcar #'date->time (cons number more-numbers)))))
 456         ,(if result-func
 457              `(funcall #',result-func result)
 458              'result)))))
 459
 460 (wrap-time-for-date time=)
 461 (wrap-time-for-date time/=)
 462 (wrap-time-for-date time<)
 463 (wrap-time-for-date time>)
 464 (wrap-time-for-date time<=)
 465 (wrap-time-for-date time>=)
 466 (wrap-time-for-date time-max :result-func time->date)
 467 (wrap-time-for-date time-min :result-func time->date)
 468
 469 (defun date-compare (date-a date-b)
 470   (time-compare (date->time date-a) (date->time date-b)))
 471
 472 ;; ------------------------------------------------------------
 473 ;; Formatting and output
 474 (defun db-timestring (time &key stream )
 475   "return the string to store the given time in the database"
 476   (if stream
 477       (progn (write-char #\' stream) (iso-timestring time :stream stream) (write-char #\' stream))
 478       (concatenate 'string "'" (iso-timestring time) "'")))
 479
 480 (defun iso-timestring (time &key stream)
 481   (multiple-value-bind (usec sec min hour day month year dow is-utc?)
 482       (decode-time time)
 483     (declare (ignore dow))
 484     (flet ((fmt (stream)
 485              (when (< year 1000) (princ #\0 stream))
 486              (when (< year 100) (princ #\0 stream))
 487              (when (< year 10) (princ #\0 stream))
 488              (princ year stream)
 489              (princ #\- stream)
 490              (when (< month 10) (princ #\0 stream))
 491              (princ month stream)
 492              (princ #\- stream)
 493              (when (< day 10) (princ #\0 stream))
 494              (princ day stream)
 495              (princ #\T stream) ;strict ISO says T here isn't optional.
 496              (when (< hour 10) (princ #\0 stream))
 497              (princ hour stream)
 498              (princ #\: stream)
 499              (when (< min 10) (princ #\0 stream))
 500              (princ min stream)
 501              (princ #\: stream)
 502              (when (< sec 10) (princ #\0 stream))
 503              (princ sec stream)
 504              (when (and usec (plusp usec))
 505                ;; we dont do this because different dbs support differnt precision levels
 506                (princ #\. stream)
 507                (loop for i from 5 downto 0
 508                      for x10 = (expt 10 i)
 509                      do (multiple-value-bind (quo rem)
 510                             (floor (/ usec x10))
 511                           (setf usec (- usec (* quo x10)))
 512                           (princ quo stream)
 513                           (when (= rem 0) (return)))))
 514              (when is-utc? (princ #\Z stream))
 515              nil))
 516       (if stream
 517           (fmt stream)
 518           (with-output-to-string (stream)
 519             (fmt stream))))))
 520
 521 (defun db-datestring (date)
 522   (db-timestring (date->time date)))
 523 (defun iso-datestring (date)
 524   (iso-timestring (date->time date)))
 525
 526
 527 ;; ------------------------------------------------------------
 528 ;; Intervals
 529
 530 (defstruct interval
 531   (start nil)
 532   (end nil)
 533   (name nil)
 534   (contained nil)
 535   (type nil)
 536   (data nil))
 537
 538 ;; fix : should also return :contains / :contained
 539
 540 (defun interval-relation (x y)
 541   "Compare the relationship of node x to node y. Returns either
 542 :contained :contains :follows :overlaps or :precedes."
 543   (let ((xst  (interval-start x))
 544         (xend (interval-end x))
 545         (yst  (interval-start y))
 546         (yend (interval-end y)))
 547     (case (time-compare xst yst)
 548       (:equal
 549        (case (time-compare xend yend)
 550          (:less-than
 551           :contained)
 552          ((:equal :greater-than)
 553           :contains)))
 554       (:greater-than
 555        (case (time-compare xst yend)
 556          ((:equal :greater-than)
 557           :follows)
 558          (:less-than
 559           (case (time-compare xend yend)
 560             ((:less-than :equal)
 561              :contained)
 562             ((:greater-than)
 563              :overlaps)))))
 564       (:less-than
 565        (case (time-compare xend yst)
 566          ((:equal :less-than)
 567           :precedes)
 568          (:greater-than
 569           (case (time-compare xend yend)
 570             (:less-than
 571              :overlaps)
 572             ((:equal :greater-than)
 573              :contains))))))))
 574
 575 ;; ------------------------------------------------------------
 576 ;; interval lists
 577
 578 (defun sort-interval-list (list)
 579   (sort list (lambda (x y)
 580                (case (interval-relation x y)
 581                  ((:precedes :contains) t)
 582                  ((:follows :overlaps :contained) nil)))))
 583
 584 ;; interval push will return its list of intervals in strict order.
 585 (defun interval-push (interval-list interval &optional container-rule)
 586   (declare (ignore container-rule))
 587   (let ((sorted-list (sort-interval-list interval-list)))
 588     (dotimes (x (length sorted-list))
 589       (let ((elt (nth x sorted-list)))
 590         (case (interval-relation elt interval)
 591           (:follows
 592            (return-from interval-push (insert-at-index x sorted-list interval)))
 593           (:contains
 594            (return-from interval-push
 595              (replace-at-index x sorted-list
 596                                (make-interval :start (interval-start elt)
 597                                               :end (interval-end elt)
 598                                               :type (interval-type elt)
 599                                               :contained (interval-push (interval-contained elt) interval)
 600                                               :data (interval-data elt)))))
 601           ((:overlaps :contained)
 602            (error "Overlap")))))
 603     (append sorted-list (list interval))))
 604
 605 ;; interval lists
 606
 607 (defun interval-match (list time)
 608   "Return the index of the first interval in list containing time"
 609   ;; this depends on ordering of intervals!
 610   (let ((list (sort-interval-list list)))
 611     (dotimes (x (length list))
 612       (let ((elt (nth x list)))
 613         (when (and (time<= (interval-start elt) time)
 614                    (time< time (interval-end elt)))
 615           (return-from interval-match x))))))
 616
 617 (defun interval-clear (list time)
 618   (dotimes (x (length list))
 619     (let ((elt (nth x list)))
 620       (when (and (time<= (interval-start elt) time)
 621                  (time< time (interval-end elt)))
 622         (if (interval-match (interval-contained elt) time)
 623             (return-from interval-clear
 624               (replace-at-index x list
 625                                 (make-interval :start (interval-start elt)
 626                                                :end (interval-end elt)
 627                                                :type (interval-type elt)
 628                                                :contained (interval-clear (interval-contained elt) time)
 629                                                :data (interval-data elt))))
 630             (return-from interval-clear
 631               (delete-at-index x list)))))))
 632
 633 (defun interval-edit (list time start end &optional tag)
 634   "Attempts to modify the most deeply nested interval in list which
 635 begins at time.  If no changes are made, returns nil."
 636   ;; function required sorted interval list
 637   (let ((list (sort-interval-list list)))
 638     (if (null list) nil
 639       (dotimes (x (length list))
 640         (let ((elt (nth x list)))
 641           (when (and (time<= (interval-start elt) time)
 642                      (time< time (interval-end elt)))
 643             (or (interval-edit (interval-contained elt) time start end tag)
 644                 (cond ((and (< 0 x)
 645                             (time< start (interval-end (nth (1- x) list))))
 646                        (error "Overlap of previous interval"))
 647                       ((and (< x (1- (length list)))
 648                             (time< (interval-start (nth (1+ x) list)) end))
 649                        (error "~S ~S ~S ~S Overlap of next interval" x (length list) (interval-start (nth (1+ x) list)) end ))
 650                       ((time= (interval-start elt) time)
 651                        (return-from interval-edit
 652                          (replace-at-index x list
 653                                            (make-interval :start start
 654                                                           :end end
 655                                                           :type (interval-type elt)
 656                                                           :contained (restrict-intervals (interval-contained elt) start end)
 657                                                           :data (or tag (interval-data elt))))))))))))))
 658
 659 (defun restrict-intervals (list start end &aux newlist)
 660   (let ((test-interval (make-interval :start start :end end)))
 661     (dolist (elt list)
 662       (when (equal :contained
 663                    (interval-relation elt test-interval))
 664         (push elt newlist)))
 665     (nreverse newlist)))
 666
 667 ;;; utils from odcl/list.lisp
 668
 669 (defun replace-at-index (idx list elt)
 670   (cond ((= idx 0)
 671          (cons elt (cdr list)))
 672         ((= idx (1- (length list)))
 673          (append (butlast list) (list elt)))
 674         (t
 675          (append (subseq list 0 idx)
 676                  (list elt)
 677                  (subseq list (1+ idx))))))
 678
 679 (defun insert-at-index (idx list elt)
 680   (cond ((= idx 0)
 681          (cons elt list))
 682         ((= idx (1- (length list)))
 683          (append list (list elt)))
 684         (t
 685          (append (subseq list 0 idx)
 686                  (list elt)
 687                  (subseq list idx)))))
 688
 689 (defun delete-at-index (idx list)
 690   (cond ((= idx 0)
 691          (cdr list))
 692         ((= idx (1- (length list)))
 693          (butlast list))
 694         (t
 695          (append (subseq list 0 idx)
 696                  (subseq list (1+ idx))))))
 697
 698
 699 ;; ------------------------------------------------------------
 700 ;; return MJD for Gregorian date
 701
 702 (defun gregorian-to-mjd (month day year)
 703   (let ((b 0)
 704         (month-adj month)
 705         (year-adj (if (< year 0)
 706                       (+ year 1)
 707                       year))
 708         d
 709         c)
 710     (when (< month 3)
 711       (incf month-adj 12)
 712       (decf year-adj))
 713     (unless (or (< year 1582)
 714                 (and (= year 1582)
 715                      (or (< month 10)
 716                          (and (= month 10)
 717                               (< day 15)))))
 718       (let ((a (floor (/ year-adj 100))))
 719         (setf b (+ (- 2 a) (floor (/ a 4))))))
 720     (if (< year-adj 0)
 721         (setf c (floor (- (* 365.25d0 year-adj) 679006.75d0)))
 722         (setf c (floor (- (* 365.25d0 year-adj) 679006d0))))
 723     (setf d (floor (* 30.6001 (+ 1 month-adj))))
 724     ;; (cmsg "b ~s c ~s d ~s day ~s" b c d day)
 725     (+ b c d day)))
 726
 727 ;; convert MJD to Gregorian date
 728
 729 (defun mjd-to-gregorian (mjd)
 730   (let (z r g a b c year month day)
 731     (setf z (floor (+ mjd 678882)))
 732     (setf r (- (+ mjd 678882) z))
 733     (setf g (- z .25))
 734     (setf a (floor (/ g 36524.25)))
 735     (setf b (- a (floor (/ a 4))))
 736     (setf year (floor (/ (+ b g) 365.25)))
 737     (setf c (- (+ b z) (floor (* 365.25 year))))
 738     (setf month (truncate (/ (+ (* 5 c) 456) 153)))
 739     (setf day (+ (- c (truncate (/ (- (* 153 month) 457) 5))) r))
 740     (when (> month 12)
 741       (incf year)
 742       (decf month 12))
 743     (list month day year)))
 744
 745 (defun duration+ (time &rest durations)
 746   "Add each DURATION to TIME, returning a new wall-time value."
 747   (let ((year   (duration-year time))
 748         (month  (duration-month time))
 749         (day    (duration-day time))
 750         (hour   (duration-hour time))
 751         (minute (duration-minute time))
 752         (second (duration-second time))
 753         (usec   (duration-usec time)))
 754     (dolist (duration durations)
 755       (incf year    (duration-year duration))
 756       (incf month   (duration-month duration))
 757       (incf day     (duration-day duration))
 758       (incf hour    (duration-hour duration))
 759       (incf minute  (duration-minute duration))
 760       (incf second  (duration-second duration))
 761       (incf usec    (duration-usec duration)))
 762     (make-duration :year year :month month :day day :hour hour :minute minute
 763                    :second second :usec usec)))
 764
 765 (defun duration- (duration &rest durations)
 766     "Subtract each DURATION from TIME, returning a new duration value."
 767   (let ((year   (duration-year duration))
 768         (month  (duration-month duration))
 769         (day    (duration-day duration))
 770         (hour   (duration-hour duration))
 771         (minute (duration-minute duration))
 772         (second (duration-second duration))
 773         (usec   (duration-usec duration)))
 774     (dolist (duration durations)
 775       (decf year    (duration-year duration))
 776       (decf month   (duration-month duration))
 777       (decf day     (duration-day duration))
 778       (decf hour    (duration-hour duration))
 779       (decf minute  (duration-minute duration))
 780       (decf second  (duration-second duration))
 781       (decf usec    (duration-usec duration)))
 782     (make-duration :year year :month month :day day :hour hour :minute minute
 783                    :second second :usec usec)))
 784
 785 ;; Date + Duration
 786
 787 (defun time+ (time &rest durations)
 788   "Add each DURATION to TIME, returning a new wall-time value."
 789   (let ((new-time (copy-time time)))
 790     (dolist (duration durations)
 791       (roll new-time
 792             :year (duration-year duration)
 793             :month (duration-month duration)
 794             :day (duration-day duration)
 795             :hour (duration-hour duration)
 796             :minute (duration-minute duration)
 797             :second (duration-second duration)
 798             :usec (duration-usec duration)
 799             :destructive t))
 800     new-time))
 801
 802 (defun date+ (date &rest durations)
 803   "Add each DURATION to DATE, returning a new date value.
 804 Note that (barring daylight saving time) 12h + 12h will result in a new day, but doing
 805 it as separate calculations will not, as the time is chopped to a date before being returned."
 806   (time->date (apply #'time+ (cons (date->time date) durations))))
 807
 808 (defun time- (time &rest durations)
 809   "Subtract each DURATION from TIME, returning a new wall-time value."
 810   (let ((new-time (copy-time time)))
 811     (dolist (duration durations)
 812       (roll new-time
 813             :year (- (duration-year duration))
 814             :month (- (duration-month duration))
 815             :day (- (duration-day duration))
 816             :hour (- (duration-hour duration))
 817             :minute (- (duration-minute duration))
 818             :second (- (duration-second duration))
 819             :usec (- (duration-usec duration))
 820             :destructive t))
 821     new-time))
 822
 823 (defun date- (date &rest durations)
 824   "Subtract each DURATION to DATE, returning a new date value.
 825 Note that (barring daylight saving time) 12h + 12h will result in a new day, but doing
 826 it as separate calculations will not, as the time is chopped to a date before being returned."
 827   (time->date (apply #'time- (cons (date->time date) durations))))
 828
 829 (defun time-difference (time1 time2)
 830   "Returns a DURATION representing the difference between TIME1 and
 831 TIME2."
 832   (flet ((do-diff (time1 time2)
 833
 834   (let (day-diff sec-diff)
 835     (setf day-diff (- (time-mjd time2)
 836                       (time-mjd time1)))
 837     (if (> day-diff 0)
 838         (progn (decf day-diff)
 839                (setf sec-diff (+ (time-second time2)
 840                                  (- (* 60 60 24)
 841                                     (time-second time1)))))
 842       (setf sec-diff (- (time-second time2)
 843                         (time-second time1))))
 844      (make-duration :day day-diff
 845                    :second sec-diff))))
 846     (if (time< time1 time2)
 847         (do-diff time1 time2)
 848       (do-diff time2 time1))))
 849
 850 (defun date-difference (date1 date2)
 851   "Returns a DURATION representing the difference between TIME1 and
 852 TIME2."
 853   (time-difference (date->time date1) (date->time date2)))
 854
 855 (defun format-date (stream date &key format
 856                     (date-separator "-")
 857                     (internal-separator " "))
 858   "produces on stream the datestring corresponding to the date
 859 with the given options"
 860   (format-time stream (date->time date)
 861                :format format
 862                :date-separator date-separator
 863                :internal-separator internal-separator))
 864
 865 (defun format-time (stream time &key format
 866                     (date-separator "-")
 867                     (time-separator ":")
 868                     (internal-separator " "))
 869   "produces on stream the timestring corresponding to the wall-time
 870 with the given options"
 871   (let ((*print-circle* nil))
 872     (multiple-value-bind (usec second minute hour day month year dow is-utc?)
 873         (decode-time time)
 874       (case format
 875         (:pretty
 876            (format stream "~A ~A, ~A ~D, ~D"
 877                    (pretty-time hour minute)
 878                    (day-name dow)
 879                    (month-name month)
 880                    day
 881                    year))
 882         (:short-pretty
 883            (format stream "~A, ~D/~D/~D"
 884                    (pretty-time hour minute)
 885                    month day year))
 886         ((:iso :iso8601) (iso-timestring time :stream stream))
 887         (t (format stream "~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D.~6,'0D~A"
 888                    year date-separator month date-separator day
 889                    internal-separator hour time-separator minute time-separator
 890                    second usec
 891                    (if is-utc? "Z" ""))
 892          )))))
 893
 894 (defun pretty-time (hour minute)
 895   (cond
 896    ((eq hour 0)
 897     (format nil "12:~2,'0D AM" minute))
 898    ((eq hour 12)
 899     (format nil "12:~2,'0D PM" minute))
 900    ((< hour 12)
 901     (format nil "~D:~2,'0D AM" hour minute))
 902    ((and (> hour 12) (< hour 24))
 903     (format nil "~D:~2,'0D PM" (- hour 12) minute))
 904    (t
 905     (error "pretty-time got bad hour"))))
 906
 907 (defun leap-days-in-days (days)
 908   ;; return the number of leap days between Mar 1 2000 and
 909   ;; (Mar 1 2000) + days, where days can be negative
 910   (if (< days 0)
 911       (ceiling (/ (- days) (* 365 4)))
 912       (floor (/ days (* 365 4)))))
 913
 914 (defun current-year ()
 915   (third (mjd-to-gregorian (time-mjd (get-time)))))
 916
 917 (defun current-month ()
 918   (first (mjd-to-gregorian (time-mjd (get-time)))))
 919
 920 (defun current-day ()
 921   (second (mjd-to-gregorian (time-mjd (get-time)))))
 922
 923 (defun parse-date-time (string)
 924   "parses date like 08/08/01, 8.8.2001, eg"
 925   (when (> (length string) 1)
 926     (let ((m (current-month))
 927           (d (current-day))
 928           (y (current-year)))
 929       (let ((integers (mapcar #'parse-integer (hork-integers string))))
 930         (case (length integers)
 931           (1
 932            (setf y (car integers)))
 933           (2
 934            (setf m (car integers))
 935            (setf y (cadr integers)))
 936           (3
 937            (setf m (car integers))
 938            (setf d (cadr integers))
 939            (setf y (caddr integers)))
 940           (t
 941            (return-from parse-date-time))))
 942       (when (< y 100)
 943         (incf y 2000))
 944       (make-time :year y :month m :day d))))
 945
 946 (defun hork-integers (input)
 947   (let ((output '())
 948         (start 0))
 949     (dotimes (x (length input))
 950       (unless (<= 48 (char-code (aref input x)) 57)
 951         (push (subseq input start x) output)
 952         (setf start (1+ x))))
 953     (nreverse (push (subseq input start) output))))
 954
 955 (defun merged-time (day time-of-day)
 956   (%make-wall-time :mjd (time-mjd day)
 957                    :second (time-second time-of-day)))
 958
 959 (defun time-meridian (hours)
 960   (cond ((= hours 0)
 961          (values 12 "AM"))
 962         ((= hours 12)
 963          (values 12 "PM"))
 964         ((< 12 hours)
 965          (values (- hours 12) "PM"))
 966         (t
 967          (values hours "AM"))))
 968
 969 (defgeneric to-string (val &rest keys)
 970   )
 971
 972 (defmethod to-string ((time wall-time) &rest keys)
 973   (destructuring-bind (&key (style :daytime) &allow-other-keys)
 974       keys
 975     (print-date time style)))
 976
 977 (defun print-date (time &optional (style :daytime))
 978   (multiple-value-bind (usec second minute hour day month year dow)
 979       (decode-time time)
 980     (declare (ignore usec second))
 981     (multiple-value-bind (hours meridian)
 982         (time-meridian hour)
 983       (ecase style
 984         (:time-of-day
 985          ;; 2:00 PM
 986          (format nil "~d:~2,'0d ~a" hours minute meridian))
 987         (:long-day
 988          ;; October 11th, 2000
 989          (format nil "~a ~d, ~d" (month-name month) day year))
 990         (:month
 991          ;; October
 992          (month-name month))
 993         (:month-year
 994          ;; October 2000
 995          (format nil "~a ~d" (month-name month) year))
 996         (:full
 997          ;; 11:08 AM, November 22, 2002
 998          (format nil "~d:~2,'0d ~a, ~a ~d, ~d"
 999                  hours minute meridian (month-name month) day year))
1000         (:full+weekday
1001          ;; 11:09 AM Friday, November 22, 2002
1002          (format nil "~d:~2,'0d ~a ~a, ~a ~d, ~d"
1003                  hours minute meridian (nth dow *day-names*)
1004                  (month-name month) day year))
1005         (:daytime
1006          ;; 11:09 AM, 11/22/2002
1007          (format-time nil time :format :short-pretty))
1008         (:day
1009          ;; 11/22/2002
1010          (format nil "~d/~d/~d" month day year))))))
1011
1012 (defun time-element (time element)
1013   (multiple-value-bind (usec second minute hour day month year dow)
1014       (decode-time time)
1015     (declare (ignore usec))
1016     (ecase element
1017       (:seconds
1018        second)
1019       (:minutes
1020        minute)
1021       (:hours
1022        hour)
1023       (:day-of-month
1024        day)
1025       (:integer-day-of-week
1026        dow)
1027       (:day-of-week
1028        (nth dow *day-keywords*))
1029       (:month
1030        month)
1031       (:year
1032        year))))
1033
1034 (defun date-element (date element)
1035   (time-element (date->time date) element))
1036
1037 (defun format-duration (stream duration &key (precision :minute))
1038   (let ((second (duration-second duration))
1039         (minute (duration-minute duration))
1040         (hour (duration-hour duration))
1041         (day (duration-day duration))
1042         (month (duration-month duration))
1043         (year (duration-year duration))
1044         (return (null stream))
1045         (stream (or stream (make-string-output-stream))))
1046     (ecase precision
1047       (:day
1048        (setf hour 0 second 0 minute 0))
1049       (:hour
1050        (setf second 0 minute 0))
1051       (:minute
1052        (setf second 0))
1053       (:second
1054        t))
1055     (if (= 0 year month day hour minute)
1056         (format stream "0 minutes")
1057         (let ((sent? nil))
1058           (when (< 0 year)
1059             (format stream "~d year~p" year year)
1060             (setf sent? t))
1061           (when (< 0 month)
1062             (when sent?
1063               (write-char #\Space stream))
1064             (format stream "~d month~p" month month)
1065             (setf sent? t))
1066           (when (< 0 day)
1067             (when sent?
1068               (write-char #\Space stream))
1069             (format stream "~d day~p" day day)
1070             (setf sent? t))
1071           (when (< 0 hour)
1072             (when sent?
1073               (write-char #\Space stream))
1074             (format stream "~d hour~p" hour hour)
1075             (setf sent? t))
1076           (when (< 0 minute)
1077             (when sent?
1078               (write-char #\Space stream))
1079             (format stream "~d min~p" minute minute)
1080             (setf sent? t))
1081           (when (< 0 second)
1082             (when sent?
1083               (write-char #\Space stream))
1084             (format stream "~d sec~p" second second))))
1085     (when return
1086       (get-output-stream-string stream))))
1087
1088 (defgeneric midnight (self))
1089 (defmethod midnight ((self wall-time))
1090   "truncate hours, minutes and seconds"
1091   (%make-wall-time :mjd (time-mjd self)))
1092
1093 (defun roll (date &key (year 0) (month 0) (day 0) (second 0) (hour 0)
1094              (minute 0) (usec 0) (destructive nil))
1095   (unless (= 0 year month)
1096     (multiple-value-bind (year-orig month-orig day-orig)
1097         (time-ymd date)
1098       (multiple-value-bind (new-year new-month)
1099          (floor (+ month month-orig (* 12 (+ year year-orig))) 12)
1100        (let ((new-date (make-time :year new-year
1101                                   :month new-month
1102                                   :day day-orig
1103                                   :second (time-second date)
1104                                   :usec usec)))
1105          (if destructive
1106              (setf (time-mjd date) (time-mjd new-date))
1107              (setq date new-date))))))
1108   (let ((mjd (time-mjd date))
1109         (sec (time-second date)))
1110     (multiple-value-bind (sec-new usec-new)
1111         (floor (+ usec (time-usec date)
1112                   (* 1000000
1113                      (+ sec second
1114                         (* 60 minute)
1115                         (* 60 60 hour))))
1116                1000000)
1117       (multiple-value-bind (mjd-new sec-new)
1118           (floor sec-new (* 60 60 24))
1119         (if destructive
1120             (progn
1121               (setf (time-mjd date) (+ mjd mjd-new day)
1122                     (time-second date) sec-new
1123                     (time-usec date) usec-new)
1124               date)
1125             (%make-wall-time :mjd (+ mjd mjd-new day)
1126                              :second sec-new
1127                              :usec usec-new))))))
1128
1129 (defun roll-to (date size position)
1130   (ecase size
1131     (:month
1132      (ecase position
1133        (:beginning
1134         (roll date :day (+ 1
1135                            (- (time-element date :day-of-month)))))
1136        (:end
1137         (roll date :day (+ (days-in-month (time-element date :month)
1138                                           (time-element date :year))
1139                            (- (time-element date :day-of-month)))))))))
1140
1141 (defun week-containing (time)
1142   (let* ((midn (midnight time))
1143          (dow (time-element midn :integer-day-of-week)))
1144     (list (roll midn :day (- dow))
1145           (roll midn :day (- 7 dow)))))
1146
1147 (defun leap-year? (year)
1148   "t if YEAR is a leap yeap in the Gregorian calendar"
1149   (and (= 0 (mod year 4))
1150        (or (not (= 0 (mod year 100)))
1151            (= 0 (mod year 400)))))
1152
1153 (defun valid-month-p (month)
1154   "t if MONTH exists in the Gregorian calendar"
1155   (<= 1 month 12))
1156
1157 (defun valid-gregorian-date-p (date)
1158   "t if DATE (year month day) exists in the Gregorian calendar"
1159   (let ((max-day (days-in-month (nth 1 date) (nth 0 date))))
1160     (<= 1 (nth 2 date) max-day)))
1161
1162 (defun days-in-month (month year &key (careful t))
1163   "the number of days in MONTH of YEAR, observing Gregorian leap year
1164 rules"
1165   (declare (type fixnum month year))
1166   (when careful
1167     (check-type month (satisfies valid-month-p)
1168                 "between 1 (January) and 12 (December)"))
1169   (if (eql month 2)                     ; feb
1170       (if (leap-year? year)
1171           29 28)
1172       (let ((even (mod (1- month) 2)))
1173         (if (< month 8)                 ; aug
1174             (- 31 even)
1175             (+ 30 even)))))
1176
1177 (defun day-of-year (year month day &key (careful t))
1178   "the day number within the year of the date DATE.  For example,
1179 1987 1 1 returns 1"
1180   (declare (type fixnum year month day))
1181   (when careful
1182     (let ((date (list year month day)))
1183     (check-type date (satisfies valid-gregorian-date-p)
1184                 "a valid Gregorian date")))
1185   (let ((doy (+ day (* 31 (1- month)))))
1186     (declare (type fixnum doy))
1187     (when (< 2 month)
1188       (setf doy (- doy (floor (+ 23 (* 4 month)) 10)))
1189       (when (leap-year? year)
1190         (incf doy)))
1191     doy))
1192
1193 (defun parse-yearstring (string)
1194   (let ((year (or (parse-integer-insensitively string)
1195                   (extract-roman string))))
1196     (when (and year (< 1500 year 2500))
1197       (make-time :year year))))
1198
1199 (defun parse-integer-insensitively (string)
1200   (let ((start (position-if #'digit-char-p string))
1201         (end   (position-if #'digit-char-p string :from-end t)))
1202     (when (and start end)
1203       (parse-integer (subseq string start (1+ end)) :junk-allowed t))))
1204
1205 (defvar *roman-digits*
1206   '((#\M . 1000)
1207     (#\D . 500)
1208     (#\C . 100)
1209     (#\L . 50)
1210     (#\X . 10)
1211     (#\V . 5)
1212     (#\I . 1)))
1213
1214 (defun extract-roman (string &aux parse)
1215   (dotimes (x (length string))
1216     (let ((val (cdr (assoc (aref string x) *roman-digits*))))
1217       (when (and val parse (< (car parse) val))
1218         (push (- (pop parse)) parse))
1219       (push val parse)))
1220   (apply #'+ parse))
1221
1222
1223 ;; ------------------------------------------------------------
1224 ;; Parsing iso-8601 timestrings
1225
1226 (define-condition iso-8601-syntax-error (sql-user-error)
1227   ((input :initarg :input :reader input)
1228    (bad-component;; year, month whatever
1229     :initarg :bad-component
1230     :reader bad-component))
1231   (:report (lambda (c stream)
1232              (format stream "Bad component: ~A of input: ~A "
1233                      (bad-component c) (input c)))))
1234
1235 (defun parse-timestring (timestring &key (start 0) end junk-allowed)
1236   "parse a timestring and return the corresponding wall-time.  If the
1237 timestring starts with P, read a duration; otherwise read an ISO 8601
1238 formatted date string."
1239   (declare (ignore junk-allowed))
1240   (etypecase timestring
1241     (wall-time timestring)
1242     (date (date->time timestring))
1243     (string
1244      (let ((string (subseq timestring start end)))
1245        (if (char= (aref string 0) #\P)
1246            (parse-iso-8601-duration string)
1247            (parse-iso-8601-time string))))))
1248
1249 (defun parse-datestring (datestring &key (start 0) end junk-allowed)
1250   "parse a ISO 8601 timestring and return the corresponding date.
1251 Will throw a hissy fit if the date string is a duration. Will ignore any precision beyond day (hour/min/sec/usec)."
1252   (etypecase datestring
1253     (date datestring)
1254     (wall-time (time->date datestring))
1255     (string
1256      (let ((parsed-value
1257              (parse-timestring
1258               datestring :start start :end end :junk-allowed junk-allowed)))
1259        (etypecase parsed-value
1260          (date parsed-value)
1261          (wall-time (time->date parsed-value)))))))
1262
1263
1264 (defvar *iso-8601-duration-delimiters*
1265   '((#\Y . :years)
1266     (#\D . :days)
1267     (#\H . :hours)
1268     (#\M . :months/minutes)
1269     (#\S . :seconds)))
1270
1271 (defun iso-8601-delimiter (elt)
1272   (cdr (assoc elt *iso-8601-duration-delimiters*)))
1273
1274 (defun iso-8601-duration-subseq (string end)
1275   (let* ((pos (position-if #'iso-8601-delimiter string :end end :from-end t))
1276          (pos2 (when pos
1277                  (position-if-not #'digit-char-p string :end pos :from-end t)))
1278          (number (when pos2
1279                    (parse-integer
1280                     (subseq string (1+ pos2) pos) :junk-allowed t))))
1281     (when number
1282       (values number
1283               (1+ pos)
1284               (1+ pos2)
1285               (iso-8601-delimiter (aref string pos))))))
1286
1287 (defun parse-iso-8601-duration (string)
1288   "return a wall-time from a duration string"
1289   (block parse
1290     (let ((years 0)
1291           (months 0)
1292           (days 0)
1293           (secs 0)
1294           (hours 0)
1295           (minutes 0)
1296           (index (length string))
1297           (months/minutes nil))
1298       (loop
1299        (multiple-value-bind (duration end next-index duration-type)
1300            (iso-8601-duration-subseq string index)
1301          (declare (ignore end))
1302          (case duration-type
1303            (:years
1304             (incf years duration))
1305            (:months/minutes
1306             (if months/minutes
1307                 (incf months duration)
1308                 (progn
1309                   (setq months/minutes t)
1310                   (incf minutes duration))))
1311            (:days
1312             (setq months/minutes t)
1313             (incf days duration))
1314            (:hours
1315             (setq months/minutes t)
1316             (incf hours duration))
1317            (:seconds
1318             (incf secs duration))
1319            (t
1320             (return-from parse
1321               (make-duration
1322                :year years :month months :day days :hour hours
1323                :minute minutes :second secs))))
1324          (setf index next-index))))))
1325
1326 ;; e.g. 2000-11-11 00:00:00-06
1327
1328 (defun parse-iso-8601-time (string)
1329   "return the wall-time corresponding to the given ISO 8601 datestring"
1330   (multiple-value-bind (year month day hour minute second usec offset)
1331       (syntax-parse-iso-8601 string)
1332     (make-time :year year
1333                :month month
1334                :day day
1335                :hour hour
1336                :minute minute
1337                :second second
1338                :usec usec
1339                :offset offset)))
1340
1341 (defun %frac-string-to-usec (frac-str)
1342   (when frac-str
1343     (let* ((frac (parse-integer frac-str))
1344            (frac-len (length frac-str))
1345            (frac-exp (- 6 frac-len)))
1346       (floor (* frac (expt 10 frac-exp))))))
1347
1348 (defun %parse-offset-string (offset-str input &aux (len (length offset-str)))
1349   (when (zerop len)
1350     (return-from %parse-offset-string nil))
1351   (when (and (= len 1) (char= #\Z (char offset-str 0)))
1352     (return-from %parse-offset-string 0))
1353   (let ((pos? (char= #\+ (char offset-str 0)))
1354         (colon? (position #\: offset-str)))
1355     (unless (or (member len '(3 5))     ;; +05 or -0530
1356                 (and colon? (= 6 len))) ;; +05:30
1357       (error 'iso-8601-syntax-error
1358              :input input
1359              :bad-component `(timezone . ,offset-str)))
1360     (handler-bind ((error (lambda (c) (declare (ignore c))
1361                             (error 'iso-8601-syntax-error
1362                                    :input input
1363                                    :bad-component `(timezone . ,offset-str))
1364                             )))
1365       (let* ((hours (parse-integer offset-str :start 1 :end 3))
1366              (hsec (* 60 60 hours))
1367              (sec (* 60 (cond
1368                           (colon?
1369                            (parse-integer offset-str :start 4))
1370                           ((> len 3)
1371                            (parse-integer offset-str :start 3))
1372                           (t 0))))
1373              (total (+ hsec sec)))
1374         (if pos? (- total) total)))))
1375
1376 (defun syntax-parse-iso-8601 (string)
1377   ;; use strlen to determine if fractional seconds are present in timestamp
1378   (let ((strlen (length string))
1379         year month day hour minute second usec gmt-sec-offset)
1380     (handler-case
1381         (progn
1382           (setf year           (parse-integer string :start 0 :end 4)
1383                 month          (parse-integer string :start 5 :end 7)
1384                 day            (parse-integer string :start 8 :end 10)
1385                 hour           (if (<= 13 strlen)
1386                                    (parse-integer string :start 11 :end 13)
1387                                    0)
1388                 minute         (if (<= 16 strlen)
1389                                    (parse-integer string :start 14 :end 16)
1390                                    0)
1391                 second         (if (<= 19 strlen)
1392                                    (parse-integer string :start 17 :end 19)
1393                                    0))
1394           (when (> strlen 19)
1395             ;; fractional second
1396             (let* ((has-frac? (or (char= #\, (char string 19))
1397                                    (char= #\. (char string 19))))
1398                    (z-idx (position #\Z string :start 19))
1399                    (offset-start (or (position #\+ string :start 19)
1400                                      (position #\- string :start 19)))
1401                    (frac-end (or z-idx offset-start strlen ))
1402                    (frac-string (when has-frac? (subseq string 20 frac-end)))
1403                    (offset-string (when offset-start
1404                                     (subseq string offset-start))))
1405               (setf usec (or (%frac-string-to-usec frac-string)
1406                              0)
1407                     gmt-sec-offset
1408                     (cond
1409                       (z-idx 0)
1410                       (offset-string
1411                        (%parse-offset-string offset-string string))))))
1412
1413             (unless (< 0 year)
1414               (error 'iso-8601-syntax-error
1415                      :input string
1416                      :bad-component '(year . 0)))
1417             (unless (< 0 month)
1418               (error 'iso-8601-syntax-error
1419                      :bad-component '(month . 0)))
1420             (unless (< 0 day)
1421               (error 'iso-8601-syntax-error
1422                      :bad-component '(month . 0)))
1423             (values year month day hour minute second usec gmt-sec-offset))
1424       (simple-error ()
1425         (error 'iso-8601-syntax-error
1426                :bad-component
1427                (car (find-if (lambda (pair) (null (cdr pair)))
1428                              `((year . ,year) (month . ,month)
1429                                (day . ,day) (hour . ,hour)
1430                                (minute . ,minute) (second . ,second)
1431                                (usec . ,usec)))))))))