;;;;
;;;; time.stk                   -- Date and Time Operations
;;;;
;;;; Copyright © 2002-2024 Erick Gallesio <eg@stklos.net>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;;           Author: Erick Gallesio [eg@unice.fr]
;;;;    Creation date:  3-Apr-2002 10:06 (eg)
;;;;

(export time? time->seconds seconds->time make-date date? seconds->date
        date-nanosecond date-second date-minute date-hour
        date-day date-month date-year
        date-week-day date-year-day
        date-dst date-tz time-zone-name
        seconds->list current-date current-time seconds->string date->string
        time-nanosecond set-time-nanosecond! time-second set-time-second!
        time-type set-time-type! make-time

        time-tai->time-utc time-tai->time-utc!
        time-utc->time-tai time-utc->time-tai!

        ;; internal symbols used by SRFI-19
        %leap-second-table %leap-second-delta
        %time-tai->time-utc! %time-utc->time-tai!)


;;;; ======================================================================
;;;;
;;;;                    TIME functions
;;;;
;;;; ======================================================================


#|
<doc EXT make-time
 * (make-time nanosecond second)
 * (make-time type nanosecond second)
 *
 * Creates a time structure with the given |nanosecond| and |second|.
 * If |type| is passed, it must be a symbol representing one of the
 * supported time types (|time-tai|, |time-utc|, |time-monotonic|,
 * |time-process| and |time-duration|).
 *
 * NOTE:  |time-monotonic|, |time-process| and |time-duration| can
 * be created, but operations on them are only available when SRFI-19 is
 * loaded.
