srfi-19.scm

MSYS在windows下模拟了一个类unix的终端

	 (jdays-1/2 (inexact->exact (- jdays 1/2))))
    (make-time
     time-utc
     (date-nanosecond date)
     (+ (* jdays-1/2 24 60 60)
        (* (date-hour date) 60 60)
        (* (date-minute date) 60)
        (date-second date)
	(- (date-zone-offset date))))))

(define (date->time-tai date)
  (time-utc->time-tai! (date->time-utc date)))

(define (date->time-monotonic date)
  (time-utc->time-monotonic! (date->time-utc date)))

(define (priv:leap-year? year)
  (or (= (modulo year 400) 0)
      (and (= (modulo year 4) 0) (not (= (modulo year 100) 0)))))

(define (leap-year? date)
  (priv:leap-year? (date-year date)))

;; Map 1-based month number M to number of days in the year before the
;; start of month M (in a non-leap year).
(define priv:month-assoc '((1 . 0)   (2 . 31)   (3 . 59)   (4 . 90)
			   (5 . 120) (6 . 151)  (7 . 181)  (8 . 212)
			   (9 . 243) (10 . 273) (11 . 304) (12 . 334)))

(define (priv:year-day day month year)
  (let ((days-pr (assoc month priv:month-assoc)))
    (if (not days-pr)
        (priv:error 'date-year-day 'invalid-month-specification month))
    (if (and (priv:leap-year? year) (> month 2))
        (+ day (cdr days-pr) 1)
        (+ day (cdr days-pr)))))

(define (date-year-day date)
  (priv:year-day (date-day date) (date-month date) (date-year date)))

;; from calendar faq
(define (priv:week-day day month year)
  (let* ((a (quotient (- 14 month) 12))
         (y (- year a))
         (m (+ month (* 12 a) -2)))
    (modulo (+ day
               y
               (quotient y 4)
               (- (quotient y 100))
               (quotient y 400)
               (quotient (* 31 m) 12))
            7)))

(define (date-week-day date)
  (priv:week-day (date-day date) (date-month date) (date-year date)))

