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