srfi-19.scm

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

;;  (let ((current-ms (proc)))
;;    (make-time time-type
;;               (quotient current-ms 10000)
;;       (* (remainder current-ms 1000) 10000))))

;; -- we define it to be the same as TAI.
;;    A different implemation of current-time-montonic
;;    will require rewriting all of the time-monotonic converters,
;;    of course.

(define (priv:current-time-monotonic)
  ;; Resolution is microseconds.
  (priv:current-time-tai))

(define (priv:current-time-thread)
  (priv:time-error 'current-time 'unsupported-clock-type 'time-thread))

(define priv:ns-per-guile-tick (/ 1000000000 internal-time-units-per-second))

(define (priv:current-time-process)
  (let ((run-time (get-internal-run-time)))
    (make-time
     time-process
     (quotient run-time internal-time-units-per-second)
     (* (remainder run-time internal-time-units-per-second)
        priv:ns-per-guile-tick))))

(define (priv:current-time-process)
  (let ((run-time (get-internal-run-time)))
    (list
     'time-process
     (* (remainder run-time internal-time-units-per-second)
        priv:ns-per-guile-tick)
     (quotient run-time internal-time-units-per-second))))

;;(define (priv:current-time-gc)
;;  (priv:current-time-ms-time time-gc current-gc-milliseconds))

(define (current-time . clock-type)
  (let ((clock-type (if (null? clock-type) time-utc (car clock-type))))
    (cond
     ((eq? clock-type time-tai) (priv:current-time-tai))
     ((eq? clock-type time-utc) (priv:current-time-utc))
     ((eq? clock-type time-monotonic) (priv:current-time-monotonic))
     ((eq? clock-type time-thread) (priv:current-time-thread))
     ((eq? clock-type time-process) (priv:current-time-process))
     ;;     ((eq? clock-type time-gc) (priv:current-time-gc))
     (else (priv:time-error 'current-time 'invalid-clock-type clock-type)))))

;; -- Time Resolution
;; This is the resolution of the clock in nanoseconds.
;; This will be implementation specific.

(define (time-resolution . clock-type)
  (let ((clock-type (if (null? clock-type) time-utc (car clock-type))))
    (case clock-type
      ((time-tai) 1000)
      ((time-utc) 1000)
      ((time-monotonic) 1000)
      ((time-process) priv:ns-per-guile-tick)
      ;;     ((eq? clock-type time-thread) 1000)
      ;;     ((eq? clock-type time-gc) 10000)
      (else (priv:time-error 'time-resolution 'invalid-clock-type clock-type)))))

;; -- Time comparisons

(define (time=? t1 t2)
  ;; Arrange tests for speed and presume that t1 and t2 are actually times.
  ;; also presume it will be rare to check two times of different types.
  (and (= (time-second t1) (time-second t2))
       (= (time-nanosecond t1) (time-nanosecond t2))
       (eq? (time-type t1) (time-type t2))))

(define (time>? t1 t2)
  (or (> (time-second t1) (time-second t2))
      (and (= (time-second t1) (time-second t2))
           (> (time-nanosecond t1) (time-nanosecond t2)))))

(define (time<? t1 t2)
  (or (< (time-second t1) (time-second t2))
      (and (= (time-second t1) (time-second t2))
           (< (time-nanosecond t1) (time-nanosecond t2)))))

(define (time>=? t1 t2)
  (or (> (time-second t1) (time-second t2))
      (and (= (time-second t1) (time-second t2))
           (>= (time-nanosecond t1) (time-nanosecond t2)))))

(define (time<=? t1 t2)
  (or (< (time-second t1) (time-second t2))
      (and (= (time-second t1) (time-second t2))
           (<= (time-nanosecond t1) (time-nanosecond t2)))))

;; -- Time arithmetic

(define (time-difference! time1 time2)
  (let ((sec-diff (- (time-second time1) (time-second time2)))
        (nsec-diff (- (time-nanosecond time1) (time-nanosecond time2))))
    (set-time-type! time1 time-duration)
    (set-time-second! time1 sec-diff)
    (set-time-nanosecond! time1 nsec-diff)
    (priv:time-normalize! time1)))

(define (time-difference time1 time2)
  (let ((result (copy-time time1)))
    (time-difference! result time2)))

(define (add-duration! t duration)
  (if (not (eq? (time-type duration) time-duration))
      (priv:time-error 'add-duration 'not-duration duration)
      (let ((sec-plus (+ (time-second t) (time-second duration)))
            (nsec-plus (+ (time-nanosecond t) (time-nanosecond duration))))
        (set-time-second! t sec-plus)
        (set-time-nanosecond! t nsec-plus)
        (priv:time-normalize! t))))

(define (add-duration t duration)
  (let ((result (copy-time t)))
    (add-duration! result duration)))

(define (subtract-duration! t duration)
  (if (not (eq? (time-type duration) time-duration))
      (priv:time-error 'add-duration 'not-duration duration)
      (let ((sec-minus  (- (time-second t) (time-second duration)))
            (nsec-minus (- (time-nanosecond t) (time-nanosecond duration))))
        (set-time-second! t sec-minus)
        (set-time-nanosecond! t nsec-minus)
        (priv:time-normalize! t))))

(define (subtract-duration time1 duration)
  (let ((result (copy-time time1)))
    (subtract-duration! result duration)))

;; -- Converters between types.

(define (priv:time-tai->time-utc! time-in time-out caller)
  (if (not (eq? (time-type time-in) time-tai))
      (priv: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)
                                    (priv:leap-second-delta
                                     (time-second time-in))))
  time-out)

(define (time-tai->time-utc time-in)
  (priv:time-tai->time-utc! time-in (make-time-unnormalized #f #f #f) 'time-tai->time-utc))


(define (time-tai->time-utc! time-in)
  (priv:time-tai->time-utc! time-in time-in 'time-tai->time-utc!))

(define (priv:time-utc->time-tai! time-in time-out caller)
  (if (not (eq? (time-type time-in) time-utc))
      (priv: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)
                                    (priv:leap-second-delta
                                     (time-second time-in))))
  time-out)

(define (time-utc->time-tai time-in)
  (priv:time-utc->time-tai! time-in (make-time-unnormalized #f #f #f) 'time-utc->time-tai))

(define (time-utc->time-tai! time-in)
  (priv:time-utc->time-tai! time-in time-in 'time-utc->time-tai!))

;; -- these depend on time-monotonic having the same definition as time-tai!
(define (time-monotonic->time-utc time-in)
  (if (not (eq? (time-type time-in) time-monotonic))
      (priv:time-error caller 'incompatible-time-types time-in))
  (let ((ntime (copy-time time-in)))
    (set-time-type! ntime time-tai)
    (priv:time-tai->time-utc! ntime ntime 'time-monotonic->time-utc)))

(define (time-monotonic->time-utc! time-in)
  (if (not (eq? (time-type time-in) time-monotonic))
      (priv:time-error caller 'incompatible-time-types time-in))
  (set-time-type! time-in time-tai)
  (priv:time-tai->time-utc! ntime ntime 'time-monotonic->time-utc))

(define (time-monotonic->time-tai time-in)
  (if (not (eq? (time-type time-in) time-monotonic))
      (priv:time-error caller 'incompatible-time-types time-in))
  (let ((ntime (copy-time time-in)))
    (set-time-type! ntime time-tai)
    ntime))

(define (time-monotonic->time-tai! time-in)
  (if (not (eq? (time-type time-in) time-monotonic))
      (priv:time-error caller 'incompatible-time-types time-in))
  (set-time-type! time-in time-tai)
  time-in)

(define (time-utc->time-monotonic time-in)
  (if (not (eq? (time-type time-in) time-utc))
      (priv:time-error caller 'incompatible-time-types time-in))
  (let ((ntime (priv:time-utc->time-tai! time-in (make-time-unnormalized #f #f #f)
                                         'time-utc->time-monotonic)))
    (set-time-type! ntime time-monotonic)
    ntime))

(define (time-utc->time-monotonic! time-in)
  (if (not (eq? (time-type time-in) time-utc))
      (priv:time-error caller 'incompatible-time-types time-in))
  (let ((ntime (priv:time-utc->time-tai! time-in time-in
                                         'time-utc->time-monotonic!)))
    (set-time-type! ntime time-monotonic)
    ntime))

(define (time-tai->time-monotonic time-in)
  (if (not (eq? (time-type time-in) time-tai))
      (priv:time-error caller 'incompatible-time-types time-in))
  (let ((ntime (copy-time time-in)))
    (set-time-type! ntime time-monotonic)
    ntime))

(define (time-tai->time-monotonic! time-in)
  (if (not (eq? (time-type time-in) time-tai))
      (priv:time-error caller 'incompatible-time-types time-in))
  (set-time-type! time-in time-monotonic)
  time-in)

;; -- Date Structures

;; FIXME: to be really safe, perhaps we should normalize the
;; seconds/nanoseconds/minutes coming in to make-date...

(define-record-type date
  (make-date nanosecond second minute
             hour day month
             year
             zone-offset)
  date?
  (nanosecond date-nanosecond set-date-nanosecond!)
  (second date-second set-date-second!)
  (minute date-minute set-date-minute!)
  (hour date-hour set-date-hour!)
  (day date-day set-date-day!)
  (month date-month set-date-month!)
  (year date-year set-date-year!)
  (zone-offset date-zone-offset set-date-zone-offset!))

;; gives the julian day which starts at noon.
(define (priv:encode-julian-day-number day month year)
  (let* ((a (quotient (- 14 month) 12))
         (y (- (+ year 4800) a (if (negative? year) -1  0)))
         (m (- (+ month (* 12 a)) 3)))
    (+ day
       (quotient (+ (* 153 m) 2) 5)
       (* 365 y)
       (quotient y 4)
       (- (quotient y 100))
       (quotient y 400)
       -32045)))

;; gives the seconds/date/month/year
(define (priv:decode-julian-day-number jdn)
  (let* ((days (inexact->exact (truncate jdn)))
         (a (+ days 32044))
         (b (quotient (+ (* 4 a) 3) 146097))
         (c (- a (quotient (* 146097 b) 4)))
         (d (quotient (+ (* 4 c) 3) 1461))
         (e (- c (quotient (* 1461 d) 4)))
         (m (quotient (+ (* 5 e) 2) 153))
         (y (+ (* 100 b) d -4800 (quotient m 10))))
    (values ; seconds date month year
     (* (- jdn days) priv:sid)
     (+ e (- (quotient (+ (* 153 m) 2) 5)) 1)
     (+ m 3 (* -12 (quotient m 10)))
     (if (>= 0 y) (- y 1) y))))

;; relies on the fact that we named our time zone accessor
;; differently from MzScheme's....
;; This should be written to be OS specific.

(define (priv:local-tz-offset utc-time)
  ;; SRFI uses seconds West, but guile (and libc) use seconds East.
  (- (tm:gmtoff (localtime (time-second utc-time)))))

;; special thing -- ignores nanos
(define (priv:time->julian-day-number seconds tz-offset)
  (+ (/ (+ seconds tz-offset priv:sihd)
        priv:sid)
     priv:tai-epoch-in-jd))

(define (priv:leap-second? second)
  (and (assoc second priv:leap-second-table) #t))

(define (time-utc->date time . tz-offset)
  (if (not (eq? (time-type time) time-utc))
      (priv:time-error 'time->date 'incompatible-time-types  time))
  (let* ((offset (if (null? tz-offset)
		     (priv:local-tz-offset time)
		     (car tz-offset)))
         (leap-second? (priv:leap-second? (+ offset (time-second time))))
         (jdn (priv:time->julian-day-number (if leap-second?
                                                (- (time-second time) 1)
                                                (time-second time))
                                            offset)))

    (call-with-values (lambda () (priv:decode-julian-day-number jdn))
      (lambda (secs date month year)
	;; secs is a real because jdn is a real in Guile;
	;; but it is conceptionally an integer.
        (let* ((int-secs (inexact->exact (round secs)))
               (hours    (quotient int-secs (* 60 60)))
               (rem      (remainder int-secs (* 60 60)))
               (minutes  (quotient rem 60))
               (seconds  (remainder rem 60)))
          (make-date (time-nanosecond time)
                     (if leap-second? (+ seconds 1) seconds)
                     minutes
                     hours
                     date
                     month
                     year
                     offset))))))

(define (time-tai->date time  . tz-offset)
  (if (not (eq? (time-type time) time-tai))
      (priv:time-error 'time->date 'incompatible-time-types  time))
  (let* ((offset (if (null? tz-offset)
		     (priv:local-tz-offset (time-tai->time-utc time))
		     (car tz-offset)))
         (seconds (- (time-second time)
                     (priv:leap-second-delta (time-second time))))
         (leap-second? (priv:leap-second? (+ offset seconds)))
         (jdn (priv:time->julian-day-number (if leap-second?
                                                (- seconds 1)
                                                seconds)
                                            offset)))
    (call-with-values (lambda () (priv:decode-julian-day-number jdn))
      (lambda (secs date month year)
	;; secs is a real because jdn is a real in Guile;
	;; but it is conceptionally an integer.
        ;; adjust for leap seconds if necessary ...
        (let* ((int-secs (inexact->exact (round secs)))
	       (hours    (quotient int-secs (* 60 60)))
               (rem      (remainder int-secs (* 60 60)))
               (minutes  (quotient rem 60))
               (seconds  (remainder rem 60)))
          (make-date (time-nanosecond time)
                     (if leap-second? (+ seconds 1) seconds)
                     minutes
                     hours
                     date
                     month
                     year
                     offset))))))

;; this is the same as time-tai->date.
(define (time-monotonic->date time . tz-offset)
  (if (not (eq? (time-type time) time-monotonic))
      (priv:time-error 'time->date 'incompatible-time-types  time))
  (let* ((offset (if (null? tz-offset)
		     (priv:local-tz-offset (time-monotonic->time-utc time))
		     (car tz-offset)))
         (seconds (- (time-second time)
                     (priv:leap-second-delta (time-second time))))
         (leap-second? (priv:leap-second? (+ offset seconds)))
         (jdn (priv:time->julian-day-number (if leap-second?
                                                (- seconds 1)
                                                seconds)
                                            offset)))
    (call-with-values (lambda () (priv:decode-julian-day-number jdn))
      (lambda (secs date month year)
	;; secs is a real because jdn is a real in Guile;
	;; but it is conceptionally an integer.
        ;; adjust for leap seconds if necessary ...
        (let* ((int-secs (inexact->exact (round secs)))
	       (hours    (quotient int-secs (* 60 60)))
               (rem      (remainder int-secs (* 60 60)))
               (minutes  (quotient rem 60))
               (seconds  (remainder rem 60)))
          (make-date (time-nanosecond time)
                     (if leap-second? (+ seconds 1) seconds)
                     minutes
                     hours
                     date
                     month
                     year
                     offset))))))

(define (date->time-utc date)
  (let* ((jdays (- (priv:encode-julian-day-number (date-day date)
                                                 (date-month date)
                                                 (date-year date))
		   priv:tai-epoch-in-jd))
	 ;; jdays is an integer plus 1/2,