(define (priv:days-before-first-week date day-of-week-starting-week)
  (let* ((first-day (make-date 0 0 0 0
                               1
                               1
                               (date-year date)
                               #f))
         (fdweek-day (date-week-day first-day)))
    (modulo (- day-of-week-starting-week fdweek-day)
            7)))

(define (date-week-number date day-of-week-starting-week)
  (quotient (- (date-year-day date)
               (priv:days-before-first-week  date day-of-week-starting-week))
            7))

(define (current-date . tz-offset)
  (let ((time (current-time time-utc)))
    (time-utc->date
     time
     (if (null? tz-offset)
	 (priv:local-tz-offset time)
	 (car tz-offset)))))

;; given a 'two digit' number, find the year within 50 years +/-
(define (priv:natural-year n)
  (let* ((current-year (date-year (current-date)))
         (current-century (* (quotient current-year 100) 100)))
    (cond
     ((>= n 100) n)
     ((<  n 0) n)
     ((<=  (- (+ current-century n) current-year) 50) (+ current-century n))
     (else (+ (- current-century 100) n)))))

(define (date->julian-day date)
  (let ((nanosecond (date-nanosecond date))
        (second (date-second date))
        (minute (date-minute date))
        (hour (date-hour date))
        (day (date-day date))
        (month (date-month date))
        (year (date-year date)))
    (+ (priv:encode-julian-day-number day month year)
       (- 1/2)
       (+ (/ (+ (* hour 60 60)
                (* minute 60)
                second
                (/ nanosecond priv:nano))
             priv:sid)))))

(define (date->modified-julian-day date)
  (- (date->julian-day date)
     4800001/2))

(define (time-utc->julian-day time)
  (if (not (eq? (time-type time) time-utc))
      (priv:time-error 'time->date 'incompatible-time-types  time))
  (+ (/ (+ (time-second time) (/ (time-nanosecond time) priv:nano))
        priv:sid)
     priv:tai-epoch-in-jd))

(define (time-utc->modified-julian-day time)
  (- (time-utc->julian-day time)
     4800001/2))

(define (time-tai->julian-day time)
  (if (not (eq? (time-type time) time-tai))
      (priv:time-error 'time->date 'incompatible-time-types  time))
  (+ (/ (+ (- (time-second time)
              (priv:leap-second-delta (time-second time)))
           (/ (time-nanosecond time) priv:nano))
        priv:sid)
     priv:tai-epoch-in-jd))

(define (time-tai->modified-julian-day time)
  (- (time-tai->julian-day time)
     4800001/2))

;; this is the same as time-tai->julian-day
(define (time-monotonic->julian-day time)
  (if (not (eq? (time-type time) time-monotonic))
      (priv:time-error 'time->date 'incompatible-time-types  time))
  (+ (/ (+ (- (time-second time)
              (priv:leap-second-delta (time-second time)))
           (/ (time-nanosecond time) priv:nano))
        priv:sid)
     priv:tai-epoch-in-jd))

(define (time-monotonic->modified-julian-day time)
  (- (time-monotonic->julian-day time)
     4800001/2))

(define (julian-day->time-utc jdn)
  (let ((secs (* priv:sid (- jdn priv:tai-epoch-in-jd))))
    (receive (seconds parts)
	(priv:split-real secs)
      (make-time time-utc
		 (* parts priv:nano)
		 seconds))))

(define (julian-day->time-tai jdn)
  (time-utc->time-tai! (julian-day->time-utc jdn)))

(define (julian-day->time-monotonic jdn)
  (time-utc->time-monotonic! (julian-day->time-utc jdn)))

(define (julian-day->date jdn . tz-offset)
  (let* ((time (julian-day->time-utc jdn))
	 (offset (if (null? tz-offset)
		     (priv:local-tz-offset time)
		     (car tz-offset))))
    (time-utc->date time offset)))

(define (modified-julian-day->date jdn . tz-offset)
  (apply julian-day->date (+ jdn 4800001/2)
	 tz-offset))

(define (modified-julian-day->time-utc jdn)
  (julian-day->time-utc (+ jdn 4800001/2)))

(define (modified-julian-day->time-tai jdn)
  (julian-day->time-tai (+ jdn 4800001/2)))

(define (modified-julian-day->time-monotonic jdn)
  (julian-day->time-monotonic (+ jdn 4800001/2)))

(define (current-julian-day)
  (time-utc->julian-day (current-time time-utc)))

(define (current-modified-julian-day)
  (time-utc->modified-julian-day (current-time time-utc)))

;; returns a string rep. of number N, of minimum LENGTH, padded with
;; character PAD-WITH. If PAD-WITH is #f, no padding is done, and it's
;; as if number->string was used.  if string is longer than or equal
;; in length to LENGTH, it's as if number->string was used.

(define (priv:padding n pad-with length)
  (let* ((str (number->string n))
         (str-len (string-length str)))
    (if (or (>= str-len length)
            (not pad-with))
        str
        (string-append (make-string (- length str-len) pad-with) str))))

(define (priv:last-n-digits i n)
  (abs (remainder i (expt 10 n))))

(define (priv:locale-abbr-weekday n)
  (vector-ref priv:locale-abbr-weekday-vector n))

(define (priv:locale-long-weekday n)
  (vector-ref priv:locale-long-weekday-vector n))

(define (priv:locale-abbr-month n)
  (vector-ref priv:locale-abbr-month-vector n))

(define (priv:locale-long-month n)
  (vector-ref priv:locale-long-month-vector n))

(define (priv:vector-find needle haystack comparator)
  (let ((len (vector-length haystack)))
    (define (priv:vector-find-int index)
      (cond
       ((>= index len) #f)
       ((comparator needle (vector-ref haystack index)) index)
       (else (priv:vector-find-int (+ index 1)))))
    (priv:vector-find-int 0)))

(define (priv:locale-abbr-weekday->index string)
  (priv:vector-find string priv:locale-abbr-weekday-vector string=?))

(define (priv:locale-long-weekday->index string)
  (priv:vector-find string priv:locale-long-weekday-vector string=?))

(define (priv:locale-abbr-month->index string)
  (priv:vector-find string priv:locale-abbr-month-vector string=?))

(define (priv:locale-long-month->index string)
  (priv:vector-find string priv:locale-long-month-vector string=?))


;; FIXME: mkoeppe: Put a symbolic time zone in the date structs.
;; Print it here instead of the numerical offset if available.
(define (priv:locale-print-time-zone date port)
  (priv:tz-printer (date-zone-offset date) port))

;; FIXME: we should use strftime to determine this dynamically if possible.
;; Again, locale specific.
(define (priv:locale-am/pm hr)
  (if (> hr 11) priv:locale-pm priv:locale-am))

(define (priv:tz-printer offset port)
  (cond
   ((= offset 0) (display "Z" port))
   ((negative? offset) (display "-" port))
   (else (display "+" port)))
  (if (not (= offset 0))
      (let ((hours   (abs (quotient offset (* 60 60))))
            (minutes (abs (quotient (remainder offset (* 60 60)) 60))))
        (display (priv:padding hours #\0 2) port)
        (display (priv:padding minutes #\0 2) port))))

;; A table of output formatting directives.
;; the first time is the format char.
;; the second is a procedure that takes the date, a padding character
;; (which might be #f), and the output port.
;;
(define priv:directives
  (list
   (cons #\~ (lambda (date pad-with port)
               (display #\~ port)))
   (cons #\a (lambda (date pad-with port)
               (display (priv:locale-abbr-weekday (date-week-day date))
                        port)))
   (cons #\A (lambda (date pad-with port)
               (display (priv:locale-long-weekday (date-week-day date))
                        port)))
   (cons #\b (lambda (date pad-with port)
               (display (priv:locale-abbr-month (date-month date))
                        port)))
   (cons #\B (lambda (date pad-with port)
               (display (priv:locale-long-month (date-month date))
                        port)))
   (cons #\c (lambda (date pad-with port)
               (display (date->string date priv:locale-date-time-format) port)))
   (cons #\d (lambda (date pad-with port)
               (display (priv:padding (date-day date)
                                      #\0 2)
                        port)))
   (cons #\D (lambda (date pad-with port)
               (display (date->string date "~m/~d/~y") port)))
   (cons #\e (lambda (date pad-with port)
               (display (priv:padding (date-day date)
                                      #\Space 2)
                        port)))
   (cons #\f (lambda (date pad-with port)
               (if (> (date-nanosecond date)
                      priv:nano)
                   (display (priv:padding (+ (date-second date) 1)
                                          pad-with 2)
                            port)
                   (display (priv:padding (date-second date)
                                          pad-with 2)
                            port))
               (receive (i f)
                        (priv:split-real (/
                                          (date-nanosecond date)
                                          priv:nano 1.0))
                        (let* ((ns (number->string f))
                               (le (string-length ns)))
                          (if (> le 2)
                              (begin
                                (display priv:locale-number-separator port)
                                (display (substring ns 2 le) port)))))))
   (cons #\h (lambda (date pad-with port)
               (display (date->string date "~b") port)))
   (cons #\H (lambda (date pad-with port)
               (display (priv:padding (date-hour date)
                                      pad-with 2)
                        port)))
   (cons #\I (lambda (date pad-with port)
               (let ((hr (date-hour date)))
                 (if (> hr 12)
                     (display (priv:padding (- hr 12)
                                            pad-with 2)
                              port)
                     (display (priv:padding hr
                                            pad-with 2)
                              port)))))
   (cons #\j (lambda (date pad-with port)
               (display (priv:padding (date-year-day date)
                                      pad-with 3)
                        port)))
   (cons #\k (lambda (date pad-with port)
               (display (priv:padding (date-hour date)
                                      #\Space 2)
                        port)))
   (cons #\l (lambda (date pad-with port)
               (let ((hr (if (> (date-hour date) 12)
                             (- (date-hour date) 12) (date-hour date))))
                 (display (priv:padding hr  #\Space 2)
                          port))))
   (cons #\m (lambda (date pad-with port)
               (display (priv:padding (date-month date)
                                      pad-with 2)
                        port)))
   (cons #\M (lambda (date pad-with port)
               (display (priv:padding (date-minute date)
                                      pad-with 2)
                        port)))
   (cons #\n (lambda (date pad-with port)
               (newline port)))
   (cons #\N (lambda (date pad-with port)
               (display (priv:padding (date-nanosecond date)
                                      pad-with 7)
                        port)))
   (cons #\p (lambda (date pad-with port)
               (display (priv:locale-am/pm (date-hour date)) port)))
   (cons #\r (lambda (date pad-with port)
               (display (date->string date "~I:~M:~S ~p") port)))
   (cons #\s (lambda (date pad-with port)
               (display (time-second (date->time-utc date)) port)))
   (cons #\S (lambda (date pad-with port)
               (if (> (date-nanosecond date)
                      priv:nano)
                   (display (priv:padding (+ (date-second date) 1)
                                          pad-with 2)
                            port)
                   (display (priv:padding (date-second date)
                                          pad-with 2)
                            port))))
   (cons #\t (lambda (date pad-with port)
               (display #\Tab port)))
   (cons #\T (lambda (date pad-with port)
               (display (date->string date "~H:~M:~S") port)))
   (cons #\U (lambda (date pad-with port)
               (if (> (priv:days-before-first-week date 0) 0)
                   (display (priv:padding (+ (date-week-number date 0) 1)
                                          #\0 2) port)
                   (display (priv:padding (date-week-number date 0)
                                          #\0 2) port))))
   (cons #\V (lambda (date pad-with port)
               (display (priv:padding (date-week-number date 1)
                                      #\0 2) port)))
   (cons #\w (lambda (date pad-with port)
               (display (date-week-day date) port)))
   (cons #\x (lambda (date pad-with port)
               (display (date->string date priv:locale-short-date-format) port)))
   (cons #\X (lambda (date pad-with port)
               (display (date->string date priv:locale-time-format) port)))
   (cons #\W (lambda (date pad-with port)
               (if (> (priv:days-before-first-week date 1) 0)
                   (display (priv:padding (+ (date-week-number date 1) 1)
                                          #\0 2) port)
                   (display (priv:padding (date-week-number date 1)