srfi-19.scm

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

;;; srfi-19.scm --- Time/Date Library

;; 	Copyright (C) 2001, 2002 Free Software Foundation, Inc.
;;
;; 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, 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 software; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;; Boston, MA 02111-1307 USA
;;
;; As a special exception, the Free Software Foundation gives permission
;; for additional uses of the text contained in its release of GUILE.
;;
;; The exception is that, if you link the GUILE library with other files
;; to produce an executable, this does not by itself cause the
;; resulting executable to be covered by the GNU General Public License.
;; Your use of that executable is in no way restricted on account of
;; linking the GUILE library code into it.
;;
;; This exception does not however invalidate any other reasons why
;; the executable file might be covered by the GNU General Public License.
;;
;; This exception applies only to the code released by the
;; Free Software Foundation under the name GUILE.  If you copy
;; code from other Free Software Foundation releases into a copy of
;; GUILE, as the General Public License permits, the exception does
;; not apply to the code that you add in this way.  To avoid misleading
;; anyone as to the status of such modified files, you must delete
;; this exception notice from them.
;;
;; If you write modifications of your own for GUILE, it is your choice
;; whether to permit this exception to apply to your modifications.
;; If you do not wish that, delete this exception notice.

;;; Author: Rob Browning <[e-mail]>
;;;         Originally from SRFI reference implementation by Will Fitzgerald.

;;; Commentary:

;; This module is fully documented in the Guile Reference Manual.

;;; Code:

;; FIXME: I haven't checked a decent amount of this code for potential
;; performance improvements, but I suspect that there may be some
;; substantial ones to be realized, esp. in the later "parsing" half
;; of the file, by rewriting the code with use of more Guile native
;; functions that do more work in a "chunk".
;;
;; FIXME: mkoeppe: Time zones are treated a little simplistic in
;; SRFI-19; they are only a numeric offset.  Thus, printing time zones
;; (PRIV:LOCALE-PRINT-TIME-ZONE) can't be implemented sensibly.  The
;; functions taking an optional TZ-OFFSET should be extended to take a
;; symbolic time-zone (like "CET"); this string should be stored in
;; the DATE structure.

(define-module (srfi srfi-19)
  :use-module (srfi srfi-6)
  :use-module (srfi srfi-8)
  :use-module (srfi srfi-9))

