diff --git a/lib/srfi/srfi-19.scm b/lib/srfi/srfi-19.scm index 8a398e3ad5..29f3b112d3 100644 --- a/lib/srfi/srfi-19.scm +++ b/lib/srfi/srfi-19.scm @@ -27,98 +27,110 @@ ;; functions that do more work in a "chunk". (define-module (srfi srfi-19) - :use-module (srfi srfi-6) + :use-module (ice-9 syncase) :use-module (srfi srfi-8) - :use-module (srfi srfi-9) - :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 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-monotonic - 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)) + :use-module (srfi srfi-9)) -(cond-expand-provide (current-module) '(srfi-19)) +(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 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-monotonic + 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) + +;; Guile's prior to 1.5.X didn't have this. +(define (priv:open-input-string str) + (call-with-input-string str (lambda (port) + port))) + +;; :OPTIONAL is nice + +(define-syntax :optional + (syntax-rules () + ((_ val default-value) + (if (null? val) default-value (car val))))) (define time-tai 'time-tai) (define time-utc 'time-utc) @@ -215,7 +227,7 @@ (let loop ((line (read-line port))) (if (not (eq? line eof)) (begin - (let* ((data (read (open-input-string + (let* ((data (read (priv:open-input-string (string-append "(" line ")")))) (year (car data)) (jd (cadddr (cdr data))) @@ -378,7 +390,7 @@ ;; (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)))) + (let ((clock-type (:optional clock-type time-utc))) (cond ((eq? clock-type time-tai) (priv:current-time-tai)) ((eq? clock-type time-utc) (priv:current-time-utc)) @@ -393,7 +405,7 @@ ;; This will be implementation specific. (define (time-resolution . clock-type) - (let ((clock-type (if (null? clock-type) time-utc (car clock-type)))) + (let ((clock-type (:optional clock-type time-utc))) (case clock-type ((time-tai) 1000) ((time-utc) 1000) @@ -565,14 +577,11 @@ ;; -- 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) + (make-date-unnormalized nanosecond second minute + hour day month + year + zone-offset) date? (nanosecond date-nanosecond) (second date-second) @@ -583,28 +592,6 @@ (year date-year) (zone-offset date-zone-offset)) -(define (priv:time-normalize! t) - (if (>= (abs (time-nanosecond t)) 1000000000) - (begin - (set-time-second! t (+ (time-second t) - (quotient (time-nanosecond t) 1000000000))) - (set-time-nanosecond! t (remainder (time-nanosecond t) - 1000000000)))) - (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) - - - ( - ;; gives the julian day which starts at noon. (define (priv:encode-julian-day-number day month year) (let* ((a (quotient (- 14 month) 12)) @@ -625,7 +612,7 @@ ;; gives the seconds/date/month/year (define (priv:decode-julian-day-number jdn) - (let* ((days (inexact->exact (truncate jdn))) + (let* ((days (truncate jdn)) (a (+ days 32044)) (b (quotient (+ (* 4 a) 3) 146097)) (c (- a (quotient (* 146097 b) 4))) @@ -659,7 +646,7 @@ (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) (car tz-offset))) + (let* ((offset (:optional tz-offset (priv:local-tz-offset))) (leap-second? (priv:leap-second? (+ offset (time-second time)))) (jdn (priv:time->julian-day-number (if leap-second? (- (time-second time) 1) @@ -668,9 +655,8 @@ (call-with-values (lambda () (priv:decode-julian-day-number jdn)) (lambda (secs date month year) - (let* ((int-secs (inexact->exact (floor secs))) - (hours (quotient int-secs (* 60 60))) - (rem (remainder int-secs (* 60 60))) + (let* ((hours (quotient secs (* 60 60))) + (rem (remainder secs (* 60 60))) (minutes (quotient rem 60)) (seconds (remainder rem 60))) (make-date (time-nanosecond time) @@ -685,7 +671,7 @@ (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) (car tz-offset))) + (let* ((offset (:optional tz-offset (priv:local-tz-offset))) (seconds (- (time-second time) (priv:leap-second-delta (time-second time)))) (leap-second? (priv:leap-second? (+ offset seconds))) @@ -713,7 +699,7 @@ (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) (car tz-offset))) + (let* ((offset (:optional tz-offset (priv:local-tz-offset))) (seconds (- (time-second time) (priv:leap-second-delta (time-second time)))) (leap-second? (priv:leap-second? (+ offset seconds))) @@ -810,9 +796,8 @@ 7)) (define (current-date . tz-offset) - (time-utc->date - (current-time time-utc) - (if (null? tz-offset) (priv:local-tz-offset) (car tz-offset)))) + (time-utc->date (current-time time-utc) + (:optional tz-offset (priv:local-tz-offset)))) ;; given a 'two digit' number, find the year within 50 years +/- (define (priv:natural-year n) @@ -897,11 +882,11 @@ (time-utc->time-monotonic! (julian-day->time-utc jdn))) (define (julian-day->date jdn . tz-offset) - (let ((offset (if (null? tz-offset) (priv:local-tz-offset) (car tz-offset)))) + (let ((offset (:optional tz-offset (priv:local-tz-offset)))) (time-utc->date (julian-day->time-utc jdn) offset))) (define (modified-julian-day->date jdn . tz-offset) - (let ((offset (if (null? tz-offset) (priv:local-tz-offset) (car tz-offset)))) + (let ((offset (:optional tz-offset (priv:local-tz-offset)))) (julian-day->date (+ jdn 4800001/2) offset))) (define (modified-julian-day->time-utc jdn) @@ -1227,10 +1212,11 @@ (define (date->string date . format-string) - (let ((str-port (open-output-string)) - (fmt-str (if (null? format-string) "~c" (car format-string)))) - (priv:date-printer date 0 fmt-str (string-length fmt-str) str-port) - (get-output-string str-port))) + (call-with-output-string + (lambda (str-port) + (let ((fmt-str (:optional format-string "~c"))) + (priv:date-printer date 0 fmt-str (string-length fmt-str) str-port) + (get-output-string str-port))))) (define (priv:char->int ch) (case ch @@ -1335,18 +1321,18 @@ ;; looking at a char, read the char string, run thru indexer, return index (define (priv:locale-reader port indexer) - (let ((string-port (open-output-string))) - (define (read-char-string) - (let ((ch (peek-char port))) - (if (char-alphabetic? ch) - (begin (write-char (read-char port) string-port) - (read-char-string)) - (get-output-string string-port)))) - (let* ((str (read-char-string)) - (index (indexer str))) - (if index index (priv:time-error 'string->date - 'bad-date-template-string - (list "Invalid string for " indexer)))))) + + (define (read-char-string result) + (let ((ch (peek-char port))) + (if (char-alphabetic? ch) + (read-char-string (cons (read-char port) result)) + (list->string (reverse result))))) + + (let* ((str (read-char-string '())) + (index (indexer str))) + (if index index (priv:time-error 'string->date + 'bad-date-template-string + (list "Invalid string for " indexer))))) (define (priv:make-locale-reader indexer) (lambda (port) @@ -1496,7 +1482,7 @@ 0 template-string (string-length template-string) - (open-input-string input-string) + (priv:open-input-string input-string) template-string) (if (priv:date-ok? newdate) newdate