sql/time.lisp

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