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