bug fix: tm:get-time-of-day
svn: r5771
This commit is contained in:
Chongkai Zhu
parent
df611dbf1a
commit
c506af5c55
|
|
@ -293,8 +293,8 @@
|
||||||
;;
|
;;
|
||||||
|
|
||||||
(define (tm:get-time-of-day)
|
(define (tm:get-time-of-day)
|
||||||
(values (current-seconds)
|
(let* ((total-msecs (inexact->exact (floor (current-inexact-milliseconds)))))
|
||||||
(abs (remainder (current-milliseconds) 1000))))
|
(quotient/remainder total-msecs 1000)))
|
||||||
|
|
||||||
(define (tm:current-time-utc)
|
(define (tm:current-time-utc)
|
||||||
(receive (seconds ms) (tm:get-time-of-day)
|
(receive (seconds ms) (tm:get-time-of-day)
|
||||||
|
|
@ -338,13 +338,13 @@
|
||||||
(define (current-time . clock-type)
|
(define (current-time . clock-type)
|
||||||
(let ( (clock-type (:optional clock-type time-utc)) )
|
(let ( (clock-type (:optional clock-type time-utc)) )
|
||||||
(cond
|
(cond
|
||||||
((eq? clock-type time-tai) (tm:current-time-tai))
|
((eq? clock-type time-tai) (tm:current-time-tai))
|
||||||
((eq? clock-type time-utc) (tm:current-time-utc))
|
((eq? clock-type time-utc) (tm:current-time-utc))
|
||||||
((eq? clock-type time-monotonic) (tm:current-time-monotonic))
|
((eq? clock-type time-monotonic) (tm:current-time-monotonic))
|
||||||
((eq? clock-type time-thread) (tm:current-time-thread))
|
((eq? clock-type time-thread) (tm:current-time-thread))
|
||||||
((eq? clock-type time-process) (tm:current-time-process))
|
((eq? clock-type time-process) (tm:current-time-process))
|
||||||
((eq? clock-type time-gc) (tm:current-time-gc))
|
((eq? clock-type time-gc) (tm:current-time-gc))
|
||||||
(else (tm:time-error 'current-time 'invalid-clock-type clock-type)))))
|
(else (tm:time-error 'current-time 'invalid-clock-type clock-type)))))
|
||||||
|
|
||||||
|
|
||||||
;; -- Time Resolution
|
;; -- Time Resolution
|
||||||
|
|
@ -354,12 +354,12 @@
|
||||||
(define (time-resolution . clock-type)
|
(define (time-resolution . clock-type)
|
||||||
(let ((clock-type (:optional clock-type time-utc)))
|
(let ((clock-type (:optional clock-type time-utc)))
|
||||||
(cond
|
(cond
|
||||||
((eq? clock-type time-tai) 10000)
|
((eq? clock-type time-tai) 10000)
|
||||||
((eq? clock-type time-utc) 10000)
|
((eq? clock-type time-utc) 10000)
|
||||||
((eq? clock-type time-monotonic) 10000)
|
((eq? clock-type time-monotonic) 10000)
|
||||||
((eq? clock-type time-thread) 10000)
|
((eq? clock-type time-thread) 10000)
|
||||||
((eq? clock-type time-gc) 10000)
|
((eq? clock-type time-gc) 10000)
|
||||||
(else (tm:time-error 'time-resolution 'invalid-clock-type clock-type)))))
|
(else (tm:time-error 'time-resolution 'invalid-clock-type clock-type)))))
|
||||||
|
|
||||||
(define (tm:time-compare-check time1 time2 caller)
|
(define (tm:time-compare-check time1 time2 caller)
|
||||||
(if (or (not (and (time? time1) (time? time2)))
|
(if (or (not (and (time? time1) (time? time2)))
|
||||||
|
|
@ -444,7 +444,7 @@
|
||||||
(nsec-plus (+ (time-nanosecond time1) (time-nanosecond duration))) )
|
(nsec-plus (+ (time-nanosecond time1) (time-nanosecond duration))) )
|
||||||
(let ((r (remainder nsec-plus tm:nano))
|
(let ((r (remainder nsec-plus tm:nano))
|
||||||
(q (quotient nsec-plus tm:nano)))
|
(q (quotient nsec-plus tm:nano)))
|
||||||
; (set-time-type! time3 (time-type time1))
|
; (set-time-type! time3 (time-type time1))
|
||||||
(if (negative? r)
|
(if (negative? r)
|
||||||
(begin
|
(begin
|
||||||
(set-time-second! time3 (+ sec-plus q -1))
|
(set-time-second! time3 (+ sec-plus q -1))
|
||||||
|
|
@ -629,11 +629,11 @@
|
||||||
|
|
||||||
(define (tm:char-pos char str index len)
|
(define (tm:char-pos char str index len)
|
||||||
(cond
|
(cond
|
||||||
((>= index len) #f)
|
((>= index len) #f)
|
||||||
((char=? (string-ref str index) char)
|
((char=? (string-ref str index) char)
|
||||||
index)
|
index)
|
||||||
(else
|
(else
|
||||||
(tm:char-pos char str (+ index 1) len))))
|
(tm:char-pos char str (+ index 1) len))))
|
||||||
|
|
||||||
; return a string representing the decimal expansion of the fractional
|
; return a string representing the decimal expansion of the fractional
|
||||||
; portion of a number, limited by a specified precision
|
; portion of a number, limited by a specified precision
|
||||||
|
|
@ -766,8 +766,8 @@
|
||||||
|
|
||||||
;; tm:year-day fixed: adding wrong number of days.
|
;; tm:year-day fixed: adding wrong number of days.
|
||||||
(define tm:month-assoc '((0 . 0) (1 . 31) (2 . 59) (3 . 90) (4 . 120)
|
(define tm:month-assoc '((0 . 0) (1 . 31) (2 . 59) (3 . 90) (4 . 120)
|
||||||
(5 . 151) (6 . 181) (7 . 212) (8 . 243)
|
(5 . 151) (6 . 181) (7 . 212) (8 . 243)
|
||||||
(9 . 273) (10 . 304) (11 . 334)))
|
(9 . 273) (10 . 304) (11 . 334)))
|
||||||
|
|
||||||
(define (tm:year-day day month year)
|
(define (tm:year-day day month year)
|
||||||
(let ((days-pr (assoc (- month 1) tm:month-assoc)))
|
(let ((days-pr (assoc (- month 1) tm:month-assoc)))
|
||||||
|
|
@ -816,12 +816,12 @@
|
||||||
(let* ( (current-year (srfi:date-year (current-date)))
|
(let* ( (current-year (srfi:date-year (current-date)))
|
||||||
(current-century (* (quotient current-year 100) 100)) )
|
(current-century (* (quotient current-year 100) 100)) )
|
||||||
(cond
|
(cond
|
||||||
((>= n 100) n)
|
((>= n 100) n)
|
||||||
((< n 0) n)
|
((< n 0) n)
|
||||||
((<= (- (+ current-century n) current-year) 50)
|
((<= (- (+ current-century n) current-year) 50)
|
||||||
(+ current-century n))
|
(+ current-century n))
|
||||||
(else
|
(else
|
||||||
(+ (- current-century 100) n)))))
|
(+ (- current-century 100) n)))))
|
||||||
|
|
||||||
(define (date->julian-day date)
|
(define (date->julian-day date)
|
||||||
(let ( (nanosecond (date-nanosecond date))
|
(let ( (nanosecond (date-nanosecond date))
|
||||||
|
|
@ -935,7 +935,7 @@
|
||||||
(new-str-offset (- (string-length new-str)
|
(new-str-offset (- (string-length new-str)
|
||||||
str-len)) )
|
str-len)) )
|
||||||
(do ((i 0 (+ i 1)))
|
(do ((i 0 (+ i 1)))
|
||||||
((>= i (string-length str)))
|
((>= i (string-length str)))
|
||||||
(string-set! new-str (+ new-str-offset i)
|
(string-set! new-str (+ new-str-offset i)
|
||||||
(string-ref str i)))
|
(string-ref str i)))
|
||||||
new-str))))
|
new-str))))
|
||||||
|
|
@ -959,9 +959,9 @@
|
||||||
(let ((len (vector-length haystack)))
|
(let ((len (vector-length haystack)))
|
||||||
(define (tm:vector-find-int index)
|
(define (tm:vector-find-int index)
|
||||||
(cond
|
(cond
|
||||||
((>= index len) #f)
|
((>= index len) #f)
|
||||||
((comparator needle (localized-message (vector-ref haystack index))) (+ index 1))
|
((comparator needle (localized-message (vector-ref haystack index))) (+ index 1))
|
||||||
(else (tm:vector-find-int (+ index 1)))))
|
(else (tm:vector-find-int (+ index 1)))))
|
||||||
(tm:vector-find-int 0)))
|
(tm:vector-find-int 0)))
|
||||||
|
|
||||||
(define (tm:locale-abbr-weekday->index string)
|
(define (tm:locale-abbr-weekday->index string)
|
||||||
|
|
@ -991,9 +991,9 @@
|
||||||
|
|
||||||
(define (tm:tz-printer offset port)
|
(define (tm:tz-printer offset port)
|
||||||
(cond
|
(cond
|
||||||
((= offset 0) (display "Z" port))
|
((= offset 0) (display "Z" port))
|
||||||
((negative? offset) (display "-" port))
|
((negative? offset) (display "-" port))
|
||||||
(else (display "+" port)))
|
(else (display "+" port)))
|
||||||
(if (not (= offset 0))
|
(if (not (= offset 0))
|
||||||
(let ( (hours (abs (quotient offset (* 60 60))))
|
(let ( (hours (abs (quotient offset (* 60 60))))
|
||||||
(minutes (abs (quotient (remainder offset (* 60 60)) 60))) )
|
(minutes (abs (quotient (remainder offset (* 60 60)) 60))) )
|
||||||
|
|
@ -1171,46 +1171,46 @@
|
||||||
format-string)
|
format-string)
|
||||||
(let ( (pad-char? (string-ref format-string (+ index 1))) )
|
(let ( (pad-char? (string-ref format-string (+ index 1))) )
|
||||||
(cond
|
(cond
|
||||||
((char=? pad-char? #\-)
|
((char=? pad-char? #\-)
|
||||||
(if (= (+ index 2) str-len) ; bad format string.
|
(if (= (+ index 2) str-len) ; bad format string.
|
||||||
(tm:time-error 'tm:date-printer 'bad-date-format-string
|
(tm:time-error 'tm:date-printer 'bad-date-format-string
|
||||||
format-string)
|
format-string)
|
||||||
(let ( (formatter (tm:get-formatter
|
(let ( (formatter (tm:get-formatter
|
||||||
(string-ref format-string
|
(string-ref format-string
|
||||||
(+ index 2)))) )
|
(+ index 2)))) )
|
||||||
(if (not formatter)
|
(if (not formatter)
|
||||||
(tm:time-error 'tm:date-printer 'bad-date-format-string
|
(tm:time-error 'tm:date-printer 'bad-date-format-string
|
||||||
format-string)
|
format-string)
|
||||||
(begin
|
(begin
|
||||||
(formatter date #f port)
|
(formatter date #f port)
|
||||||
(tm:date-printer date (+ index 3)
|
(tm:date-printer date (+ index 3)
|
||||||
format-string str-len port))))))
|
format-string str-len port))))))
|
||||||
|
|
||||||
((char=? pad-char? #\_)
|
((char=? pad-char? #\_)
|
||||||
(if (= (+ index 2) str-len) ; bad format string.
|
(if (= (+ index 2) str-len) ; bad format string.
|
||||||
(tm:time-error 'tm:date-printer 'bad-date-format-string
|
(tm:time-error 'tm:date-printer 'bad-date-format-string
|
||||||
format-string)
|
format-string)
|
||||||
(let ( (formatter (tm:get-formatter
|
(let ( (formatter (tm:get-formatter
|
||||||
(string-ref format-string
|
(string-ref format-string
|
||||||
(+ index 2)))) )
|
(+ index 2)))) )
|
||||||
(if (not formatter)
|
(if (not formatter)
|
||||||
(tm:time-error 'tm:date-printer 'bad-date-format-string
|
(tm:time-error 'tm:date-printer 'bad-date-format-string
|
||||||
format-string)
|
format-string)
|
||||||
(begin
|
(begin
|
||||||
(formatter date #\Space port)
|
(formatter date #\Space port)
|
||||||
(tm:date-printer date (+ index 3)
|
(tm:date-printer date (+ index 3)
|
||||||
format-string str-len port))))))
|
format-string str-len port))))))
|
||||||
(else
|
(else
|
||||||
(let ( (formatter (tm:get-formatter
|
(let ( (formatter (tm:get-formatter
|
||||||
(string-ref format-string
|
(string-ref format-string
|
||||||
(+ index 1)))) )
|
(+ index 1)))) )
|
||||||
(if (not formatter)
|
(if (not formatter)
|
||||||
(tm:time-error 'tm:date-printer 'bad-date-format-string
|
(tm:time-error 'tm:date-printer 'bad-date-format-string
|
||||||
format-string)
|
format-string)
|
||||||
(begin
|
(begin
|
||||||
(formatter date #\0 port)
|
(formatter date #\0 port)
|
||||||
(tm:date-printer date (+ index 2)
|
(tm:date-printer date (+ index 2)
|
||||||
format-string str-len port))))))))))))
|
format-string str-len port))))))))))))
|
||||||
|
|
||||||
|
|
||||||
(define (date->string date . format-string)
|
(define (date->string date . format-string)
|
||||||
|
|
@ -1221,18 +1221,18 @@
|
||||||
|
|
||||||
(define (tm:char->int ch)
|
(define (tm:char->int ch)
|
||||||
(cond
|
(cond
|
||||||
((char=? ch #\0) 0)
|
((char=? ch #\0) 0)
|
||||||
((char=? ch #\1) 1)
|
((char=? ch #\1) 1)
|
||||||
((char=? ch #\2) 2)
|
((char=? ch #\2) 2)
|
||||||
((char=? ch #\3) 3)
|
((char=? ch #\3) 3)
|
||||||
((char=? ch #\4) 4)
|
((char=? ch #\4) 4)
|
||||||
((char=? ch #\5) 5)
|
((char=? ch #\5) 5)
|
||||||
((char=? ch #\6) 6)
|
((char=? ch #\6) 6)
|
||||||
((char=? ch #\7) 7)
|
((char=? ch #\7) 7)
|
||||||
((char=? ch #\8) 8)
|
((char=? ch #\8) 8)
|
||||||
((char=? ch #\9) 9)
|
((char=? ch #\9) 9)
|
||||||
(else (tm:time-error 'bad-date-template-string
|
(else (tm:time-error 'bad-date-template-string
|
||||||
(list "Non-integer character" ch)))))
|
(list "Non-integer character" ch)))))
|
||||||
|
|
||||||
;; read an integer upto n characters long on port; upto -> #f if any length
|
;; read an integer upto n characters long on port; upto -> #f if any length
|
||||||
(define (tm:integer-reader upto port)
|
(define (tm:integer-reader upto port)
|
||||||
|
|
@ -1255,20 +1255,20 @@
|
||||||
(define (accum-int port accum nchars)
|
(define (accum-int port accum nchars)
|
||||||
(let ((ch (peek-char port)))
|
(let ((ch (peek-char port)))
|
||||||
(cond
|
(cond
|
||||||
((>= nchars n) accum)
|
((>= nchars n) accum)
|
||||||
((eof-object? ch)
|
((eof-object? ch)
|
||||||
(tm:time-error 'string->date 'bad-date-template-string
|
(tm:time-error 'string->date 'bad-date-template-string
|
||||||
"Premature ending to integer read."))
|
"Premature ending to integer read."))
|
||||||
((char-numeric? ch)
|
((char-numeric? ch)
|
||||||
(set! padding-ok #f)
|
(set! padding-ok #f)
|
||||||
(accum-int port (+ (* accum 10) (tm:char->int (read-char port)))
|
(accum-int port (+ (* accum 10) (tm:char->int (read-char port)))
|
||||||
(+ nchars 1)))
|
(+ nchars 1)))
|
||||||
(padding-ok
|
(padding-ok
|
||||||
(read-char port) ; consume padding
|
(read-char port) ; consume padding
|
||||||
(accum-int port accum (+ nchars 1)))
|
(accum-int port accum (+ nchars 1)))
|
||||||
(else ; padding where it shouldn't be
|
(else ; padding where it shouldn't be
|
||||||
(tm:time-error 'string->date 'bad-date-template-string
|
(tm:time-error 'string->date 'bad-date-template-string
|
||||||
"Non-numeric characters in integer read.")))))
|
"Non-numeric characters in integer read.")))))
|
||||||
(accum-int port 0 0)))
|
(accum-int port 0 0)))
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -1287,11 +1287,11 @@
|
||||||
0
|
0
|
||||||
(begin
|
(begin
|
||||||
(cond
|
(cond
|
||||||
((char=? ch #\+) (set! positive? #t))
|
((char=? ch #\+) (set! positive? #t))
|
||||||
((char=? ch #\-) (set! positive? #f))
|
((char=? ch #\-) (set! positive? #f))
|
||||||
(else
|
(else
|
||||||
(tm:time-error 'string->date 'bad-date-template-string
|
(tm:time-error 'string->date 'bad-date-template-string
|
||||||
(list "Invalid time zone +/-" ch))))
|
(list "Invalid time zone +/-" ch))))
|
||||||
(let ((ch (read-char port)))
|
(let ((ch (read-char port)))
|
||||||
(if (eof-object? ch)
|
(if (eof-object? ch)
|
||||||
(tm:time-error 'string->date 'bad-date-template-string (list "Invalid time zone number" ch)))
|
(tm:time-error 'string->date 'bad-date-template-string (list "Invalid time zone number" ch)))
|
||||||
|
|
@ -1299,9 +1299,9 @@
|
||||||
10 60 60)))
|
10 60 60)))
|
||||||
(let ((ch (read-char port)))
|
(let ((ch (read-char port)))
|
||||||
(unless (eof-object? ch)
|
(unless (eof-object? ch)
|
||||||
;; FIXME: non-existing values should be considered Zero instead of an error
|
;; FIXME: non-existing values should be considered Zero instead of an error
|
||||||
;; (tm:time-error 'string->date 'bad-date-template-string (list "Invalid time zone number" ch)))
|
;; (tm:time-error 'string->date 'bad-date-template-string (list "Invalid time zone number" ch)))
|
||||||
(set! offset (+ offset (* (tm:char->int ch) 60 60)))))
|
(set! offset (+ offset (* (tm:char->int ch) 60 60)))))
|
||||||
(let ((ch (read-char port)))
|
(let ((ch (read-char port)))
|
||||||
(unless (eof-object? ch)
|
(unless (eof-object? ch)
|
||||||
;; FIXME: non-existing values should be considered Zero instead of an error
|
;; FIXME: non-existing values should be considered Zero instead of an error
|
||||||
|
|
@ -1311,7 +1311,7 @@
|
||||||
(unless (eof-object? ch)
|
(unless (eof-object? ch)
|
||||||
;; FIXME: non-existing values should be considered Zero instead of an error
|
;; FIXME: non-existing values should be considered Zero instead of an error
|
||||||
;; (tm:time-error 'string->date 'bad-date-template-string (list "Invalid time zone number" ch)))
|
;; (tm:time-error 'string->date 'bad-date-template-string (list "Invalid time zone number" ch)))
|
||||||
(set! offset (+ offset (* (tm:char->int ch) 60)))))
|
(set! offset (+ offset (* (tm:char->int ch) 60)))))
|
||||||
(if positive? offset (- offset)))))))
|
(if positive? offset (- offset)))))))
|
||||||
|
|
||||||
;; looking at a char, read the char string, run thru indexer, return index
|
;; looking at a char, read the char string, run thru indexer, return index
|
||||||
|
|
@ -1354,7 +1354,7 @@
|
||||||
;; In some cases (e.g., ~A) the action is to do nothing
|
;; In some cases (e.g., ~A) the action is to do nothing
|
||||||
(define tm:read-directives
|
(define tm:read-directives
|
||||||
(let ( (ireader4 (tm:make-integer-reader 4))
|
(let ( (ireader4 (tm:make-integer-reader 4))
|
||||||
(ireader2 (tm:make-integer-reader 2))
|
(ireader2 (tm:make-integer-reader 2))
|
||||||
(ireader7 (tm:make-integer-reader 7))
|
(ireader7 (tm:make-integer-reader 7))
|
||||||
(ireaderf (tm:make-integer-reader #f))
|
(ireaderf (tm:make-integer-reader #f))
|
||||||
(eireader2 (tm:make-integer-exact-reader 2))
|
(eireader2 (tm:make-integer-exact-reader 2))
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user