(begin-deprecated
 ;; Prevent `export' from re-exporting core bindings.  This behaviour
 ;; of `export' is deprecated and will disappear in one of the next
 ;; releases.
 (define current-time #f))

(export ;; Constants
           time-duration
           time-monotonic
           time-process
           time-tai
           time-thread
           time-utc
           ;; Current time and clock resolution
           current-date
           current-julian-day
           current-modified-julian-day
           current-time
           time-resolution
           ;; Time object and accessors
           make-time
           time?
           time-type
           time-nanosecond
           time-second
           set-time-type!
           set-time-nanosecond!
           set-time-second!
           copy-time
           ;; Time comparison procedures
           time<=?
           time<?
           time=?
           time>=?
           time>?
           ;; Time arithmetic procedures
           time-difference
           time-difference!
           add-duration
           add-duration!
           subtract-duration
           subtract-duration!
           ;; Date object and accessors
           make-date
           date?
           date-nanosecond
           date-second
           date-minute
           date-hour
           date-day
           date-month
           date-year
           date-zone-offset
           date-year-day
           date-week-day
           date-week-number
           ;; Time/Date/Julian Day/Modified Julian Day converters
           date->julian-day
           date->modified-julian-day
           date->time-monotonic
           date->time-tai
           date->time-utc
           julian-day->date
           julian-day->time-monotonic
           julian-day->time-tai
           julian-day->time-utc
           modified-julian-day->date
           modified-julian-day->time-monotonic
           modified-julian-day->time-tai
           modified-julian-day->time-utc
           time-monotonic->date
           time-monotonic->time-tai
           time-monotonic->time-tai!
           time-monotonic->time-utc
           time-monotonic->time-utc!
           time-tai->date
           time-tai->julian-day
           time-tai->modified-julian-day
           time-tai->time-monotonic
           time-tai->time-monotonic!
           time-tai->time-utc
           time-tai->time-utc!
           time-utc->date
           time-utc->julian-day
           time-utc->modified-julian-day
           time-utc->time-monotonic
           time-utc->time-monotonic!
           time-utc->time-tai
           time-utc->time-tai!
           ;; Date to string/string to date converters.
           date->string
           string->date)

(cond-expand-provide (current-module) '(srfi-19))

(define time-tai 'time-tai)
(define time-utc 'time-utc)
(define time-monotonic 'time-monotonic)
(define time-thread 'time-thread)
(define time-process 'time-process)
(define time-duration 'time-duration)

;; FIXME: do we want to add gc time?
;; (define time-gc 'time-gc)

;;-- LOCALE dependent constants

(define priv:locale-number-separator ".")

(define priv:locale-abbr-weekday-vector
  (vector "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat"))

(define priv:locale-long-weekday-vector
  (vector
   "Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"))

;; note empty string in 0th place.
(define priv:locale-abbr-month-vector
  (vector ""
          "Jan"
          "Feb"
          "Mar"
          "Apr"
          "May"
          "Jun"
          "Jul"
          "Aug"
          "Sep"
          "Oct"
          "Nov"
          "Dec"))

(define priv:locale-long-month-vector
  (vector ""
          "January"
          "February"
          "March"
          "April"
          "May"
          "June"
          "July"
          "August"
          "September"
          "October"
          "November"
          "December"))

(define priv:locale-pm "PM")
(define priv:locale-am "AM")

;; See date->string
(define priv:locale-date-time-format "~a ~b ~d ~H:~M:~S~z ~Y")
(define priv:locale-short-date-format "~m/~d/~y")
(define priv:locale-time-format "~H:~M:~S")
(define priv:iso-8601-date-time-format "~Y-~m-~dT~H:~M:~S~z")

;;-- Miscellaneous Constants.
;;-- only the priv:tai-epoch-in-jd might need changing if
;;   a different epoch is used.

(define priv:nano 1000000000)           ; nanoseconds in a second
(define priv:sid  86400)                ; seconds in a day
(define priv:sihd 43200)                ; seconds in a half day
(define priv:tai-epoch-in-jd 4881175/2) ; julian day number for 'the epoch'

;; FIXME: should this be something other than misc-error?
(define (priv:time-error caller type value)
  (if value
      (throw 'misc-error caller "TIME-ERROR type ~A: ~S" (list type value) #f)
      (throw 'misc-error caller "TIME-ERROR type ~A" (list type) #f)))

;; A table of leap seconds
;; See ftp://maia.usno.navy.mil/ser7/tai-utc.dat
;; and update as necessary.
;; this procedures reads the file in the abover
;; format and creates the leap second table
;; it also calls the almost standard, but not R5 procedures read-line
;; & open-input-string
;; ie (set! priv:leap-second-table (priv:read-tai-utc-date "tai-utc.dat"))

(define (priv:read-tai-utc-data filename)
  (define (convert-jd jd)
    (* (- (inexact->exact jd) priv:tai-epoch-in-jd) priv:sid))
  (define (convert-sec sec)
    (inexact->exact sec))
  (let ((port (open-input-file filename))
        (table '()))
    (let loop ((line (read-line port)))
      (if (not (eq? line eof))
          (begin
            (let* ((data (read (open-input-string
                                (string-append "(" line ")"))))
                   (year (car data))
                   (jd   (cadddr (cdr data)))
                   (secs (cadddr (cdddr data))))
              (if (>= year 1972)
                  (set! table (cons
                               (cons (convert-jd jd) (convert-sec secs))
                               table)))
              (loop (read-line port))))))
    table))

;; each entry is (tai seconds since epoch . # seconds to subtract for utc)
;; note they go higher to lower, and end in 1972.
(define priv:leap-second-table
  '((915148800 . 32)
    (867715200 . 31)
    (820454400 . 30)
    (773020800 . 29)
    (741484800 . 28)
    (709948800 . 27)
    (662688000 . 26)
    (631152000 . 25)
    (567993600 . 24)
    (489024000 . 23)
    (425865600 . 22)
    (394329600 . 21)
    (362793600 . 20)
    (315532800 . 19)
    (283996800 . 18)
    (252460800 . 17)
    (220924800 . 16)
    (189302400 . 15)
    (157766400 . 14)
    (126230400 . 13)
    (94694400  . 12)
    (78796800  . 11)
    (63072000  . 10)))

(define (read-leap-second-table filename)
  (set! priv:leap-second-table (priv:read-tai-utc-data filename))
  (values))


(define (priv: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 priv:sid)) 0
        (lsd  priv:leap-second-table))))


;;; the TIME structure; creates the accessors, too.

(define-record-type time
  (make-time-unnormalized type nanosecond second)
  time?
  (type time-type set-time-type!)
  (nanosecond time-nanosecond set-time-nanosecond!)
  (second time-second set-time-second!))

(define (copy-time time)
  (make-time (time-type time) (time-nanosecond time) (time-second time)))

(define (priv:split-real r)
  (if (integer? r)
      (values (inexact->exact r) 0)
      (let ((l (truncate r)))
        (values (inexact->exact l) (- r l)))))

(define (priv:time-normalize! t)
  (if (>= (abs (time-nanosecond t)) 1000000000)
      (receive (int frac)
	  (priv:split-real (time-nanosecond t))
	(set-time-second! t (+ (time-second t)
			       (quotient int 1000000000)))
	(set-time-nanosecond! t (+ (remainder int 1000000000)
				   frac))))
  (if (and (positive? (time-second t))
           (negative? (time-nanosecond t)))
      (begin
        (set-time-second! t (- (time-second t) 1))
        (set-time-nanosecond! t (+ 1000000000 (time-nanosecond t))))
      (if (and (negative? (time-second t))
               (positive? (time-nanosecond t)))
          (begin
            (set-time-second! t (+ (time-second t) 1))
            (set-time-nanosecond! t (+ 1000000000 (time-nanosecond t))))))
  t)

(define (make-time type nanosecond second)
  (priv:time-normalize! (make-time-unnormalized type nanosecond second)))

;; Helpers
;; FIXME: finish this and publish it?
(define (date->broken-down-time date)
  (let ((result (mktime 0)))
    ;; FIXME: What should we do about leap-seconds which may overflow
    ;; set-tm:sec?
    (set-tm:sec result (date-second date))
    (set-tm:min result (date-minute date))
    (set-tm:hour result (date-hour date))
    ;; FIXME: SRFI day ranges from 0-31.  (not compatible with set-tm:mday).
    (set-tm:mday result (date-day date))
    (set-tm:month result (- (date-month date) 1))
    ;; FIXME: need to signal error on range violation.
    (set-tm:year result (+ 1900 (date-year date)))
    (set-tm:isdst result -1)
    (set-tm:gmtoff result (- (date-zone-offset date)))
    result))

;;; current-time

;;; specific time getters.

(define (priv:current-time-utc)
  ;; Resolution is microseconds.
  (let ((tod (gettimeofday)))
    (make-time time-utc (* (cdr tod) 1000) (car tod))))

(define (priv:current-time-tai)
  ;; Resolution is microseconds.
  (let* ((tod (gettimeofday))
         (sec (car tod))
         (usec (cdr tod)))
    (make-time time-tai
               (* usec 1000)
               (+ (car tod) (priv:leap-second-delta sec)))))

;;(define (priv:current-time-ms-time time-type proc)