local-time.lisp

(in-package #:local-time)

;;; Types

(defclass timestamp ()
  ((day :accessor day-of :initarg :day :initform 0 :type integer)
   (sec :accessor sec-of :initarg :sec :initform 0 :type integer)
   (nsec :accessor nsec-of :initarg :nsec :initform 0 :type (integer 0 999999999))))

(defstruct subzone
  (abbrev nil)
  (offset nil)
  (daylight-p nil))

(defstruct timezone
  (transitions #(0) :type simple-vector)
  (indexes #(0) :type simple-vector)
  (subzones #() :type simple-vector)
  (leap-seconds nil :type list)
  (path nil)
  (name "anonymous" :type string)
  (loaded nil :type boolean))

(deftype timezone-offset ()
  '(integer -43200 50400))

(defun %valid-time-of-day? (timestamp)
  (zerop (day-of timestamp)))

(deftype time-of-day ()
  '(and timestamp
        (satisfies %valid-time-of-day?)))

(defun %valid-date? (timestamp)
  (and (zerop (sec-of timestamp))
       (zerop (nsec-of timestamp))))

(deftype date ()
  '(and timestamp
        (satisfies %valid-date?)))

(define-condition invalid-timezone-file (error)
  ((path :accessor path-of :initarg :path))
  (:report (lambda (condition stream)
             (format stream "The file at ~a is not a timezone file."
                     (path-of condition)))))

(define-condition invalid-time-specification (error)
  ()
  (:report "The time specification is invalid"))

(define-condition invalid-timestring (error)
  ((timestring :accessor timestring-of :initarg :timestring)
   (failure :accessor failure-of :initarg :failure))
  (:report (lambda (condition stream)
             (format stream "Failed to parse ~S as an rfc3339 time: ~S"
                     (timestring-of condition)
                     (failure-of condition)))))

(defmethod make-load-form ((self timestamp) &optional environment)
  (make-load-form-saving-slots self :environment environment))

;;; Declaims

(declaim (inline now format-timestring %get-current-time
                 format-rfc3339-timestring to-rfc3339-timestring
                 format-rfc1123-timestring to-rfc1123-timestring)
         (ftype (function (&rest t) string) format-rfc3339-timestring)
         (ftype (function (&rest t) string) format-timestring)
         (ftype (function (&rest t) fixnum) local-timezone)
         (ftype (function (&rest t) (values
                                     timezone-offset
                                     boolean
                                     string)) timestamp-subzone)
         (ftype (function (timestamp &key (:timezone timezone) (:offset (or null integer)))
                          (values (integer 0 999999999)
                                  (integer 0 59)
                                  (integer 0 59)
                                  (integer 0 23)
                                  (integer 1 31)
                                  (integer 1 12)
                                  (integer -1000000 1000000)
                                  (integer 0 6)
                                  t
                                  timezone-offset
                                  simple-string))
                decode-timestamp))

;;; Variables

(defvar *default-timezone*)

(defparameter *default-timezone-repository-path*
  (flet ((try (project-home-directory)
           (when project-home-directory
             (ignore-errors
               (truename
                (merge-pathnames "zoneinfo/"
                                 (make-pathname :directory (pathname-directory project-home-directory))))))))
    (or (when (find-package "ASDF")
          (let ((path (eval (read-from-string
                             "(let ((system (asdf:find-system :local-time nil)))
                                (when system
                                  (asdf:component-pathname system)))"))))
            (try path)))
        (let ((path (or #.*compile-file-truename*
                        *load-truename*)))
          (when path
            (try (merge-pathnames "../" path)))))))

;;; Month information
(defparameter +month-names+
  #("" "January" "February" "March" "April" "May" "June" "July" "August"
    "September" "October" "November" "December"))
(defparameter +short-month-names+
  #("" "Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov"
    "Dec"))
(defparameter +day-names+
  #("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"))
(defparameter +day-names-as-keywords+
  #(:sunday :monday :tuesday :wednesday :thursday :friday :saturday))
(defparameter +short-day-names+
  #("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat"))
(defparameter +minimal-day-names+
  #("Su" "Mo" "Tu" "We" "Th" "Fr" "Sa"))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defconstant +months-per-year+ 12)
  (defconstant +days-per-week+ 7)
  (defconstant +hours-per-day+ 24)
  (defconstant +minutes-per-day+ 1440)
  (defconstant +minutes-per-hour+ 60)
  (defconstant +seconds-per-day+ 86400)
  (defconstant +seconds-per-hour+ 3600)
  (defconstant +seconds-per-minute+ 60)
  (defconstant +usecs-per-day+ 86400000000))

(defparameter +iso-8601-date-format+
  '((:year 4) #\- (:month 2) #\- (:day 2)))

(defparameter +iso-8601-time-format+
  '((:hour 2) #\: (:min 2) #\: (:sec 2) #\. (:usec 6)))

(defparameter +iso-8601-format+
  ;; 2008-11-18T02:32:00.586931+01:00
  (append +iso-8601-date-format+ (list #\T) +iso-8601-time-format+ (list :gmt-offset-or-z)))

(defparameter +rfc3339-format+ +iso-8601-format+)

(defparameter +rfc3339-format/date-only+
  '((:year 4) #\- (:month 2) #\- (:day 2)))

(defparameter +asctime-format+
  '(:short-weekday #\space :short-month #\space (:day 2 #\space) #\space
    (:hour 2) #\: (:min 2) #\: (:sec 2) #\space
    (:year 4)))

(defparameter +rfc-1123-format+
  ;; Sun, 06 Nov 1994 08:49:37 GMT
  '(:short-weekday ", " (:day 2) #\space :short-month #\space (:year 4) #\space
    (:hour 2) #\: (:min 2) #\: (:sec 2) #\space :gmt-offset-hhmm)
  "See the RFC 1123 for the details about the possible values of the timezone field.")

(defparameter +iso-week-date-format+
  ;; 2009-W53-5
  '((:iso-week-year 4) #\- #\W (:iso-week-number 2) #\- (:iso-week-day 1)))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defparameter +rotated-month-days-without-leap-day+
    #.(coerce #(31 30 31 30 31 31 30 31 30 31 31 28)
              '(simple-array fixnum (*))))

  (defparameter +rotated-month-offsets-without-leap-day+
    (coerce
     (cons 0
           (loop with sum = 0
                 for days :across +rotated-month-days-without-leap-day+
                 collect (incf sum days)))
     '(simple-array fixnum (*)))))

;; The astronomical julian date offset is the number of days between
;; the current date and -4713-01-01T00:00:00+00:00
(defparameter +astronomical-julian-date-offset+ -2451605)

;; The modified julian date is the number of days between the current
;; date and 1858-11-17T12:00:00+00:00. TODO: For the sake of simplicity,
;; we currently just do the date arithmetic and don't adjust for the
;; time of day.
(defparameter +modified-julian-date-offset+ -51604)

(defun %guess-offset (seconds days &optional timezone)
  ;; try converting the local time to a timestamp using each available
  ;; subtimezone, until we find one where the offset matches the offset that
  ;; applies at that time (according to the transition table).
  ;;
  ;; Consequence for ambiguous cases:
  ;; Whichever subtimezone is listed first in the tzinfo database will be
  ;; the one that we pick to resolve ambiguous local time representations.
  (let* ((zone (%realize-timezone (or timezone *default-timezone*)))
         (unix-time (timestamp-values-to-unix seconds days))
         (subzone-idx (if (zerop (length (timezone-indexes zone)))
                          0
                          (elt (timezone-indexes zone)
                               (transition-position unix-time
                                                    (timezone-transitions zone)))))
         (subzone (elt (timezone-subzones zone) subzone-idx)))
    (subzone-offset subzone)))

(defun %read-binary-integer (stream byte-count &optional (signed nil))
  "Read BYTE-COUNT bytes from the binary stream STREAM, and return an integer which is its representation in network byte order (MSB).  If SIGNED is true, interprets the most significant bit as a sign indicator."
  (loop
    :with result = 0
    :for offset :from (* (1- byte-count) 8) :downto 0 :by 8
    :do (setf (ldb (byte 8 offset) result) (read-byte stream))
    :finally (if signed
                 (let ((high-bit (* byte-count 8)))
                   (if (logbitp (1- high-bit) result)
                       (return (- result (ash 1 high-bit)))
                       (return result)))
                 (return result))))

(defun %string-from-unsigned-byte-vector (vector offset)
  "Returns a string created from the vector of unsigned bytes VECTOR starting at OFFSET which is terminated by a 0."
  (declare (type (vector (unsigned-byte 8)) vector))
  (let* ((null-pos (or (position 0 vector :start offset) (length vector)))
         (result (make-string (- null-pos offset))))
    (loop for input-index :from offset :upto (1- null-pos)
          for output-index :upfrom 0
          do (setf (aref result output-index) (code-char (aref vector input-index))))
    result))

(defun %find-first-std-offset (timezone-indexes timestamp-info)
  (let ((subzone-idx (find-if 'subzone-daylight-p
                              timezone-indexes
                              :key (lambda (x) (aref timestamp-info x)))))
    (subzone-offset (aref timestamp-info (or subzone-idx 0)))))

(defun %tz-verify-magic-number (inf zone)
  ;; read and verify magic number
  (let ((magic-buf (make-array 4 :element-type 'unsigned-byte)))
    (read-sequence magic-buf inf :start 0 :end 4)
    (when (string/= (map 'string #'code-char magic-buf) "TZif" :end1 4)
      (error 'invalid-timezone-file :path (timezone-path zone))))
  ;; skip 16 bytes for "future use"
  (let ((ignore-buf (make-array 16 :element-type 'unsigned-byte)))
    (read-sequence ignore-buf inf :start 0 :end 16)))

(defun %tz-read-header (inf)
  `(:utc-count ,(%read-binary-integer inf 4)
    :wall-count ,(%read-binary-integer inf 4)
    :leap-count ,(%read-binary-integer inf 4)
    :transition-count ,(%read-binary-integer inf 4)
    :type-count ,(%read-binary-integer inf 4)
    :abbrev-length ,(%read-binary-integer inf 4)))

(defun %tz-read-transitions (inf count)
  (make-array count
              :initial-contents
              (loop for idx from 1 upto count
                 collect (%read-binary-integer inf 4 t))))

(defun %tz-read-indexes (inf count)
  (make-array count
              :initial-contents
              (loop for idx from 1 upto count
                 collect (%read-binary-integer inf 1))))

(defun %tz-read-subzone (inf count)
  (loop for idx from 1 upto count
     collect (list (%read-binary-integer inf 4 t)
                   (%read-binary-integer inf 1)
                   (%read-binary-integer inf 1))))

(defun leap-seconds-sec (leap-seconds)
  (car leap-seconds))
(defun leap-seconds-adjustment (leap-seconds)
  (cdr leap-seconds))

(defun %tz-read-leap-seconds (inf count)
  (when (plusp count)
    (loop for idx from 1 upto count
          collect (%read-binary-integer inf 4) into sec
          collect (%read-binary-integer inf 4) into adjustment
          finally (return (cons (make-array count :initial-contents sec)
                                (make-array count :initial-contents adjustment))))))

(defun %tz-read-abbrevs (inf length)
  (let ((a (make-array length :element-type '(unsigned-byte 8))))
    (read-sequence a inf
                   :start 0
                   :end length)
    a))

(defun %tz-read-indicators (inf length)
  ;; read standard/wall indicators
  (let ((buf (make-array length :element-type '(unsigned-byte 8))))
    (read-sequence buf inf
                   :start 0
                   :end length)
    (make-array length
                :element-type 'bit
                :initial-contents buf)))

(defun %tz-make-subzones (raw-info abbrevs gmt-indicators std-indicators)
  (declare (ignore gmt-indicators std-indicators))
  ;; TODO: handle TZ environment variables, which use the gmt and std
  ;; indicators
  (make-array (length raw-info)
              :element-type 'subzone
              :initial-contents
              (loop for info in raw-info collect
                   (make-subzone
                    :offset (first info)
                    :daylight-p (/= (second info) 0)
                    :abbrev (%string-from-unsigned-byte-vector abbrevs (third info))))))

(defun %realize-timezone (zone &optional reload)
  "If timezone has not already been loaded or RELOAD is non-NIL, loads the timezone information from its associated unix file.  If the file is not a valid timezone file, the condition INVALID-TIMEZONE-FILE will be signaled."
  (when (or reload (not (timezone-loaded zone)))
    (with-open-file (inf (timezone-path zone)
                         :direction :input
                         :element-type 'unsigned-byte)
      (%tz-verify-magic-number inf zone)

      ;; read header values
      (let* ((header (%tz-read-header inf))
             (timezone-transitions (%tz-read-transitions inf (getf header :transition-count)))
             (subzone-indexes (%tz-read-indexes inf (getf header :transition-count)))
             (subzone-raw-info (%tz-read-subzone inf (getf header :type-count)))
             (abbreviation-buf (%tz-read-abbrevs inf (getf header :abbrev-length)))
             (leap-second-info (%tz-read-leap-seconds inf (getf header :leap-count)))
             (std-indicators (%tz-read-indicators inf (getf header :wall-count)))
             (gmt-indicators (%tz-read-indicators inf (getf header :utc-count)))
             (subzone-info (%tz-make-subzones subzone-raw-info
                                              abbreviation-buf
                                              gmt-indicators
                                              std-indicators)))

        (setf (timezone-transitions zone) timezone-transitions)
        (setf (timezone-indexes zone) subzone-indexes)
        (setf (timezone-subzones zone) subzone-info)
        (setf (timezone-leap-seconds zone) leap-second-info))
      (setf (timezone-loaded zone) t)))
  zone)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun %make-simple-timezone (name abbrev offset)
    (let ((subzone (local-time::make-subzone :offset offset
                                           :daylight-p nil
                                           :abbrev abbrev)))
    (local-time::make-timezone
     :subzones (make-array 1 :initial-contents (list subzone))
     :path nil
     :name name
     :loaded t)))

  ;; to be used as #+#.(local-time::package-with-symbol? "SB-EXT" "GET-TIME-OF-DAY")
  (defun package-with-symbol? (package name)
    (if (and (find-package package)
             (find-symbol name package))
        '(:and)
        '(:or))))

(defparameter +utc-zone+ (%make-simple-timezone "Coordinated Universal Time" "UTC" 0))

(defparameter +gmt-zone+ (%make-simple-timezone "Greenwich Mean Time" "GMT" 0))

(defparameter +none-zone+ (%make-simple-timezone "Explicit Offset Given" "NONE" 0))

(defmacro define-timezone (zone-name zone-file &key (load nil))
  "Define zone-name (a symbol or a string) as a new timezone, lazy-loaded from zone-file (a pathname designator relative to the zoneinfo directory on this system.  If load is true, load immediately."
  (declare (type (or string symbol) zone-name))
  (let ((zone-sym (if (symbolp zone-name) zone-name (intern zone-name))))
    `(prog1
      (defparameter ,zone-sym (make-timezone :path ,zone-file
                                             :name ,(if (symbolp zone-name)
                                                        (string-downcase (symbol-name zone-name))
                                                        zone-name)))
      ,@(when load
              `((%realize-timezone ,zone-sym))))))

(eval-when (:load-toplevel :execute)
  (let ((default-timezone-file #p"/etc/localtime"))
    (handler-case
        (define-timezone *default-timezone* default-timezone-file :load t)
      (t ()
        (setf *default-timezone* +utc-zone+)))))

(defparameter *location-name->timezone* (make-hash-table :test 'equal)
  "A hashtable with entries like \"Europe/Budapest\" -> timezone-instance")

(defparameter *abbreviated-subzone-name->timezone-list* (make-hash-table :test 'equal)
  "A hashtable of \"CEST\" -> list of timezones with \"CEST\" subzone")

(defun find-timezone-by-location-name (name)
  (when (zerop (hash-table-count *location-name->timezone*))
    (error "Seems like the timezone repository has not yet been loaded. Hint: see REREAD-TIMEZONE-REPOSITORY."))
  (gethash name *location-name->timezone*))

(defun timezone= (timezone-1 timezone-2)
  "Return two values indicating the relationship between timezone-1 and timezone-2. The first value is whether the two timezones are equal and the second value indicates whether it is sure or not.

In other words:
\(values t t) means timezone-1 and timezone-2 are definitely equal.
\(values nil t) means timezone-1 and timezone-2 are definitely different.
\(values nil nil) means that it couldn't be determined."
  (if (or (eq timezone-1 timezone-2)
          (equalp timezone-1 timezone-2))
      (values t t)
      (values nil nil)))

(defun reread-timezone-repository (&key (timezone-repository *default-timezone-repository-path*))
  (check-type timezone-repository (or pathname string))
  (let ((root-directory (fad:directory-exists-p timezone-repository)))
    (unless root-directory
      (error "REREAD-TIMEZONE-REPOSITORY was called with invalid PROJECT-DIRECTORY (~A)."
             timezone-repository))
    (let ((cutoff-position (length (princ-to-string root-directory))))
      (flet ((visitor (file)
               (handler-case
                   (let* ((full-name (subseq (princ-to-string file) cutoff-position))
                          (name (pathname-name file))
                          (timezone (%realize-timezone (make-timezone :path file :name name))))
                     (setf (gethash full-name *location-name->timezone*) timezone)
                     (map nil (lambda (subzone)
                                (push timezone (gethash (subzone-abbrev subzone)
                                                        *abbreviated-subzone-name->timezone-list*)))
                          (timezone-subzones timezone)))
                 (invalid-timezone-file () nil))))
        (setf *location-name->timezone* (make-hash-table :test 'equal))
        (setf *abbreviated-subzone-name->timezone-list* (make-hash-table :test 'equal))
        (cl-fad:walk-directory root-directory #'visitor :directories nil
                               :test (lambda (file)
                                       (not (find "Etc" (pathname-directory file) :test #'string=)))
                               :follow-symlinks nil)
        (cl-fad:walk-directory (merge-pathnames "Etc/" root-directory) #'visitor :directories nil)))))

(defmacro make-timestamp (&rest args)
  `(make-instance 'timestamp ,@args))

(defun clone-timestamp (timestamp)
  (make-instance 'timestamp
                 :nsec (nsec-of timestamp)
                 :sec (sec-of timestamp)
                 :day (day-of timestamp)))

(defun transition-position (needle haystack)
  (declare (type integer needle)
           (type (simple-array integer (*)) haystack))
  (loop
     with start = 0
     with end = (1- (length haystack))
     for middle = (floor (+ end start) 2)
     while (and (< start end)
                (/= needle (elt haystack middle)))
     do (cond
          ((> needle (elt haystack middle))
           (setf start (1+ middle)))
          (t
           (setf end (1- middle))))
     finally
       (return (max 0 (cond
                        ((minusp end)
                         0)
                        ((= needle (elt haystack middle))
                         middle)
                        ((>= needle (elt haystack end))
                         end)
                        (t
                         (1- end)))))))

(defun timestamp-subtimezone (timestamp timezone)
  "Return as multiple values the time zone as the number of seconds east of UTC, a boolean daylight-saving-p, and the customary abbreviation of the timezone."
  (declare (type timestamp timestamp)
           (type (or null timezone) timezone))
  (let* ((zone (%realize-timezone (or timezone *default-timezone*)))
         (unix-time (timestamp-to-unix timestamp))
         (subzone-idx (if (zerop (length (timezone-indexes zone)))
                          0
                          (elt (timezone-indexes zone)
                               (transition-position unix-time
                                                   (timezone-transitions zone)))))
         (subzone (elt (timezone-subzones zone) subzone-idx)))
    (values
     (subzone-offset subzone)
     (subzone-daylight-p subzone)
     (subzone-abbrev subzone))))

(defun %adjust-to-offset (sec day offset)
  "Returns two values, the values of new DAY and SEC slots of the timestamp adjusted to the given timezone."
  (declare (type integer sec day offset))
  (multiple-value-bind (offset-day offset-sec)
      (truncate offset +seconds-per-day+)
    (let* ((new-sec (+ sec offset-sec))
           (new-day (+ day offset-day)))
      (cond ((minusp new-sec)
             (incf new-sec +seconds-per-day+)
             (decf new-day))
            ((>= new-sec +seconds-per-day+)
             (incf new-day)
             (decf new-sec +seconds-per-day+)))
      (values new-sec new-day))))

(defun %adjust-to-timezone (source timezone &optional offset)
  (%adjust-to-offset (sec-of source)
                     (day-of source)
                     (or offset
                         (timestamp-subtimezone source timezone))))

(defun timestamp-minimize-part (timestamp part &key
                                (timezone *default-timezone*)
                                into)
  (let* ((timestamp-parts '(:nsec :sec :min :hour :day :month))
         (part-count (position part timestamp-parts)))
    (assert part-count nil
            "timestamp-minimize-part called with invalid part ~a (expected one of ~a)"
            part
            timestamp-parts)
    (multiple-value-bind (nsec sec min hour day month year day-of-week daylight-saving-time-p offset)
        (decode-timestamp timestamp :timezone timezone)
      (declare (ignore nsec day-of-week daylight-saving-time-p))
      (encode-timestamp 0
                        (if (> part-count 0) 0 sec)
                        (if (> part-count 1) 0 min)
                        (if (> part-count 2) 0 hour)
                        (if (> part-count 3) 1 day)
                        (if (> part-count 4) 1 month)
                        year
                        :offset (if timezone nil offset)
                        :timezone timezone
                        :into into))))

(defun timestamp-maximize-part (timestamp part &key
                                (timezone *default-timezone*)
                                into)
  (let* ((timestamp-parts '(:nsec :sec :min :hour :day :month))
         (part-count (position part timestamp-parts)))
    (assert part-count nil
            "timestamp-maximize-part called with invalid part ~a (expected one of ~a)"
            part
            timestamp-parts)
    (multiple-value-bind (nsec sec min hour day month year day-of-week daylight-saving-time-p offset)
        (decode-timestamp timestamp :timezone timezone)
      (declare (ignore nsec day-of-week daylight-saving-time-p))
      (let ((month (if (> part-count 4) 12 month)))
        (encode-timestamp 999999999
                          (if (> part-count 0) 59 sec)
                          (if (> part-count 1) 59 min)
                          (if (> part-count 2) 23 hour)
                          (if (> part-count 3) (days-in-month month year) day)
                          month
                          year
                          :offset (if timezone nil offset)
                          :timezone timezone
                          :into into)))))

(defmacro with-decoded-timestamp ((&key nsec sec minute hour day month year day-of-week daylight-p timezone offset)
                                   timestamp &body forms)
  "This macro binds variables to the decoded elements of TIMESTAMP. The TIMEZONE argument is used for decoding the timestamp, and is not bound by the macro. The value of DAY-OF-WEEK starts from 0 which means Sunday."
  (let ((ignores)
        (types)
        (variables))
    (macrolet ((initialize (&rest vars)
                 `(progn
                    ,@(loop
                         :for var :in vars
                         :collect `(progn
                                     (unless ,var
                                       (setf ,var (gensym))
                                       (push ,var ignores))
                                     (push ,var variables)))
                    (setf ignores (nreverse ignores))
                    (setf variables (nreverse variables))))
               (declare-fixnum-type (&rest vars)
                 `(progn
                    ,@(loop
                         :for var :in vars
                         :collect `(when ,var
                                     (push `(type fixnum ,,var) types)))
                    (setf types (nreverse types)))))
      (when nsec
        (push `(type (integer 0 999999999) ,nsec) types))
      (declare-fixnum-type sec minute hour day month year)
      (initialize nsec sec minute hour day month year day-of-week daylight-p))
    `(multiple-value-bind (,@variables)
         (decode-timestamp ,timestamp :timezone ,(or timezone '*default-timezone*) :offset ,offset)
       (declare (ignore ,@ignores) ,@types)
       ,@forms)))

(defun %normalize-month-year-pair (month year)
  "Normalizes the month/year pair: in case month is < 1 or > 12 the month and year are corrected to handle the overflow."
  (multiple-value-bind (year-offset month-minus-one)
      (floor (1- month) 12)
    (values (1+ month-minus-one)
            (+ year year-offset))))

(defun days-in-month (month year)
  "Returns the number of days in the given month of the specified year."
  (let ((normal-days (aref +rotated-month-days-without-leap-day+
                           (mod (+ month 9) 12))))
    (if (and (= month 2)
             (or (and (zerop (mod year 4))
                      (plusp (mod year 100)))
                 (zerop (mod year 400))))
        (1+ normal-days)                ; February on a leap year
        normal-days)))

;; TODO scan all uses of FIX-OVERFLOW-IN-DAYS and decide where it's ok to silently fix and where should be and error reported
(defun %fix-overflow-in-days (day month year)
  "In case the day number is higher than the maximal possible for the given month/year pair, returns the last day of the month."
  (let ((max-day (days-in-month month year)))
    (if (> day max-day)
        max-day
        day)))

(eval-when (:compile-toplevel :load-toplevel)
  (defun %list-length= (num list)
    "Tests for a list of length NUM without traversing the entire list to get the length."
    (let ((c (nthcdr (1- num) list)))
      (and c (endp (cdr c)))))

  (defun %expand-adjust-timestamp-changes (timestamp changes visitor)
    (loop
      :with params = ()
      :with functions = ()
      :for change in changes
      :do
         (progn
           (assert (or
                    (%list-length= 3 change)
                    (and (%list-length= 2 change)
                         (symbolp (first change))
                         (or (string= (first change) :timezone)
                             (string= (first change) :utc-offset)))
                    (and (%list-length= 4 change)
                         (symbolp (third change))
                         (or (string= (third change) :to)
                             (string= (third change) :by))))
                   nil "Syntax error in expression ~S" change)
           (let ((operation (first change))
                 (part (second change))
                 (value (if (%list-length= 3 change)
                            (third change)
                            (fourth change))))
             (cond
               ((string= operation :set)
                (push `(%set-timestamp-part ,part ,value) functions))
               ((string= operation :offset)
                (push `(%offset-timestamp-part ,part ,value) functions))
               ((string= operation :utc-offset)
                (push part params)
                (push :utc-offset params))
               ((string= operation :timezone)
                (push part params)
                (push :timezone params))
               (t (error "Unexpected operation ~S" operation)))))
      :finally
         (loop
           :for (function part value) in functions
           :do
           (funcall visitor `(,function ,timestamp ,part ,value ,@params)))))

  (defun %expand-adjust-timestamp (timestamp changes &key functional)
    (let* ((old (gensym "OLD"))
           (new (if functional
                    (gensym "NEW")
                    old))
           (forms (list)))
      (%expand-adjust-timestamp-changes old changes
                                        (lambda (change)
                                          (push
                                           `(progn
                                              (multiple-value-bind (nsec sec day)
                                                  ,change
                                                (setf (nsec-of ,new) nsec)
                                                (setf (sec-of ,new) sec)
                                                (setf (day-of ,new) day))
                                              ,@(when functional
                                                      `((setf ,old ,new))))
                                           forms)))
      (setf forms (nreverse forms))
      `(let* ((,old ,timestamp)
              ,@(when functional
                      `((,new (clone-timestamp ,old)))))
         ,@forms
         ,old)))
  )                                     ; eval-when

(defmacro adjust-timestamp (timestamp &body changes)
  (%expand-adjust-timestamp timestamp changes :functional t))

(defmacro adjust-timestamp! (timestamp &body changes)
  (%expand-adjust-timestamp timestamp changes :functional nil))

(defun %set-timestamp-part (time part new-value &key (timezone *default-timezone*) utc-offset)
  ;; TODO think about error signalling. when, how to disable if it makes sense, ...
  (case part
    ((:nsec :sec-of-day :day)
     (let ((nsec (nsec-of time))
           (sec (sec-of time))
           (day (day-of time)))
       (case part
         (:nsec (setf nsec (coerce new-value '(integer 0 999999999))))
         (:sec-of-day (setf sec (coerce new-value `(integer 0 ,+seconds-per-day+))))
         (:day (setf day new-value)))
       (values nsec sec day)))
    (otherwise
     (with-decoded-timestamp (:nsec nsec :sec sec :minute minute :hour hour
                              :day day :month month :year year :timezone timezone :offset utc-offset)
         time
       (ecase part
         (:sec (setf sec new-value))
         (:minute (setf minute new-value))
         (:hour (setf hour new-value))
         (:day-of-month (setf day new-value))
         (:month (setf month new-value)
                 (setf day (%fix-overflow-in-days day month year)))
         (:year (setf year new-value)
                (setf day (%fix-overflow-in-days day month year))))
       (encode-timestamp-into-values nsec sec minute hour day month year :timezone timezone :offset utc-offset)))))

(defun %offset-timestamp-part (time part offset &key (timezone *default-timezone*) utc-offset)
  "Returns a time adjusted by the specified OFFSET. Takes care of
different kinds of overflows. The setting :day-of-week is possible
using a keyword symbol name of a week-day (see
+DAY-NAMES-AS-KEYWORDS+) as value. In that case point the result to
the previous day given by OFFSET."
  (labels ((direct-adjust (part offset nsec sec day)
             (cond ((eq part :day-of-week)
                    (with-decoded-timestamp (:day-of-week day-of-week
                                                          :nsec nsec :sec sec :minute minute :hour hour
                                                          :day day :month month :year year
                                                          :timezone timezone :offset utc-offset)
                      time
                      (let ((position (position offset +day-names-as-keywords+ :test #'eq)))
                        (assert position (position) "~S is not a valid day name" offset)
                        (let ((offset (+ (- (if (zerop day-of-week)
                                                7
                                                day-of-week))
                                         position)))
                          (incf day offset)
                          (cond
                            ((< day 1)
                             (decf month)
                             (when (< month 1)
                               (setf month 12)
                               (decf year))
                             (setf day (+ (days-in-month month year) day)))
                            ((let ((days-in-month (days-in-month month year)))
                               (when (< days-in-month day)
                                 (incf month)
                                 (when (= month 13)
                                   (setf month 1)
                                   (incf year))
                                 (decf day days-in-month)))))
                          (encode-timestamp-into-values nsec sec minute hour day month year
                                                        :timezone timezone :offset utc-offset)))))
                   ((zerop offset)
                    ;; The offset is zero, so just return the parts of the timestamp object
                    (values nsec sec day))
                   (t
                    (let ((old-utc-offset (or utc-offset
                                              (timestamp-subtimezone time timezone)))
                          new-utc-offset)
                      (tagbody
                       top
                         (ecase part
                           (:nsec
                            (multiple-value-bind (sec-offset new-nsec)
                                (floor (+ offset nsec) 1000000000)
                              ;; the time might need to be adjusted a bit more if q != 0
                              (setf part :sec
                                    offset sec-offset
                                    nsec new-nsec)
                              (go top)))
                           ((:sec :minute :hour)
                            (multiple-value-bind (days-offset new-sec)
                                (floor (+ sec (* offset (ecase part
                                                          (:sec 1)
                                                          (:minute +seconds-per-minute+)
                                                          (:hour +seconds-per-hour+))))
                                       +seconds-per-day+)
                              (return-from direct-adjust (values nsec new-sec (+ day days-offset)))))
                           (:day
                            (incf day offset)
                            (setf new-utc-offset (or utc-offset
                                                     (timestamp-subtimezone (make-timestamp :nsec nsec :sec sec :day day)
                                                                            timezone)))
                            (when (not (= old-utc-offset
                                          new-utc-offset))
                              ;; We hit the DST boundary. We need to restart again
                              ;; with :sec, but this time we know both old and new
                              ;; UTC offset will be the same, so it's safe to do
                              (setf part :sec
                                    offset (- old-utc-offset
                                              new-utc-offset)
                                    old-utc-offset new-utc-offset)
                              (go top))
                            (return-from direct-adjust (values nsec sec day)))))))))

           (safe-adjust (part offset time)
             (with-decoded-timestamp (:nsec nsec :sec sec :minute minute :hour hour :day day
                                            :month month :year year :timezone timezone :offset utc-offset)
               time
               (multiple-value-bind (month-new year-new)
                   (%normalize-month-year-pair
                    (+ (ecase part
                         (:month offset)
                         (:year (* 12 offset)))
                       month)
                    year)
                 ;; Almost there. However, it is necessary to check for
                 ;; overflows first
                 (encode-timestamp-into-values nsec sec minute hour
                                               (%fix-overflow-in-days day month-new year-new)
                                               month-new year-new
                                               :timezone timezone :offset utc-offset)))))
    (ecase part
      ((:nsec :sec :minute :hour :day :day-of-week)
       (direct-adjust part offset
                      (nsec-of time)
                      (sec-of time)
                      (day-of time)))
      ((:month :year) (safe-adjust part offset time)))))

;; TODO merge this functionality into timestamp-difference
(defun timestamp-whole-year-difference (time-a time-b)
  "Returns the number of whole years elapsed between time-a and time-b (hint: anniversaries)."
  (declare (type timestamp time-b time-a))
  (multiple-value-bind (nsec-b sec-b minute-b hour-b day-b month-b year-b day-of-week-b daylight-p-b offset-b)
      (decode-timestamp time-b)
    (declare (ignore day-of-week-b daylight-p-b))
    (multiple-value-bind (nsec-a sec-a minute-a hour-a day-a month-a year-a)
        (decode-timestamp time-a)
      (declare (ignore nsec-a sec-a minute-a hour-a day-a month-a))
      (let ((year-difference (- year-a year-b)))
        (if (timestamp<= (encode-timestamp nsec-b sec-b minute-b hour-b
                                           (if (= month-b 2)
                                               (min 28 day-b)
                                               day-b)
                                           month-b
                                           (+ year-difference year-b)
                                           :offset offset-b)
                         time-a)
            year-difference
            (1- year-difference))))))

(defun timestamp-difference (time-a time-b)
  "Returns the difference between TIME-A and TIME-B in seconds"
  (let ((nsec (- (nsec-of time-a) (nsec-of time-b)))
        (second (- (sec-of time-a) (sec-of time-b)))
        (day (- (day-of time-a) (day-of time-b))))
    (when (minusp nsec)
      (decf second)
      (incf nsec 1000000000))
    (when (minusp second)
      (decf day)
      (incf second +seconds-per-day+))
    (let ((result (+ (* day +seconds-per-day+)
                     second)))
      (unless (zerop nsec)
        ;; this incf turns the result into a float, so only do this when necessary
        (incf result (/ nsec 1000000000d0)))
      result)))

(defun timestamp+ (time amount unit &optional (timezone *default-timezone*) offset)
  (multiple-value-bind (nsec sec day)
      (%offset-timestamp-part time unit amount :timezone timezone :utc-offset offset)
    (make-timestamp :nsec nsec
                    :sec sec
                    :day day)))

(defun timestamp- (time amount unit &optional (timezone *default-timezone*) offset)
  (timestamp+ time (- amount) unit timezone offset))

(defun timestamp-day-of-week (timestamp &key (timezone *default-timezone*) offset)
  (mod (+ 3 (nth-value 1 (%adjust-to-timezone timestamp timezone offset))) 7))

;; TODO read
;; http://java.sun.com/j2se/1.4.2/docs/api/java/util/GregorianCalendar.html
;; (or something else, sorry :) this scheme only works back until
;; 1582, the start of the gregorian calendar.  see also
;; DECODE-TIMESTAMP when fixing if fixing is desired at all.
(defun valid-timestamp-p (nsec sec minute hour day month year)
  "Returns T if the time values refer to a valid time, otherwise returns NIL."
  (and (<= 0 nsec 999999999)
       (<= 0 sec 59)
       (<= 0 minute 59)
       (<= 0 hour 23)
       (<= 1 month 12)
       (<= 1 day (days-in-month month year))
       (/= year 0)))

(defun encode-timestamp-into-values (nsec sec minute hour day month year
                                     &key (timezone *default-timezone*) offset)
  "Returns (VALUES NSEC SEC DAY ZONE) ready to be used for
instantiating a new timestamp object.  If the specified time is
invalid, the condition INVALID-TIME-SPECIFICATION is raised."
  ;; If the user provided an explicit offset, we use that.  Otherwise,
  (declare (type integer nsec sec minute hour day month year)
           (type (or integer null) offset))
  (unless (valid-timestamp-p nsec sec minute hour day month year)
    (error 'invalid-time-specification))
  (let* ((0-based-rotated-month (if (>= month 3)
                                    (- month 3)
                                    (+ month 9)))
         (internal-year (if (< month 3)
                            (- year 2001)
                            (- year 2000)))
         (years-as-days (years-to-days internal-year))
         (sec (+ (* hour +seconds-per-hour+)
                 (* minute +seconds-per-minute+)
                 sec))
         (days-from-zero-point (+ years-as-days
                                  (aref +rotated-month-offsets-without-leap-day+ 0-based-rotated-month)
                                  (1- day)))
         (used-offset (or offset
                          (%guess-offset sec
                                         days-from-zero-point
                                         timezone))))
    (multiple-value-bind (utc-sec utc-day)
        (%adjust-to-offset sec days-from-zero-point (- used-offset))
      (values nsec utc-sec utc-day))))

(defun encode-timestamp (nsec sec minute hour day month year
                         &key (timezone *default-timezone*) offset into)
  "Return a new TIMESTAMP instance corresponding to the specified time
elements."
  (declare (type integer nsec sec minute hour day month year))
  (multiple-value-bind (nsec sec day)
      (encode-timestamp-into-values nsec sec minute hour day month year
                                    :timezone timezone :offset offset)
    (if into
        (progn
          (setf (nsec-of into) nsec)
          (setf (sec-of into) sec)
          (setf (day-of into) day)
          into)
        (make-timestamp
         :nsec nsec
         :sec sec
         :day day))))

(defun universal-to-timestamp (universal &key (nsec 0))
  "Returns a timestamp corresponding to the given universal time."
  ;; universal time is seconds from 1900-01-01T00:00:00Z.
  (let ((adjusted-universal (- universal #.(encode-universal-time 0 0 0 1 3 2000 0))))
    (multiple-value-bind (day second)
        (floor adjusted-universal +seconds-per-day+)
      (make-timestamp :day day :sec second :nsec nsec))))

(defun timestamp-to-universal (timestamp)
  "Return the UNIVERSAL-TIME corresponding to the TIMESTAMP"
  ;; universal time is seconds from 1900-01-01T00:00:00Z
  (+ (* (day-of timestamp) +seconds-per-day+)
     (sec-of timestamp)
     #.(encode-universal-time 0 0 0 1 3 2000 0)))

(defun unix-to-timestamp (unix &key (nsec 0))
  "Return a TIMESTAMP corresponding to UNIX, which is the number of seconds since the unix epoch, 1970-01-01T00:00:00Z."
  (multiple-value-bind (days secs)
      (floor unix +seconds-per-day+)
    (make-timestamp :day (- days 11017) :sec secs :nsec nsec)))

(defun timestamp-values-to-unix (seconds day)
  "Return the Unix time correspondint to the values used to encode a TIMESTAMP"
  (+ (* (+ day 11017) +seconds-per-day+) seconds))

(defun timestamp-to-unix (timestamp)
  "Return the Unix time corresponding to the TIMESTAMP"
  (declare (type timestamp timestamp))
  (timestamp-values-to-unix (sec-of timestamp) (day-of timestamp)))

#+(and allegro (not os-windows))
(eval-when (:compile-toplevel :load-toplevel :execute)
  ;; Allegro common lisp requires some toplevel hoops through which to
  ;; jump in order to call unix's gettimeofday properly.
  (ff:def-foreign-type timeval
      (:struct (tv_sec :long)
               (tv_usec :long)))

  (ff:def-foreign-call
      (allegro-ffi-gettimeofday "gettimeofday")
      ((timeval (* timeval))
       ;; and do this to allow a 0 for NULL
       (timezone :foreign-address))
    :returning (:int fixnum)))

#+(and allegro os-windows)
(eval-when (:compile-toplevel :load-toplevel :execute)
  ;; Allegro common lisp requires some toplevel hoops through which to
  ;; jump in order to call unix's gettimeofday properly.
  (ff:def-foreign-type filetime
      (:struct (|dwLowDateTime| :int)
               (|dwHighDateTime| :int)))

  (ff:def-foreign-call
      (allegro-ffi-get-system-time-as-file-time "GetSystemTimeAsFileTime")
      ((filetime (* filetime)))
    :returning :void))

#+(or (and allegro os-windows)
      (and ccl windows))
(defun filetime-to-current-time (low high)
  "Convert a Windows time into (values sec nano-sec)."
  (let* ((unix-epoch-filetime 116444736000000000)
         (filetime (logior low (ash high 32)))
         (filetime (- filetime unix-epoch-filetime)))
    (multiple-value-bind (secs 100ns-periods)
        (floor filetime #.(round 1e7))
      (values secs (* 100ns-periods 100)))))

#+(and lispworks (or linux darwin))
(progn
  (fli:define-c-typedef time-t :long)
  (fli:define-c-typedef suseconds-t #+linux :long
                                    #+darwin :int)

  (fli:define-c-struct timeval
    (tv-sec time-t)
    (tv-usec suseconds-t))

  (fli:define-foreign-function (gettimeofday/ffi "gettimeofday")
      ((tv (:pointer (:struct timeval)))
       (tz :pointer))
    :result-type :int)

  (defun lispworks-gettimeofday ()
    (declare (optimize speed (safety 1)))
    (fli:with-dynamic-foreign-objects ((tv (:struct timeval)))
      (let ((ret (gettimeofday/ffi tv fli:*null-pointer*)))
        (assert (zerop ret) nil "gettimeofday failed")
        (let ((secs
                (fli:foreign-slot-value tv 'tv-sec
                                        :type 'time-t
                                        :object-type '(:struct timeval)))
              (usecs
                (fli:foreign-slot-value tv 'tv-usec
                                        :type 'suseconds-t
                                        :object-type '(:struct timeval))))
          (values secs (* 1000 usecs)))))))

(defun %get-current-time ()
  "Cross-implementation abstraction to get the current time measured from the unix epoch (1/1/1970). Should return (values sec nano-sec)."
  #+(and allegro (not os-windows))
  (flet ((allegro-gettimeofday ()
           (let ((tv (ff:allocate-fobject 'timeval :c)))
             (allegro-ffi-gettimeofday tv 0)
             (let ((sec (ff:fslot-value-typed 'timeval :c tv 'tv_sec))
                   (usec (ff:fslot-value-typed 'timeval :c tv 'tv_usec)))
               (ff:free-fobject tv)
               (values sec usec)))))
    (multiple-value-bind (sec usec) (allegro-gettimeofday)
      (values sec (* 1000 usec))))
  #+(and allegro os-windows)
  (let* ((ft (ff:allocate-fobject 'filetime :c)))
    (allegro-ffi-get-system-time-as-file-time ft)
    (let* ((low (ff:fslot-value-typed 'filetime :c ft '|dwLowDateTime|))
           (high (ff:fslot-value-typed 'filetime :c ft '|dwHighDateTime|)))
      (filetime-to-current-time low high)))
  #+cmu
  (multiple-value-bind (success? sec usec) (unix:unix-gettimeofday)
    (assert success? () "unix:unix-gettimeofday reported failure?!")
    (values sec (* 1000 usec)))
  #+sbcl
  (progn
    #+#.(local-time::package-with-symbol? "SB-EXT" "GET-TIME-OF-DAY") ; available from sbcl 1.0.28.66
    (multiple-value-bind (sec nsec) (sb-ext:get-time-of-day)
      (values sec (* 1000 nsec)))
    #-#.(local-time::package-with-symbol? "SB-EXT" "GET-TIME-OF-DAY") ; obsolete, scheduled to be deleted at the end of 2009
    (multiple-value-bind (success? sec nsec) (sb-unix:unix-gettimeofday)
      (assert success? () "sb-unix:unix-gettimeofday reported failure?!")
      (values sec (* 1000 nsec))))
  #+(and ccl (not windows))
  (ccl:rlet ((tv :timeval))
    (let ((err (ccl:external-call "gettimeofday" :address tv :address (ccl:%null-ptr) :int)))
      (assert (zerop err) nil "gettimeofday failed")
      (values (ccl:pref tv :timeval.tv_sec) (* 1000 (ccl:pref tv :timeval.tv_usec)))))
  #+(and ccl windows)
  (ccl:rlet ((time :<lpfiletime>))
    (ccl:external-call "GetSystemTimeAsFileTime" :<lpfiletime> time :void)
    (let* ((low (ccl:%get-unsigned-long time (/ 0 8)))
           (high (ccl:%get-unsigned-long time (/ 32 8))))
      (filetime-to-current-time low high)))
  #+abcl
  (multiple-value-bind (sec millis)
      (truncate (java:jstatic "currentTimeMillis" "java.lang.System") 1000)
    (values sec (* millis 1000000)))
  #+(and lispworks (or linux darwin))
  (lispworks-gettimeofday)
  #-(or allegro cmu sbcl abcl ccl (and lispworks (or linux darwin)))
  (values (- (get-universal-time)
             ;; CL's get-universal-time uses an epoch of 1/1/1900, so adjust the result to the Unix epoch
             #.(encode-universal-time 0 0 0 1 1 1970 0))
          0))

(defvar *clock* t
  "Use the `*clock*' special variable if you need to define your own idea of the current time.

The value of this variable should have the methods `local-time::clock-now', and
`local-time::clock-today'. The currently supported values in local-time are:
  t - use the standard clock
  local-time:leap-second-adjusted - use a clock which adjusts for leap seconds using the information in *default-timezone*.")

(defun now ()
  "Returns a timestamp representing the present moment."
  (clock-now *clock*))

(defun today ()
  "Returns a timestamp representing the present day."
  (clock-today *clock*))

(defgeneric clock-now (clock)
  (:documentation "Returns a timestamp for the current time given a clock."))

(defgeneric clock-today (clock)
  (:documentation "Returns a timestamp for the current date given a
  clock.  The date is encoded by convention as a timestamp with the
  time set to 00:00:00UTC."))

(defun %leap-seconds-offset (leap-seconds sec)
  "Find the latest leap second adjustment effective at SEC system time."
  (elt (leap-seconds-adjustment leap-seconds)
       (transition-position sec (leap-seconds-sec leap-seconds))))

(defun %adjust-sec-for-leap-seconds (sec)
  "Ajdust SEC from system time to Unix time (on systems those clock does not jump back over leap seconds)."
  (let ((leap-seconds (timezone-leap-seconds (%realize-timezone *default-timezone*))))
    (when leap-seconds
      (decf sec (%leap-seconds-offset leap-seconds sec))))
  sec)

(defmethod clock-now ((clock (eql 'leap-second-adjusted)))
  (multiple-value-bind (sec nsec) (%get-current-time)
    (unix-to-timestamp (%adjust-sec-for-leap-seconds sec)
                       :nsec nsec)))

(defmethod clock-now (clock)
  (declare (ignore clock))
  (multiple-value-bind (sec nsec) (%get-current-time)
    (unix-to-timestamp sec :nsec nsec)))

(defmethod clock-today (clock)
  (declare (ignore clock))
  ;; TODO should return a date value, anyhow we will decide to represent it eventually
  (let ((result (now)))
    (setf (sec-of result) 0)
    (setf (nsec-of result) 0)
    result))

(defmacro %defcomparator (name &body body)
  (let ((pair-comparator-name (intern (concatenate 'string "%" (string name)))))
    `(progn
      (declaim (inline ,pair-comparator-name))
      (defun ,pair-comparator-name (time-a time-b)
        (assert (typep time-a 'timestamp)
                nil
                'type-error
                :datum time-a
                :expected-type 'timestamp)
        (assert (typep time-b 'timestamp)
                nil
                'type-error
                :datum time-b
                :expected-type 'timestamp)
        ,@body)
      (defun ,name (&rest times)
        (declare (dynamic-extent times))
        (loop for head on times
              while (cdr head)
              always (,pair-comparator-name (first head) (second head))))
      (define-compiler-macro ,name (&rest times)
        (let ((vars (loop
                      :for i :upfrom 0 :below (length times)
                      :collect (gensym (concatenate 'string "TIME-" (princ-to-string i) "-")))))
          `(let (,@(loop
                     :for var :in vars
                     :for time :in times
                     :collect (list var time)))
            ;; we could evaluate comparisons of timestamp literals here
            (and ,@(loop
                     :for (time-a time-b) :on vars
                     :while time-b
                     :collect `(,',pair-comparator-name ,time-a ,time-b)))))))))

(defun %timestamp-compare (time-a time-b)
  "Returns the symbols <, >, or =, describing the relationship between TIME-A and TIME-b."
  (declare (type timestamp time-a time-b))
  (cond
    ((< (day-of time-a) (day-of time-b)) '<)
    ((> (day-of time-a) (day-of time-b)) '>)
    ((< (sec-of time-a) (sec-of time-b)) '<)
    ((> (sec-of time-a) (sec-of time-b)) '>)
    ((< (nsec-of time-a) (nsec-of time-b)) '<)
    ((> (nsec-of time-a) (nsec-of time-b)) '>)
    (t '=)))

(%defcomparator timestamp<
  (eql (%timestamp-compare time-a time-b) '<))

(%defcomparator timestamp<=
  (not (null (member (%timestamp-compare time-a time-b) '(< =)))))

(%defcomparator timestamp>
  (eql (%timestamp-compare time-a time-b) '>))

(%defcomparator timestamp>=
  (not (null (member (%timestamp-compare time-a time-b) '(> =)))))

(%defcomparator timestamp=
  (eql (%timestamp-compare time-a time-b) '=))

(%defcomparator timestamp/=
  (not (eql (%timestamp-compare time-a time-b) '=)))

(defun contest (test list)
  "Applies TEST to pairs of elements in list, keeping the element which last tested T.  Returns the winning element."
  (reduce (lambda (a b) (if (funcall test a b) a b)) list))

(defun timestamp-minimum (time &rest times)
  "Returns the earliest timestamp"
  (contest #'timestamp< (cons time times)))

(defun timestamp-maximum (time &rest times)
  "Returns the latest timestamp"
  (contest #'timestamp> (cons time times)))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun years-to-days (years)
    "Given a number of years, returns the number of days in those years."
    (let* ((days (* years 365))
           (l1 (floor years 4))
           (l2 (floor years 100))
           (l3 (floor years 400)))
      (+ days l1 (- l2) l3))))

(defun days-to-years (days)
  "Given a number of days, returns the number of years and the remaining days in that year."
  (let ((remaining-days days))
    (multiple-value-bind (400-years remaining-days)
        (floor remaining-days #.(years-to-days 400))
      (let* ((100-years (min (floor remaining-days #.(years-to-days 100)) 3))
             (remaining-days (- remaining-days
                                (* 100-years #.(years-to-days 100)))))
        (multiple-value-bind (4-years remaining-days)
            (floor remaining-days #.(years-to-days 4))
          (let ((years (min 3 (floor remaining-days #.(years-to-days 1)))))
            (values (+ (* 400-years 400)
                       (* 100-years 100)
                       (* 4-years 4)
                       years)
                    (- remaining-days (* years 365))))))))
  ;; the above is the macroexpansion of the following. uses metabang BIND, but kept for clarity because the expansion is unreadable.
  #+nil
  (bind ((remaining-days days)
         ((values 400-years remaining-days) (floor remaining-days #.(years-to-days 400)))
         (100-years (min (floor remaining-days #.(years-to-days 100))
                         3))
         (remaining-days (- remaining-days
                            (* 100-years
                               #.(years-to-days 100))))
         ((values 4-years remaining-days) (floor remaining-days #.(years-to-days 4)))
         (years (min (floor remaining-days 365)
                     3)))
        (values (+ (* 400-years 400)
                   (* 100-years 100)
                   (* 4-years 4)
                   years)
                (- remaining-days (* years 365)))))

(defun %timestamp-decode-date (days)
  "Returns the year, month, and day, given the number of days from the epoch."
  (declare (type integer days))
  (multiple-value-bind (years remaining-days)
      (days-to-years days)
    (let* ((leap-day-p (= remaining-days 365))
           (rotated-1-based-month (if leap-day-p
                                      12 ; march is the first month and february is the last
                                      (position remaining-days +rotated-month-offsets-without-leap-day+ :test #'<)))
           (1-based-month (if (>= rotated-1-based-month 11)
                              (- rotated-1-based-month 10)
                              (+ rotated-1-based-month 2)))
           (1-based-day (if leap-day-p
                            29
                            (1+ (- remaining-days (aref +rotated-month-offsets-without-leap-day+
                                                        (1- rotated-1-based-month)))))))
      (values
       (+ years
          (if (>= rotated-1-based-month 11) ; january is in the next year
              2001
              2000))
       1-based-month
       1-based-day))))

(defun %timestamp-decode-iso-week (timestamp)
  "Returns the year, week number, and day of week components of an ISO week date."
  ;; Algorithm from http://en.wikipedia.org/wiki/Talk:ISO_week_date#Algorithms
  (let* ((dn (timestamp-day-of-week timestamp))
         (day-of-week (if (zerop dn) 7 dn)) ; ISO weekdays are Monday=1 and Sunday=7
         (nearest-thursday (timestamp+ timestamp (- 4 day-of-week) :day))
         (year (timestamp-year nearest-thursday))
         (month (timestamp-month nearest-thursday))
         (day (timestamp-day nearest-thursday))
         (ordinal-day (- (day-of (encode-timestamp 0 0 0 0 day month year :timezone +utc-zone+))
                         (day-of (encode-timestamp 0 0 0 0 1 1 year :timezone +utc-zone+)))))
    (values year
            (1+ (floor ordinal-day 7))
            day-of-week)))

(defun %timestamp-decode-time (seconds)
  "Returns the hours, minutes, and seconds, given the number of seconds since midnight."
  (declare (type integer seconds))
  (multiple-value-bind (hours hour-remainder)
      (floor seconds +seconds-per-hour+)
    (multiple-value-bind (minutes seconds)
        (floor hour-remainder +seconds-per-minute+)
      (values
       hours
       minutes
       seconds))))

(defun decode-timestamp (timestamp &key (timezone *default-timezone*) offset)
  "Returns the decoded time as multiple values: nsec, ss, mm, hh, day, month, year, day-of-week"
  (declare (type timestamp timestamp))
  (let ((timezone (if offset (the timezone +none-zone+) timezone)))
    (multiple-value-bind (offset* daylight-p abbreviation)
        (timestamp-subtimezone timestamp timezone)
      (multiple-value-bind (adjusted-secs adjusted-days)
          (%adjust-to-timezone timestamp timezone offset)
        (multiple-value-bind (hours minutes seconds)
            (%timestamp-decode-time adjusted-secs)
          (multiple-value-bind (year month day)
              (%timestamp-decode-date adjusted-days)
            (values
             (nsec-of timestamp)
             seconds minutes hours
             day month year
             (timestamp-day-of-week timestamp :timezone timezone :offset offset)
             daylight-p
             (or offset offset*)
             abbreviation)))))))

(defun timestamp-year (timestamp &key (timezone *default-timezone*))
  "Returns the cardinal year upon which the timestamp falls."
  (nth-value 0
             (%timestamp-decode-date
              (nth-value 1 (%adjust-to-timezone timestamp timezone)))))

(defun timestamp-century (timestamp &key (timezone *default-timezone*))
  "Returns the ordinal century upon which the timestamp falls."
  (let* ((year (timestamp-year timestamp :timezone timezone))
         (sign (signum year)))
    (+ sign
       (* sign
          (truncate (1- (abs year)) 100)))))

(defun timestamp-millennium (timestamp &key (timezone *default-timezone*))
  "Returns the ordinal millennium upon which the timestamp falls."
  (let* ((year (timestamp-year timestamp :timezone timezone))
         (sign (signum year)))
    (+ sign
       (* sign
          (truncate (1- (abs year)) 1000)))))

(defun timestamp-decade (timestamp &key (timezone *default-timezone*))
  "Returns the cardinal decade upon which the timestamp falls."
  (truncate (timestamp-year timestamp :timezone timezone) 10))

(defun timestamp-month (timestamp &key (timezone *default-timezone*))
  "Returns the month upon which the timestamp falls."
  (nth-value 1
             (%timestamp-decode-date
              (nth-value 1 (%adjust-to-timezone timestamp timezone)))))

(defun timestamp-day (timestamp &key (timezone *default-timezone*))
  "Returns the day of the month upon which the timestamp falls."
  (nth-value 2
             (%timestamp-decode-date
              (nth-value 1 (%adjust-to-timezone timestamp timezone)))))

(defun timestamp-hour (timestamp &key (timezone *default-timezone*))
  (nth-value 0
             (%timestamp-decode-time
              (nth-value 0 (%adjust-to-timezone timestamp timezone)))))

(defun timestamp-minute (timestamp &key (timezone *default-timezone*))
  (nth-value 1
             (%timestamp-decode-time
              (nth-value 0 (%adjust-to-timezone timestamp timezone)))))

(defun timestamp-second (timestamp &key (timezone *default-timezone*))
  (nth-value 2
             (%timestamp-decode-time
              (nth-value 0 (%adjust-to-timezone timestamp timezone)))))

(defun timestamp-microsecond (timestamp)
  (floor (nsec-of timestamp) 1000))

(defun timestamp-millisecond (timestamp)
  (floor (nsec-of timestamp) 1000000))

(defun split-timestring (str &rest args)
  (declare (inline))
  (apply #'%split-timestring (coerce str 'simple-string) args))

(defun %split-timestring (time-string &key
                          (start 0)
                          (end (length time-string))
                          (fail-on-error t) (time-separator #\:)
                          (date-separator #\-)
                          (date-time-separator #\T)
                          (allow-missing-elements t)
                          (allow-missing-date-part allow-missing-elements)
                          (allow-missing-time-part allow-missing-elements)
                          (allow-missing-timezone-part allow-missing-time-part))
  "Based on http://www.ietf.org/rfc/rfc3339.txt including the function names used. Returns (values year month day hour minute second nsec offset-hour offset-minute). On parsing failure, signals INVALID-TIMESTRING if FAIL-ON-ERROR is NIL, otherwise returns NIL."
  (declare (type character date-time-separator time-separator date-separator)
           (type simple-string time-string)
           (optimize (speed 3)))
  (the list
    (let (year month day hour minute second nsec offset-hour offset-minute)
      (declare (type (or null fixnum) start end year month day hour minute second offset-hour offset-minute)
               (type (or null (signed-byte 32)) nsec))
      (macrolet ((passert (expression)
                   `(unless ,expression
                     (parse-error ',expression)))
                 (parse-integer-into (start-end place &optional low-limit high-limit)
                   (let ((entry (gensym "ENTRY"))
                         (value (gensym "VALUE"))
                         (pos (gensym "POS"))
                         (start (gensym "START"))
                         (end (gensym "END")))
                     `(let ((,entry ,start-end))
                       (if ,entry
                           (let ((,start (car ,entry))
                                 (,end (cdr ,entry)))
                             (multiple-value-bind (,value ,pos) (parse-integer time-string :start ,start :end ,end :junk-allowed t)
                               (passert (= ,pos ,end))
                               (setf ,place ,value)
                               ,(if (and low-limit high-limit)
                                    `(passert (<= ,low-limit ,place ,high-limit))
                                    (values))
                               (values)))
                           (progn
                             (passert allow-missing-elements)
                             (values))))))
                 (with-parts-and-count ((start end split-chars) &body body)
                   `(multiple-value-bind (parts count) (split ,start ,end ,split-chars)
                     (declare (ignorable count) (type fixnum count)
                      ;;(type #1=(cons (cons fixnum fixnum) (or null #1#)) parts)
                      (type list parts))
                     ,@body)))
        (labels ((split (start end chars)
                   (declare (type fixnum start end))
                   (unless (consp chars)
                     (setf chars (list chars)))
                   (loop with last-match = start
                         with match-count of-type (integer 0 #.most-positive-fixnum) = 0
                         for index of-type fixnum upfrom start
                         while (< index end)
                         when (member (aref time-string index) chars :test #'char-equal)
                         collect (prog1 (if (< last-match index)
                                            (cons last-match index)
                                            nil)
                                   (incf match-count)
                                   (setf last-match (1+ index)))
                                 into result
                         finally (return (values (if (zerop (- index last-match))
                                                     result
                                                     (prog1
                                                         (nconc result (list (cons last-match index)))
                                                       (incf match-count)))
                                                 match-count))))
                 (parse ()
                   (with-parts-and-count (start end date-time-separator)
                     (cond ((= count 2)
                            (if (first parts)
                                (full-date (first parts))
                                (passert allow-missing-date-part))
                            (if (second parts)
                                (full-time (second parts))
                                (passert allow-missing-time-part))
                            (done))
                           ((and (= count 1)
                                 allow-missing-date-part
                                 (find time-separator time-string
                                       :start (car (first parts))
                                       :end (cdr (first parts))))
                            (full-time (first parts))
                            (done))
                           ((and (= count 1)
                                 allow-missing-time-part
                                 (find date-separator time-string
                                       :start (car (first parts))
                                       :end (cdr (first parts))))
                            (full-date (first parts))
                            (done)))
                     (parse-error nil)))
                 (full-date (start-end)
                   (let ((parts (split (car start-end) (cdr start-end) date-separator)))
                     (passert (%list-length= 3 parts))
                     (date-fullyear (first parts))
                     (date-month (second parts))
                     (date-mday (third parts))))
                 (date-fullyear (start-end)
                   (parse-integer-into start-end year))
                 (date-month (start-end)
                   (parse-integer-into start-end month 1 12))
                 (date-mday (start-end)
                   (parse-integer-into start-end day 1 31))
                 (full-time (start-end)
                   (let ((start (car start-end))
                         (end (cdr start-end)))
                     (with-parts-and-count (start end (list #\Z #\- #\+))
                       (let* ((zulup (find #\Z time-string :test #'char-equal :start start :end end))
                              (sign (unless zulup
                                      (if (find #\+ time-string :test #'char-equal :start start :end end)
                                          1
                                          -1))))
                         (passert (<= 1 count 2))
                         (unless (and (eq (first parts) nil)
                                      (not (rest parts)))
                           ;; not a single #\Z
                           (partial-time (first parts)))
                         (when zulup
                           (setf offset-hour 0
                                 offset-minute 0))
                         (if (= count 1)
                             (passert (or zulup allow-missing-timezone-part))
                             (let* ((entry (second parts))
                                    (start (car entry))
                                    (end (cdr entry)))
                               (declare (type fixnum start end))
                               (passert (or zulup
                                            (not (zerop (- end start)))))
                               (unless zulup
                                 (time-offset (second parts) sign))))))))
                 (partial-time (start-end)
                   (with-parts-and-count ((car start-end) (cdr start-end) time-separator)
                     (passert (eql count 3))
                     (time-hour (first parts))
                     (time-minute (second parts))
                     (time-second (third parts))))
                 (time-hour (start-end)
                   (parse-integer-into start-end hour 0 23))
                 (time-minute (start-end)
                   (parse-integer-into start-end minute 0 59))
                 (time-second (start-end)
                   (with-parts-and-count ((car start-end) (cdr start-end) '(#\. #\,))
                     (passert (<= 1 count 2))
                     (let ((*read-eval* nil))
                       (parse-integer-into (first parts) second 0 59)
                       (if (> count 1)
                           (let* ((start (car (second parts)))
                                  (end (cdr (second parts))))
                             (declare (type (integer 0 #.array-dimension-limit) start end))
                             (passert (<= (- end start) 9))
                             (let ((new-end (position #\0 time-string
                                                      :test-not #'eql
                                                      :start start
                                                      :end end
                                                      :from-end t)))
                               (when new-end
                                 (setf end (min (1+ new-end)))))
                             (setf nsec (* (the (integer 0 999999999) (parse-integer time-string :start start :end end))
                                           (aref #.(coerce #(1000000000 100000000 10000000
                                                             1000000 100000 10000 1000 100 10 1)
                                                           '(simple-array (signed-byte 32) (10)))
                                                 (- end start)))))
                           (setf nsec 0)))))
                 (time-offset (start-end sign)
                   (with-parts-and-count ((car start-end) (cdr start-end) time-separator)
                     (passert (or (and allow-missing-timezone-part (zerop count))
                                  (= count 1)
                                  (= count 2)))

                     (cond
                       ((= count 2)
                        ;; hh:mm offset
                        (parse-integer-into (first parts) offset-hour 0 23)
                        (parse-integer-into (second parts) offset-minute 0 59))
                       ((= (- (cdar parts) (caar parts)) 4)
                        ;; hhmm offset
                        (parse-integer-into (cons (caar parts)
                                                  (+ (caar parts) 2))
                                            offset-hour 0 23)
                        (parse-integer-into (cons (+ (caar parts) 2)
                                                  (+ (caar parts) 4))
                                            offset-minute 0 59))
                       ((= (- (cdar parts) (caar parts)) 2)
                        ;; hh offset
                        (parse-integer-into (cons (caar parts)
                                                  (+ (caar parts) 2))
                                            offset-hour 0 23)
                        (setf offset-minute 0)))

                     (setf offset-hour (* offset-hour sign)
                           offset-minute (* offset-minute sign))))
                 (parse-error (failure)
                   (if fail-on-error
                       (error 'invalid-timestring :timestring time-string :failure failure)
                       (return-from %split-timestring nil)))
                 (done ()
                   (return-from %split-timestring (list year month day hour minute second nsec offset-hour offset-minute))))
          (parse))))))

(defun parse-rfc3339-timestring (timestring &key (fail-on-error t)
                                            (allow-missing-time-part nil))
  (parse-timestring timestring :fail-on-error fail-on-error
                    :allow-missing-timezone-part nil
                    :allow-missing-time-part allow-missing-time-part
                    :allow-missing-date-part nil))

(defun parse-timestring (timestring &key
                         start
                         end
                         (fail-on-error t)
                         (time-separator #\:)
                         (date-separator #\-)
                         (date-time-separator #\T)
                         (allow-missing-elements t)
                         (allow-missing-date-part allow-missing-elements)
                         (allow-missing-time-part allow-missing-elements)
                         (allow-missing-timezone-part allow-missing-elements)
                         (offset 0))
  "Parse a timestring and return the corresponding TIMESTAMP. See split-timestring for details. Unspecified fields in the timestring are initialized to their lowest possible value, and timezone offset is 0 (UTC) unless explicitly specified in the input string."
  (let ((parts (%split-timestring (coerce timestring 'simple-string)
                                  :start (or start 0)
                                  :end (or end (length timestring))
                                  :fail-on-error fail-on-error
                                  :time-separator time-separator
                                  :date-separator date-separator
                                  :date-time-separator date-time-separator
                                  :allow-missing-elements allow-missing-elements
                                  :allow-missing-date-part allow-missing-date-part
                                  :allow-missing-time-part allow-missing-time-part
                                  :allow-missing-timezone-part allow-missing-timezone-part)))
    (when parts
      (destructuring-bind (year month day hour minute second nsec offset-hour offset-minute)
          parts
        (encode-timestamp
         (or nsec 0)
         (or second 0)
         (or minute 0)
         (or hour 0)
         (or day 1)
         (or month 3)
         (or year 2000)
         :offset (if offset-hour
                     (+ (* offset-hour 3600)
                        (* (or offset-minute 0) 60))
                     offset))))))

(defun ordinalize (day)
  "Return an ordinal string representing the position of DAY in a sequence (1st, 2nd, 3rd, 4th, etc)."
  (declare (type (integer 1 31) day))
  (format nil "~d~a" day
          (if (<= 11 day 13)
              "th"
              (case (mod day 10)
                (1 "st")
                (2 "nd")
                (3 "rd")
                (t "th")))))

(defun %construct-timestring (timestamp format timezone)
  "Constructs a string representing TIMESTAMP given the FORMAT of the string and the TIMEZONE.  See the documentation of FORMAT-TIMESTRING for the structure of FORMAT."
  (declare (type timestamp timestamp)
           (optimize (speed 3)))
  (multiple-value-bind (nsec sec minute hour day month year weekday daylight-p offset abbrev)
      (decode-timestamp timestamp :timezone timezone)
    (declare (ignore daylight-p))
    (multiple-value-bind (iso-year iso-week iso-weekday)
        (%timestamp-decode-iso-week timestamp)
      (let ((*print-pretty* nil)
            (*print-circle* nil))
        (with-output-to-string (result nil)
          (dolist (fmt format)
            (cond
              ((member fmt '(:gmt-offset :gmt-offset-or-z :gmt-offset-hhmm))
               (multiple-value-bind (offset-hours offset-secs)
                   (floor offset +seconds-per-hour+)
                 (declare (fixnum offset-hours offset-secs))
                 (if (and (eql fmt :gmt-offset-or-z) (zerop offset))
                     (princ #\Z result)
                     (format result "~c~2,'0d~:[:~;~]~2,'0d"
                             (if (minusp offset-hours) #\- #\+)
                             (abs offset-hours)
                             (eql fmt :gmt-offset-hhmm)
                             (truncate (abs offset-secs)
                                       +seconds-per-minute+)))))
              ((eql fmt :short-year)
               (princ (mod year 100) result))
              ((eql fmt :long-month)
               (princ (aref +month-names+ month) result))
              ((eql fmt :short-month)
               (princ (aref +short-month-names+ month) result))
              ((eql fmt :long-weekday)
               (princ (aref +day-names+ weekday) result))
              ((eql fmt :short-weekday)
               (princ (aref +short-day-names+ weekday) result))
              ((eql fmt :minimal-weekday)
               (princ (aref +minimal-day-names+ weekday) result))
              ((eql fmt :timezone)
               (princ abbrev result))
              ((eql fmt :ampm)
               (princ (if (< hour 12) "am" "pm") result))
              ((eql fmt :ordinal-day)
               (princ (ordinalize day) result))
              ((or (stringp fmt) (characterp fmt))
               (princ fmt result))
              (t
               (let ((val (ecase (if (consp fmt) (car fmt) fmt)
                            (:nsec nsec)
                            (:usec (floor nsec 1000))
                            (:msec (floor nsec 1000000))
                            (:sec sec)
                            (:min minute)
                            (:hour hour)
                            (:hour12 (1+ (mod (1- hour) 12)))
                            (:day day)
                            (:weekday weekday)
                            (:month month)
                            (:year year)
                            (:iso-week-year iso-year)
                            (:iso-week-number iso-week)
                            (:iso-week-day iso-weekday))))
                 (cond
                   ((atom fmt)
                    (princ val result))
                   ((minusp val)
                    (format result "-~v,vd"
                            (second fmt)
                            (or (third fmt) #\0)
                            (abs val)))
                   (t
                    (format result "~v,vd"
                            (second fmt)
                            (or (third fmt) #\0)
                            val))))))))))))

(defun format-timestring (destination timestamp &key
                          (format +iso-8601-format+)
                          (timezone *default-timezone*))
  "Constructs a string representation of TIMESTAMP according to FORMAT and returns it.  If destination is T, the string is written to *standard-output*.  If destination is a stream, the string is written to the stream.

FORMAT is a list containing one or more of strings, characters, and keywords. Strings and characters are output literally, while keywords are replaced by the values here:

  :YEAR              *year
  :MONTH             *numeric month
  :DAY               *day of month
  :HOUR              *hour
  :MIN               *minutes
  :SEC               *seconds
  :WEEKDAY           *numeric day of week starting from index 0, which means Sunday
  :MSEC              *milliseconds
  :USEC              *microseconds
  :NSEC              *nanoseconds
  :ISO-WEEK-YEAR     *year for ISO week date (can be different from regular calendar year)
  :ISO-WEEK-NUMBER   *ISO week number (i.e. 1 through 53)
  :ISO-WEEK-DAY      *ISO compatible weekday number (monday=1, sunday=7)
  :LONG-WEEKDAY      long form of weekday (e.g. Sunday, Monday)
  :SHORT-WEEKDAY     short form of weekday (e.g. Sun, Mon)
  :MINIMAL-WEEKDAY   minimal form of weekday (e.g. Su, Mo)
  :LONG-MONTH        long form of month (e.g. January, February)
  :SHORT-MONTH       short form of month (e.g. Jan, Feb)
  :HOUR12            *hour on a 12-hour clock
  :AMPM              am/pm marker in lowercase
  :GMT-OFFSET        the gmt-offset of the time, in +00:00 form
  :GMT-OFFSET-OR-Z   like :GMT-OFFSET, but is Z when UTC
  :GMT-OFFSET-HHMM   like :GMT-OFFSET, but in +0000 form
  :TIMEZONE          timezone abbrevation for the time

Elements marked by * can be placed in a list in the form: \(:keyword padding &optional \(padchar #\0))

The string representation of the value will be padded with the padchar.

You can see examples in +ISO-8601-FORMAT+, +ASCTIME-FORMAT+, and +RFC-1123-FORMAT+."
  (declare (type (or boolean stream) destination))
  (let ((result (%construct-timestring timestamp format timezone)))
    (when destination
      (write-string result (if (eq t destination) *standard-output* destination)))
    result))

(defun format-rfc1123-timestring (destination timestamp &key
                                  (timezone *default-timezone*))
  (format-timestring destination timestamp
                     :format +rfc-1123-format+
                     :timezone timezone))

(defun to-rfc1123-timestring (timestamp)
  (format-rfc1123-timestring nil timestamp))

(defun format-rfc3339-timestring (destination timestamp &key
                                  omit-date-part
                                  omit-time-part
                                  (omit-timezone-part omit-time-part)
                                  (use-zulu t)
                                  (timezone *default-timezone*))
  "Formats a timestring in the RFC 3339 format, a restricted form of the ISO-8601 timestring specification for Internet timestamps."
  (let ((rfc3339-format
         (if (and use-zulu
                  (not omit-date-part)
                  (not omit-time-part)
                  (not omit-timezone-part))
             +rfc3339-format+ ; micro optimization
             (append
              (unless omit-date-part
                '((:year 4) #\-
                  (:month 2) #\-
                  (:day 2)))
              (unless (or omit-date-part
                          omit-time-part)
                '(#\T))
              (unless omit-time-part
                '((:hour 2) #\:
                  (:min 2) #\:
                  (:sec 2) #\.
                  (:usec 6)))
              (unless omit-timezone-part
                (if use-zulu
                    '(:gmt-offset-or-z)
                    '(:gmt-offset)))))))
    (format-timestring destination timestamp :format rfc3339-format :timezone timezone)))

(defun to-rfc3339-timestring (timestamp)
  (format-rfc3339-timestring nil timestamp))

(defun %read-timestring (stream char)
  (declare (ignore char))
  (parse-timestring
   (with-output-to-string (str)
     (loop for c = (read-char stream nil)
        while (and c (or (digit-char-p c) (member c '(#\: #\T #\t #\: #\- #\+ #\Z #\.))))
        do (princ c str)
        finally (when c (unread-char c stream))))
   :allow-missing-elements t))

(defun %read-universal-time (stream char arg)
  (declare (ignore char arg))
  (universal-to-timestamp
              (parse-integer
               (with-output-to-string (str)
                 (loop for c = (read-char stream nil)
                       while (and c (digit-char-p c))
                       do (princ c str)
                       finally (when c (unread-char c stream)))))))

(defun enable-read-macros ()
  "Enables the local-time reader macros for literal timestamps and universal time."
  (set-macro-character #\@ '%read-timestring)
  (set-dispatch-macro-character #\# #\@ '%read-universal-time)
  (values))

(defvar *debug-timestamp* nil)

(defmethod print-object ((object timestamp) stream)
  "Print the TIMESTAMP object using the standard reader notation"
  (cond
    (*debug-timestamp*
       (print-unreadable-object (object stream :type t)
         (format stream "~d/~d/~d"
                 (day-of object)
                 (sec-of object)
                 (nsec-of object))))
    (t
     (when *print-escape*
       (write-char #\@ stream))
     (format-rfc3339-timestring stream object))))

(defmethod print-object ((object timezone) stream)
  "Print the TIMEZONE object in a reader-rejected manner."
  (print-unreadable-object (object stream :type t)
    (format stream "~:[UNLOADED~;~{~a~^ ~}~]"
            (timezone-loaded object)
            (map 'list #'subzone-abbrev (timezone-subzones object)))))

(defun astronomical-julian-date (timestamp)
  "Returns the astronomical julian date referred to by the timestamp."
  (- (day-of timestamp) +astronomical-julian-date-offset+))

(defun modified-julian-date (timestamp)
  "Returns the modified julian date referred to by the timestamp."
  (- (day-of timestamp) +modified-julian-date-offset+))

(declaim (notinline format-timestring))