doc>
|#
(define (make-time a b :optional (c #f))
  (cond ((symbol? a)
         ;; a = type
         ;; b = nano
         ;; c = sec -> c necessary
         (unless c
           (error "since first argument is symbol, 3 args (type, nanosecond and second) required, only 2 given"))
         (unless (memq a '(time-tai time-utc time-monotonic time-process time-duration))
           (error "bad time type ~S" a))
         (unless (integer? b) (error "bad integer ~S" b))
         (unless (integer? c) (error "bad integer ~S" c))
         (make-struct %time a b c))
        ((integer? a)
         ;; a = nano
         ;; b = sec -> c NOT allowed
         (when c (error "since first argument is integer, 2 args (nanosecond and second) required, but 3 given"))
         (unless (integer? b) (error "bad integer ~S" b))
         (make-struct %time 'time-utc a b))
        (else (error "bad symbol or integer ~S" a))))

#|
<doc EXT time-type set-time-type! time-second set-time-second! time-nanosecond set-time-nanosecond!
 * (time-type t)
 * (set-time-type! t v)
 * (time-second t)
 * (set-time-second! t s)
 * (time-nanosecond t)
 * (set-time-nanosecond! t n)
 *
 * These are accessors for time structures.
doc>
|#
(define (time-type t) (struct-ref t 'type))
(define (set-time-type! t v) (struct-set! t 'type v))

(define (time-second t) (struct-ref t 'second))
(define (set-time-second! t s) (struct-set! t 'second s))

(define (time-nanosecond t) (struct-ref t 'nanosecond))
(define (set-time-nanosecond! t n) (struct-set! t 'nanosecond n))

#|
<doc EXT time?
 * (time? obj)
 *
 * Return `#t` if |obj| is a time object, othererwise returns `#f`.
doc>
|#
(define (time? obj)
  (and (struct? obj) (eq? (struct-type obj) %time)))


(define %nano #e1e9)
(define %sid  86400)    ; seconds in a day


;;;
;;; CONVERSIONS SECONDS <-> TIME
;;;

#|
<doc EXT time->seconds
 * (time->seconds time)
 *
 * Convert the time object |time| into an inexact real number representing
 * the number of seconds elapsed since the Epoch.
 * @lisp
 * (time->seconds (current-time))  ==>  1138983411.09337
 * @end lisp
doc>
|#
(define (time->seconds time)
  (if (time? time)
      (exact->inexact (+ (%fast-struct-ref time %time 'second 2)
                         (/ (%fast-struct-ref time %time 'nanosecond 1)
                            %nano)))
      (error 'time-seconds "bad time ~S" time)))


#|
<doc EXT seconds->time
 * (seconds->time x)
 *
 * Converts into a time object the real number |x| representing the number
 * of seconds elapsed since the Epoch.
 * @lisp
 * (seconds->time (+ 10 (time->seconds (current-time))))
 *          ==>  a time object representing 10 seconds in the future
 * @end lisp
doc>
|#
(define (seconds->time x)
  (if (and (number? x) (positive? x))
      (cond
        ((real? x)
         (let ((n (inexact->exact (round (* x #e1e9)))))
           (make-struct %time :time-utc  (remainder n %nano) (quotient n %nano))))
        ((integer? x)
         (make-struct %time 0 x))
        (else
         (error 'seconds->time "cannot convert ~S to a time" x)))
      (error 'seconds->time "bad number ~S" x)))


;;;
;;; CONVERSIONS TAI <-> UTC
;;;

;;
;; each entry is ( seconds since epoch . # seconds to add for tai )
;; note they go higher to lower, and end in 1972.
;;
;; NOTE: the correct way to use this is to take the integer number of seconds
;;       from UTC time, find if it is >= than the CAR, then add the number in
;;       the CDR to obtain the TAI seconds,
;;       OR
;;       take the number of seconds in TAI time, subtract it from the CDR, then
;;       see it it would ne >= the CAR, and if so, subtract it from the original
;;       number to obtain the number of UTC seconds.
;;
;; FIXME: can we have a reliable URL to get an updated table when a more entries
;;        are added?
;;        Maybe https://www.ietf.org/timezones/data/leap-seconds.list ?
;;
(define %leap-second-table
  '((1483228800 . 37)  ;; 1 Jan 2017
    (1435708800 . 36)  ;; 1 Jul 2015
    (1341100800 . 35)  ;; 1 Jul 2012
    (1230768000 . 34)  ;; 1 Jan 2009
    (1136073600 . 33)  ;; 1 Jan 2006
    (915148800 . 32)   ;; 1 Jan 1999
    (867715200 . 31)   ;; 1 Jul 1997
    (820454400 . 30)   ;; 1 Jan 1996
    (773020800 . 29)   ;; 1 Jul 1994
    (741484800 . 28)   ;; 1 Jul 1993
    (709948800 . 27)   ;; 1 Jul 1992
    (662688000 . 26)   ;; 1 Jan 1991
    (631152000 . 25)   ;; 1 Jan 1990
    (567993600 . 24)   ;; 1 Jan 1988
    (489024000 . 23)   ;; 1 Jul 1985
    (425865600 . 22)   ;; 1 Jul 1983
    (394329600 . 21)   ;; 1 Jul 1982
    (362793600 . 20)   ;; 1 Jul 1981
    (315532800 . 19)   ;; 1 Jan 1980
    (283996800 . 18)   ;; 1 Jan 1979
    (252460800 . 17)   ;; 1 Jan 1978
    (220924800 . 16)   ;; 1 Jan 1977
    (189302400 . 15)   ;; 1 Jan 1976
    (157766400 . 14)   ;; 1 Jan 1975
    (126230400 . 13)   ;; 1 Jan 1974
    (94694400  . 12)   ;; 1 Jan 1973
    (78796800  . 11)   ;; 1 Jul 1972
    (63072000  . 10))) ;; 1 Jan 1972


;; This funtion receives a number of seconds and returns the number of
;; seconds (the delta) to be added from UTC to get the equivalent
;; UTC time.
(define (%leap-second-delta utc-seconds)
  (letrec ( (lsd (lambda (table)
                   (cond ((>= utc-seconds (caar table))
                          (cdar table))
                         (else (lsd (cdr table)))))) )
    (if (< utc-seconds  (* (- 1972 1970) 365 %sid)) ;; 63072000, last table entry
        0
        (lsd %leap-second-table))))


;; This funtion receives a number of seconds and returns the number of
;; seconds (the delta) to be subtracted from TAI to get the equivalent
;; UTC.
(define (%leap-second-neg-delta tai-seconds)
  (letrec ( (lsd (lambda (table)
                   (cond ((null? table) 0)
                         ((<= (cdar table) (- tai-seconds (caar table)))
                          (cdar table))
                         (else (lsd (cdr table)))))) )
    (if (< tai-seconds  (* (- 1972 1970) 365 %sid)) ;; 63072000, last table entry
        0
        (lsd %leap-second-table))))



;;
;; TAI -> UTC
;;

(define (%time-tai->time-utc! time-in time-out caller)
  (when (not (eq? (time-type time-in) 'time-tai))
    (error caller "bad TAI time ~S" time-in))
  ;;(%time-error caller 'incompatible-time-types time-in))
  (set-time-type! time-out 'time-utc)
  (set-time-nanosecond! time-out (time-nanosecond time-in))
  (set-time-second!     time-out (- (time-second time-in)
                                    (%leap-second-neg-delta
                                     (time-second time-in))))
  time-out)

#|
<doc EXT time-tai->time-utc time-tai->time-utc!
 * (time-tai->time-utc t)
 * (time-tai->time-utc! t)
 *
 * Converts |t|, which must be of type |time-tai|, to the type
 * |time-utc|.
 *
 * |Time-tai->time-utc| creates a new object, while |time-tai->time-utc|
 * can use |t| to build the returned object.
doc>
|#
(define (time-tai->time-utc time-in)
  (%time-tai->time-utc! time-in (make-time 'time-utc 0 0) 'time-tai->time-utc))

(define (time-tai->time-utc! time-in)
  (%time-tai->time-utc! time-in time-in 'time-tai->time-utc!))

;;
;; UTC -> TAI
;;

(define (%time-utc->time-tai! time-in time-out caller)
  (when (not (eq? (time-type time-in) 'time-utc))
    (error caller "bad UTC time ~S" time-in))
      ;;(%time-error caller 'incompatible-time-types time-in))
  (set-time-type! time-out 'time-tai)
  (set-time-nanosecond! time-out (time-nanosecond time-in))
  (set-time-second!     time-out (+ (time-second time-in)
                                    (%leap-second-delta
                                     (time-second time-in))))
  time-out)

#|
<doc EXT time-utc->time-tai time-utc->time-tai!
 * (time-utc->time-tai t)
 * (time-utc->time-tai! t)
 *
 * Converts |t|, which must be of type |time-utc|, to the type
 * |time-tai|.
 *
 * |Time-utc->time-tai| creates a new object, while |time-utc->time-tai|
 * can use |t| to build the returned object.
doc>
|#

(define (time-utc->time-tai time-in)
  (%time-utc->time-tai! time-in (make-time 'time-tai 0 0) 'time-utc->time-tai))

(define (time-utc->time-tai! time-in)
  (%time-utc->time-tai! time-in time-in 'time-utc->time-tai!))


;;;
;;; CURRENT TIME
;;;

;;;
;;; %get-time-of-day is now implementeed using (current-second)
;;; and splitting seconds and nanoseconds.
;;;
;;; This returns TAI!
;;;
;;; --jpellegrini
;;;
(define (%get-time-of-day)
  (let* ((t (current-second)) ; inexact TAI
         (s (exact (floor t)))
         (n (- t s)))
    (values s n))) ;; exact TAI second,
                   ;; inexact TAI nanosecond

#|
 Current TAI

 RETURNS: time structure.

 stklos> (describe  (%current-time-tai))
 #[struct %time 140482687955760] is an instance of the structure type %time.
 Slots are:
      type = time-tai
      nanosecond = 484885931
      second = 1653363174
|#
(define (%current-time-tai)
  (receive (seconds ms) (%get-time-of-day)
           (make-time  'time-tai
                       (exact (floor (* ms %nano)))
                       seconds )))


#|
 Current UTC

 RETURNS: time structure.

 stklos> (describe  (%current-time-utc))
#[struct %time 140482687990160] is an instance of the structure type %time.
Slots are:
     type = time-utc
     nanosecond = 876263856
     second = 1653363215
|#
(define (%current-time-utc)
  (receive (seconds ms) (%get-time-of-day)
           (make-time 'time-utc
                      (exact (floor (* ms %nano)))
                      (- seconds (%leap-second-delta seconds)))))


#|
<doc EXT current-time
 * (current-time)
 * (current-time type)
 *
 * Return the current time as time object. The type can be |time-utc| or |time-tai|.
 * If omitted, |type| is |time-utc|.
 *
 * NOTE: To use more time types, such as |time-monotonic| and |time-process|, please
 * load {{quick-link-srfi 19}}.
doc>
|#
(define (current-time . type)
  (cond ((or (null? type) (eq? (car type) 'time-utc))
         (%current-time))
        ((> (length type) 1)
         (error "too many arguments (0 or 1 expected, ~S given)"
                (length type)))
        ((eq? (car type) 'time-tai)
         (time-utc->time-tai (%current-time)))
        (else (error "unsupported time type ~S" (car type)))))

;;;; ======================================================================
;;;;
;;;;                    DATE functions
;;;;
;;;; ======================================================================
#|
<doc EXT make-date
 * (make-date :key      nanosecond second minute hour day month year zone-offset)
 * (make-date :optional nanosecond second minute hour day month year zone-offset)
 *
 * Build a date from its argument. |hour|, |minute|, |second|, |nanosecond|
 * default to 0; |day| and |month| default to 1; |year| defaults to 1970.
doc>
|#
(define (make-date . args)
  (if (and (pair? args) (keyword? (car args)))
      (apply %make-date-key args)
      (apply %make-date-opt args)))

(define (%make-date-key :key (nanosecond 0) (second 0) (minute 0) (hour 0)
                        (day 1) (month 1) (year 1970) (zone-offset #f))
  (%make-date nanosecond second minute hour day month year zone-offset))

(define (%make-date-opt :optional (nanosecond 0) (second 0) (minute 0) (hour 0)
                        (day 1) (month 1) (year 1970) (zone-offset #f))
  (%make-date nanosecond second minute hour day month year zone-offset))

(define (check name arg min max)
  (unless (and (integer? arg)
               (<= min arg max))
    (error "bad ~s ~s" name arg)))

(define (%make-date   nanosecond second minute hour day month year zone-offset)
  (check 'nanosecond nanosecond 0 999999999)
  (check 'second second 0 60)
  (check 'minute minute 0 59)
  (check 'hour hour 0 23)
  (check 'day day 1 31)
  (check 'month month 1 12)
  (unless (integer? year) (error "bad year ~s" year))
  (unless (or (integer? zone-offset)
              (not zone-offset))
    (error "bad zone offset ~s" zone-offset))
  (let ((res (make-struct %date
                          nanosecond
                          second
                          minute
                          hour
                          day
                          month
                          year
                          #void          ;; week-day
                          #void          ;; year-day
                          -1             ;; dst
                          zone-offset)))
    ;; week-day, year-day and dst will be filled automaticallyby seconds->date,
    ;; which call localtime(3).

    ;; sec-offset is how much the second count is above 59.
    ;; FIXME: should use the leap table instead?
    (let ((sec-offset (max 0 (- second 59))))
      (let ((tmp (seconds->date (-  (date->seconds res) sec-offset)))
            (offset (if zone-offset zone-offset (local-timezone-offset))))
        (struct-set! res 'week-day (date-week-day tmp))
        (struct-set! res 'year-day (date-year-day tmp))
        (struct-set! res 'dst      (date-dst tmp))
        (struct-set! res 'tz       offset)
        res))))

#|
<doc EXT date?
 * (date? obj)
 *
 * Return `#t` if |obj| is a date, and otherwise returns `#f`.
doc>
|#
(define (date? obj)
  (and (struct? obj) (eq? (struct-type obj) %date)))

(define (time-zone-name date)
  (let ((offset (date-tz date)))
    (if (zero? offset)
        "Z"
        (let* ((hours   (abs (quotient  offset 3600)))
               (minutes (abs (quotient (remainder offset 3600) 60)))
               (signal  (if (negative? offset) #\- #\+))
               (str     (format #f "~a~2f:~2f" signal hours minutes)))
          (string-map (lambda (x) (if (eq? x #\space) #\0 x)) str)))))

;;;
;;; DATE <-> TIME CONVERSION
;;;

#|
<doc EXT seconds->date
 * (seconds->date n)
 *
 * Convert the date |n| expressed as a number of seconds since the _Epoch_,
 * 1970-01-01 00:00:00 +0000 (UTC) into a date.
 * |n| can be an exact integer or an inexact real.
 *
 * This is equivalent to converting time-UTC to date.
 * @lisp
 * (seconds->date 1351216417)           => #[date 2012-10-26 1:53:37]
 * @end lisp
doc>
|#
(define (seconds->date s)
  (%seconds->date (if (real? s) (inexact->exact (round s)) s)))

;; ======================================================================
;;      date writer
;; ======================================================================
(struct-type-change-writer!
   %date
   (lambda (s port)
     (format port "#[date ~A-~A-~A ~A:~A:~A]"
             (struct-ref s 'year) (struct-ref s 'month) (struct-ref s 'day)
             (struct-ref s 'hour) (struct-ref s 'minute) (struct-ref s 'second))))


#|
<doc EXT date-nanosecond
 * (date-nanosecond d)
 *
 * Return the nanosecond of date |d|.
doc>
<doc EXT date-second
 * (date-second d)
 *
 * Return the second of date |d|, in the range 0 to 59.
doc>
<doc EXT date-minute
 * (date-minute d)
 *
 * Return the minute of date |d|, in the range 0 to 59.
doc>
<doc EXT date-hour
 * (date-hour d)
 *
 * Return the hour of date |d|, in the range 0 to 23.
doc>
<doc EXT date-day
 * (date-day d)
 *
 * Return the day of date |d|, in the range 1 to 31
doc>
<doc EXT date-month
 * (date-month d)
 *
 * Return the month of date |d|, in the range 1 to 12
doc>
<doc EXT date-year
 * (date-year d)
 *
 * Return the year of date |d|.
doc>
<doc EXT date-week-day
 * (date-week-day d)
 *
 * Return the week day of date |d|, in the range 0 to 6 (0 is Sunday).
doc>
<doc EXT date-year-day
 * (date-year-day d)
 *
 * Return the the number of days since January 1 of date |d|, in the range
 * 1 to 366.
doc>
<doc EXT date-dst
 * (date-dst d)
 *
 * Return an indication about daylight saving adjustment of date |d|:
 *
 * - 0 if no daylight saving adjustment
 * - 1 if daylight saving adjustment
 * - -1 if the information is not available
doc>
<doc EXT date-tz
 * (date-tz d)
 *
 * Return the time zone of date |d|.
doc>
|#
(define (date-nanosecond d)     (%fast-struct-ref d %date 'date-nanosecond 0))
(define (date-second d)         (%fast-struct-ref d %date 'date-second 1))
(define (date-minute d)         (%fast-struct-ref d %date 'date-minute 2))
(define (date-hour d)           (%fast-struct-ref d %date 'date-hour 3))

(define (date-day d)            (%fast-struct-ref d %date 'date-day 4))
(define (date-month d)          (%fast-struct-ref d %date 'date-month 5))
(define (date-year d)           (%fast-struct-ref d %date 'date-year 6))

(define (date-week-day d)       (%fast-struct-ref d %date 'date-week-day 7))
(define (date-year-day d)       (%fast-struct-ref d %date 'date-year-day 8))

(define (date-dst d)            (%fast-struct-ref d %date 'date-dst 9))
(define (date-tz d)             (%fast-struct-ref d %date 'date-tz 10))


#|
<doc EXT seconds->list
 * (seconds->list sec)
 *
 * Returns a keyword list for the date given by |sec| (a date based on the
 * Epoch). The keyed values returned are
 *
 * - nanosecond : 0 to 999999
 * - second : 0 to 59 (but can be up to 61 to allow for leap seconds)
 * - minute : 0 to 59
 * - hour : 0 to 23
 * - day : 1 to 31
 * - month : 1 to 12
 * - year : e.g., 2002
 * - week-day : 0 (Sunday) to 6 (Saturday)
 * - year-day : 0 to 365 (365 in leap years)
 * - dst : indication about daylight savings time
 *   (see _<<datedst, primitive `date-dst`>>_).
 * - tz : the difference between Coordinated Universal Time
 *   (UTC) and local standard time in seconds.])
 *
 * @lisp
 * (seconds->list (current-second))
 *        => (#:nanosecond 182726 #:second 21 #:minute 35 #:hour 20 #:day 10 #:month 1
 *            #:year 2022 #:week-day 1 #:year-day 10 #:dst 0 #:tz -3600)
 * @end lisp
doc>
|#
(define (seconds->list sec)
  (apply append (map (lambda (x)
                       (list (make-keyword (car x)) (cdr x)))
                     (struct->list (seconds->date sec)))))


#|
<doc EXT current-date
 * (current-date)
 *
 * Returns the current system date.
doc>
|#
(define (current-date)
  (seconds->date (current-second)))

#|
<doc EXT seconds->string
 * (seconds->string format n)
 *
 * Convert a date expressed in seconds using the string |format| as a
 * specification. Conventions for |format| are given below:
 *
 *  - *~~* a literal ~
 *  - *~a* locale's abbreviated weekday name (Sun...Sat)
 *  - *~A* locale's full weekday name (Sunday...Saturday)
 *  - *~b* locale's abbreviate month name (Jan...Dec)
 *  - *~B* locale's full month day (January...December)
 *  - *~c* locale's date and time
 *         (e.g., ,(code "Fri Jul 14 20:28:42-0400 2000"))
 *  - *~d* day of month, zero padded (01...31)
 *  - *~D* date (mm/dd/yy)
 *  - *~e* day of month, blank padded ( 1...31)
 *  - *~f* seconds+fractional seconds, using locale's
 *         decimal separator (e.g. 5.2).
 *  - *~h* same as ~b
 *  - *~H* hour, zero padded, 24-hour clock (00...23)
 *  - *~I* hour, zero padded, 12-hour clock (01...12)
 *  - *~j* day of year, zero padded
 *  - *~k* hour, blank padded, 24-hour clock (00...23)
 *  - *~l* hour, blank padded, 12-hour clock (01...12)
 *  - *~m* month, zero padded (01...12)
 *  - *~M* minute, zero padded (00...59)
 *  - *~n* new line
 *  - *~p* locale's AM or PM
 *  - *~r* time, 12 hour clock, same as +"~I:~M:+~S ~p"
 *  - *~s* number of full seconds since _the epoch_ (in UTC)
 *  - *~S* second, zero padded (00...61)
 *  - *~t* horizontal tab
 *  - *~T* time, 24 hour clock, same as +"~H:~M:~S"+
 *  - *~U* week number of year with Sunday as first day of week
 *         (00...53)
 *  - *~V* weekISO 8601:1988 week number of year (01...53)
 *         (week 1 is the first week that has at least 4 days in
 *         the current year, and  with  Monday  as  the first day
*          of the week)
 *  - *~w* day of week (1...7, 1 is Monday)
 *  - *~W* week number of year with Monday as first day of week
 *         (01...52)
 *  - *~x* week number of year with Monday as first day of week
 *         (00...53)
 *  - *~X* locale's date representation, for example: "07/31/00"
 *  - *~y* last two digits of year (00...99)
 *  - *~Y* year
 *  - *~z* time zone in RFC-822 style
 *  - *~Z* symbol time zone

doc>
|#
(define (seconds->string format seconds)
  (unless (string? format)
    (error 'seconds->string "bad string ~S" format))
  ;; Convert the format string for C since conventions are different
  (let ((len (string-length format))
        (out (open-output-string))
        (sec (if (real? seconds) (inexact->exact (round seconds)) seconds)))
    (let Loop ((i 0))
      (when (< i len)
        (let ((cur-char (string-ref format i)))
          (case cur-char
            ((#\%) ;; "%" ==> "%%"
             (display "%%" out) (Loop (+ i 1)))
            ((#\~) (if (and (< i (- len 1)) (eq? (string-ref format (+ i 1)) #\~))
                       (begin
                         ;; "~~" => "~"
                         (display #\~ out)
                         (Loop (+ i 2)))
                       (begin
                         ;; "~c" => "%c" where c is not a %
                         (display #\% out)
                         (Loop (+ i 1)))))
            (else (display cur-char out)
                  (Loop (+ i 1)))))))
    ;; String is converted in the "OUT" string port
    (%seconds->string (get-output-string out) sec)))

#|
<doc EXT date->string
 * (date->string d)
 * (date->string d format)
 *
 * Convert the date |d| using the string |format| as a
 * specification. Conventions for format are the same as the one
 * of _<<seconds2string, primitive `seconds->string`>>_.
 * If |format| is omitted, it defaults to |"~c"|.
doc>
|#
(define (date->string date :optional (format "~c"))
  (unless (string? format)
    (error 'date->string "bad string ~S" format))

  (seconds->string format (date->seconds date)))
