From 6918efd4a4ee8daa933d3c23e1b24d30fccf05fb Mon Sep 17 00:00:00 2001 From: mainzelm Date: Tue, 25 Feb 2003 09:32:05 +0000 Subject: [PATCH] New version from Will Fitzgerald adapted to scsh. --- scheme/srfi/srfi-19.scm | 1350 +++++++++++++++++++++------------------ 1 file changed, 716 insertions(+), 634 deletions(-) diff --git a/scheme/srfi/srfi-19.scm b/scheme/srfi/srfi-19.scm index 66e0caf..34bc4c6 100644 --- a/scheme/srfi/srfi-19.scm +++ b/scheme/srfi/srfi-19.scm @@ -1,6 +1,6 @@ ;; SRFI-19: Time Data Types and Procedures. ;; -;; Copyright (C) I/NET, Inc. (2000, 2002). All Rights Reserved. +;; Copyright (C) I/NET, Inc. (2000, 2002, 2003). All Rights Reserved. ;; ;; This document and translations of it may be copied and furnished to others, ;; and derivative works that comment on or otherwise explain it or assist in its @@ -23,6 +23,56 @@ ;; INFORMATION HEREIN WILL NOT INFRINGE ANY RIGHTS OR ANY IMPLIED WARRANTIES OF ;; MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. + +;; -- Bug fixes. +;; +;; MAKE-TIME had parameters seconds and nanoseconds reversed; change all +;; references in file to match. Will F: 2002-10-15 +;; +;; DATE-YEAR-DAY returned the wrong day; tm:year-day fixed to do the right +;; thing. Will F: 2002-10-15 +;; It also called an undefined error procedure. +;; +;; DISPLAYING procedure removed. Will F: 2002-10-15. +;; +;; TM:NANO constant corrected. 2002-11-04. +;; +;; The following fixes by Will Fitzgerald, February, 2003. +;; -- Thanks to Steven Ma and others. +;; +;; (CURRENT-TIME 'TIME-THREAD) added. +;; +;; TIME-RESOLUTION for TIME-PROCESS added. +;; +;; TIME comparison procedures (time=?, etc. fixed. +;; +;; Corrected errors in converting between TAI and UTC time. +;; +;; TAI and UTC date converters no longer look at leap seconds, +;; which was an error. +;; +;; corrections to calls to tm:time-error +;; +;; timezone offset not used in date->time-utc and date->julian-day +;; +;; typos in tm:integer-reader-exact, tm:string->date, +;; time-monotonic->time-utc!, tm:char->int fixed +;; +;; corrected "~k", "~f" formatting for date->string (includes fix for +;; "~4" +;; +;; 'split-real' fixed. +;; +;; fixed julian-day->time-utc and variants. +;; -------------------------------------------------------------- + +;;; SCSH portability: import receive from srfi-8 + +;;; -- we want receive later on for a couple of small things +;; + +;; :OPTIONAL is nice, too + (define-syntax :optional (syntax-rules () ((_ val default-value) @@ -35,26 +85,29 @@ (define time-process 'time-process) (define time-duration 'time-duration) +;; example of extension (MZScheme specific) +(define time-gc 'time-gc) + ;;-- LOCALE dependent constants (define tm:locale-number-separator ".") (define tm:locale-abbr-weekday-vector (vector "Sun" "Mon" "Tue" "Wed" - "Thu" "Fri" "Sat")) + "Thu" "Fri" "Sat")) (define tm:locale-long-weekday-vector (vector "Sunday" "Monday" - "Tuesday" "Wednesday" - "Thursday" "Friday" - "Saturday")) + "Tuesday" "Wednesday" + "Thursday" "Friday" + "Saturday")) ;; note empty string in 0th place. (define tm:locale-abbr-month-vector (vector "" "Jan" "Feb" "Mar" - "Apr" "May" "Jun" "Jul" - "Aug" "Sep" "Oct" "Nov" - "Dec")) + "Apr" "May" "Jun" "Jul" + "Aug" "Sep" "Oct" "Nov" + "Dec")) (define tm:locale-long-month-vector (vector "" "January" "February" - "March" "April" "May" - "June" "July" "August" - "September" "October" - "November" "December")) + "March" "April" "May" + "June" "July" "August" + "September" "October" + "November" "December")) (define tm:locale-pm "PM") (define tm:locale-am "AM") @@ -92,10 +145,9 @@ (define (tm:time-error caller type value) (if (member type tm:time-error-types) (if value - ;; SCSH portability - (error caller (format #f "TIME-ERROR type ~S: ~S" type value)) - (error caller (format #f "TIME-ERROR type ~S" type))) - (error caller (format #f "TIME-ERROR unsupported error type ~S" type)))) + (error caller "TIME-ERROR type ~S: ~S" type value) + (error caller "TIME-ERROR type ~S" type)) + (error caller "TIME-ERROR unsupported error type ~S" type))) ;; A table of leap seconds @@ -126,7 +178,7 @@ (loop (read-line port)))))) table)) -;; each entry is (tai seconds since epoch . # seconds to subtract for utc) +;; each entry is ( utc seconds since epoch . # seconds to add for tai ) ;; note they go higher to lower, and end in 1972. (define tm:leap-second-table '((915148800 . 32) @@ -159,219 +211,267 @@ (define (tm:leap-second-delta utc-seconds) - (letrec ((lsd (lambda (table) - (cond ((>= utc-seconds (caar table)) - (cdar table)) - (else (lsd (cdr table))))))) + (letrec ( (lsd (lambda (table) + (cond + ((>= utc-seconds (caar table)) + (cdar table)) + (else (lsd (cdr table)))))) ) (if (< utc-seconds (* (- 1972 1970) 365 tm:sid)) 0 - (lsd tm:leap-second-table)))) + (lsd tm:leap-second-table)))) + +;; going from tai seconds to utc seconds ... +(define (tm:leap-second-neg-delta tai-seconds) + (letrec ( (lsd (lambda (table) + (cond ((null? table) 0) + ((<= (cdar table) (- tai-seconds (caar table))) + (cdar table)) + (else (lsd (cdr table)))))) ) + (if (< tai-seconds (* (- 1972 1970) 365 tm:sid)) 0 + (lsd tm:leap-second-table)))) -;;; the TIME structure; creates the accessors, too. -;;; wf: changed to match SRFI documentation +;;; the time structure; creates the accessors, too. +;;; wf: changed to match srfi documentation. uses mzscheme structures & inspectors -(define-record-type :time - (make-time-unnormalized type nanosecond second) +(define-record-type :time + (make-time 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 (tm:split-real r) - (if (integer? r) - (values (inexact->exact r) 0) - (let ((l (truncate r))) - (values l (- r l))))) - -(define (tm:time-normalize! t) - (if (>= (abs (time-nanosecond t)) 1000000000) - (receive (int frac) - (tm: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) - (tm:time-normalize! (make-time-unnormalized type nanosecond second))) + (let ((ntime (make-time #f #f #f))) + (set-time-type! ntime (time-type time)) + (set-time-second! ntime (time-second time)) + (set-time-nanosecond! ntime (time-nanosecond time)) + ntime)) ;;; current-time ;;; specific time getters. -;;; These should be rewritten to be OS specific. +;;; these should be rewritten to be os specific. ;; -;; -- using GNU gettimeofday() would be useful here -- gets +;; -- using gnu gettimeofday() would be useful here -- gets ;; second + millisecond -;; let's pretend we do, using MzScheme's current-seconds & current-milliseconds -;; this is supposed to return UTC. +;; let's pretend we do, using mzscheme's current-seconds & current-milliseconds +;; this is supposed to return utc. ;; -'(define (tm:get-time-of-day) - (values (current-seconds) - (abs (remainder (current-milliseconds) 1000)))) +;; SCSH portability: scsh has even more than milliseconds: ticks +; (define (tm:get-time-of-day) +; (values (current-seconds) +; (abs (remainder (current-milliseconds) 1000)))) -;; SCSH portability +;; SCSH portability: use time+ticks (define (tm:current-time-utc) (receive (seconds quanta) (time+ticks) - (make-time time-utc - (* quanta tm:ns/quantum) - seconds))) + (make-time time-utc + (* quanta tm:ns/quantum) + seconds ))) -;; SCSH portability +;; SCSH portability: use time+ticks (define (tm:current-time-tai) - (receive (seconds quanta) (time+ticks) - (make-time time-tai - (* quanta tm:ns/quantum) - (+ seconds (tm:leap-second-delta seconds))))) - - -(define (tm:current-time-ms-time time-type proc) - (let ((current-ms (proc))) - (make-time time-type - (* (remainder current-ms 1000) tm:ns/quantum) - (quotient current-ms 1000) - ))) - -;; -- 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. - -;; SCSH portability -(define (tm:current-time-monotonic) - (receive (seconds quanta) (time+ticks) + (receive (seconds quanta) (time+ticks) (make-time time-tai (* quanta tm:ns/quantum) (+ seconds (tm:leap-second-delta seconds))))) +;; SCSH portability: use tm:ns/quantum +(define (tm:current-time-ms-time time-type proc) + (let ((current-ms (proc))) + (make-time time-type + (* (remainder current-ms 1000) tm:ns/quantum) + (quotient current-ms 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. + +;; SCSH portability: use time+ticks +(define (tm:current-time-monotonic) + (receive (seconds quanta) (time+ticks) + (make-time time-monotonic + (* quanta tm:ns/quantum) + (+ seconds (tm:leap-second-delta seconds)) + ))) + +;; SCSH portability: thread time not available in scsh (define (tm:current-time-thread) (tm:time-error 'current-time 'unsupported-clock-type 'time-thread)) -;; SCSH portability +;; SCSH portability: use cpu-ticks/sec (define (tm:current-time-process) (let ((ticks/s (cpu-ticks/sec))) (receive (userticks systicks childuserticks childsysticks) (process-times) - (make-time time-process - (* (remainder userticks ticks/s) (/ tm:nano ticks/s)) - (quotient userticks ticks/s))))) + (make-time time-process + (* (remainder userticks ticks/s) (/ tm:nano ticks/s)) + (quotient userticks ticks/s))))) -;; SCSH portability + +;; SCSH portability: GC time not available in scsh (define (tm:current-time-gc) (tm:time-error 'current-time 'unsupported-clock-type 'time-gc)) + (define (current-time . clock-type) (let ( (clock-type (:optional clock-type time-utc)) ) (cond - ((eq? clock-type time-tai) (tm:current-time-tai)) - ((eq? clock-type time-utc) (tm:current-time-utc)) - ((eq? clock-type time-monotonic) (tm:current-time-monotonic)) - ((eq? clock-type time-thread) (tm:current-time-thread)) - ((eq? clock-type time-process) (tm:current-time-process)) - ;; ((eq? clock-type time-gc) (tm:current-time-gc)) - (else (tm:time-error 'current-time 'invalid-clock-type clock-type))))) + ((eq? clock-type time-tai) (tm:current-time-tai)) + ((eq? clock-type time-utc) (tm:current-time-utc)) + ((eq? clock-type time-monotonic) (tm:current-time-monotonic)) + ((eq? clock-type time-thread) (tm:current-time-thread)) + ((eq? clock-type time-process) (tm:current-time-process)) + ((eq? clock-type time-gc) (tm:current-time-gc)) + (else (tm: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. +;; -- time resolution +;; this is the resolution of the clock in nanoseconds. +;; this will be implementation specific. +;; SCSH portability: use tm:ns/quantum and tm:nano (define (time-resolution . clock-type) (let ((clock-type (:optional clock-type time-utc))) (cond - ((eq? clock-type time-tai) tm:ns/quantum) - ((eq? clock-type time-utc) tm:ns/quantum) - ((eq? clock-type time-monotonic) tm:ns/quantum) - ((eq? clock-type time-thread) tm:ns/quantum) - ;; SCSH portability - ((eq? clock-type time-process) (/ tm:nano (cpu-ticks/sec))) - ;;((eq? clock-type time-gc) tm:ns/quantum) - (else (tm:time-error 'time-resolution 'invalid-clock-type clock-type))))) + ((eq? clock-type time-tai) tm:ns/quantum) + ((eq? clock-type time-utc) tm:ns/quantum) + ((eq? clock-type time-monotonic) tm:ns/quantum) + ((eq? clock-type time-thread) tm:ns/quantum) + ((eq? clock-type time-process) (/ tm:nano (cpu-ticks/sec))) + (else (tm:time-error 'time-resolution 'invalid-clock-type clock-type))))) -;; -- Time comparisons +;; -- 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 (tm:time-compare-check time1 time2 caller) + (if (or (not (and (time? time1) (time? time2))) + (not (eq? (time-type time1) (time-type time2)))) + (tm:time-error caller 'incompatible-time-types #f) + #t)) -(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=? time1 time2) + (tm:time-compare-check time1 time2 'time=?) + (and (= (time-second time1) (time-second time2)) + (= (time-nanosecond time1) (time-nanosecond time2)))) -(define (time? time1 time2) + (tm:time-compare-check time1 time2 'time>?) + (or (> (time-second time1) (time-second time2)) + (and (= (time-second time1) (time-second time2)) + (> (time-nanosecond time1) (time-nanosecond time2))))) -(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=? time1 time2) + (tm:time-compare-check time1 time2 'time>=?) + (or (>= (time-second time1) (time-second time2)) + (and (= (time-second time1) (time-second time2)) + (>= (time-nanosecond time1) (time-nanosecond time2))))) -;; -- Time arithmetic +(define (time<=? time1 time2) + (tm:time-compare-check time1 time2 'time<=?) + (or (<= (time-second time1) (time-second time2)) + (and (= (time-second time1) (time-second time2)) + (<= (time-nanosecond time1) (time-nanosecond time2))))) -(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) - (tm:time-normalize! time1))) +;; -- time arithmetic + +(define (tm:time->nanoseconds time) + (define (sign1 n) + (if (negative? n) -1 1)) + (+ (* (time-second time) tm:nano) + (time-nanosecond time))) + +(define (tm:nanoseconds->time time-type nanoseconds) + (make-time time-type + (remainder nanoseconds tm:nano) + (quotient nanoseconds tm:nano))) + +(define (tm:nanoseconds->values nanoseconds) + (values (abs (remainder nanoseconds tm:nano)) + (quotient nanoseconds tm:nano))) + +(define (tm:time-difference time1 time2 time3) + (if (or (not (and (time? time1) (time? time2))) + (not (eq? (time-type time1) (time-type time2)))) + (tm:time-error 'time-difference 'incompatible-time-types #f)) + (set-time-type! time3 time-duration) + (if (time=? time1 time2) + (begin + (set-time-second! time3 0) + (set-time-nanosecond! time3 0)) + (receive + (nanos secs) + (tm:nanoseconds->values (- (tm:time->nanoseconds time1) + (tm:time->nanoseconds time2))) + (set-time-second! time3 secs) + (set-time-nanosecond! time3 nanos))) + time3) (define (time-difference time1 time2) - (let ((result (copy-time time1))) - (time-difference! result time2))) + (tm:time-difference time1 time2 (make-time #f #f #f))) -(define (add-duration! t duration) +(define (time-difference! time1 time2) + (tm:time-difference time1 time2 time1)) + +(define (tm:add-duration time1 duration time3) + (if (not (and (time? time1) (time? duration))) + (tm:time-error 'add-duration 'incompatible-time-types #f)) (if (not (eq? (time-type duration) time-duration)) (tm: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) - (tm:time-normalize! t)))) + (let ( (sec-plus (+ (time-second time1) (time-second duration))) + (nsec-plus (+ (time-nanosecond time1) (time-nanosecond duration))) ) + (let ((r (remainder nsec-plus tm:nano)) + (q (quotient nsec-plus tm:nano))) + ; (set-time-type! time3 (time-type time1)) + (if (negative? r) + (begin + (set-time-second! time3 (+ sec-plus q -1)) + (set-time-nanosecond! time3 (+ tm:nano r))) + (begin + (set-time-second! time3 (+ sec-plus q)) + (set-time-nanosecond! time3 r))) + time3)))) -(define (add-duration t duration) - (let ((result (copy-time t))) - (add-duration! result duration))) +(define (add-duration time1 duration) + (tm:add-duration time1 duration (make-time (time-type time1) #f #f))) -(define (subtract-duration! t duration) +(define (add-duration! time1 duration) + (tm:add-duration time1 duration time1)) + +(define (tm:subtract-duration time1 duration time3) + (if (not (and (time? time1) (time? duration))) + (tm:time-error 'add-duration 'incompatible-time-types #f)) (if (not (eq? (time-type duration) time-duration)) - (tm: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) - (tm:time-normalize! t)))) + (tm:time-error 'tm:subtract-duration 'not-duration duration) + (let ( (sec-minus (- (time-second time1) (time-second duration))) + (nsec-minus (- (time-nanosecond time1) (time-nanosecond duration))) ) + (let ((r (remainder nsec-minus tm:nano)) + (q (quotient nsec-minus tm:nano))) + (if (negative? r) + (begin + ;;; SCSH portability: use binary - + (set-time-second! time3 (- (- sec-minus q) 1)) + (set-time-nanosecond! time3 (+ tm:nano r))) + (begin + (set-time-second! time3 (- sec-minus q)) + (set-time-nanosecond! time3 r))) + time3)))) (define (subtract-duration time1 duration) - (let ((result (copy-time time1))) - (subtract-duration! result duration))) + (tm:subtract-duration time1 duration (make-time (time-type time1) #f #f))) -;; -- Converters between types. +(define (subtract-duration! time1 duration) + (tm:subtract-duration time1 duration time1)) + + +;; -- converters between types. (define (tm:time-tai->time-utc! time-in time-out caller) (if (not (eq? (time-type time-in) time-tai)) @@ -379,29 +479,31 @@ (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) - (tm:leap-second-delta - (time-second time-in)))) + (tm:leap-second-neg-delta + (time-second time-in)))) time-out) (define (time-tai->time-utc time-in) - (tm:time-tai->time-utc! time-in (make-time-unnormalized #f #f #f) 'time-tai->time-utc)) + (tm:time-tai->time-utc! time-in (make-time #f #f #f) 'time-tai->time-utc)) (define (time-tai->time-utc! time-in) (tm:time-tai->time-utc! time-in time-in 'time-tai->time-utc!)) + (define (tm:time-utc->time-tai! time-in time-out caller) (if (not (eq? (time-type time-in) time-utc)) (tm: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) - (tm:leap-second-delta - (time-second time-in)))) + (tm:leap-second-delta + (time-second time-in)))) time-out) + (define (time-utc->time-tai time-in) - (tm:time-utc->time-tai! time-in (make-time-unnormalized #f #f #f) 'time-utc->time-tai)) + (tm:time-utc->time-tai! time-in (make-time #f #f #f) 'time-utc->time-tai)) (define (time-utc->time-tai! time-in) (tm:time-utc->time-tai! time-in time-in 'time-utc->time-tai!)) @@ -409,7 +511,7 @@ ;; -- 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)) - (tm:time-error 'time-monotonic->time-utc 'incompatible-time-types time-in)) + (tm:time-error 'time-monotoinc->time-utc 'incompatible-time-types time-in)) (let ((ntime (copy-time time-in))) (set-time-type! ntime time-tai) (tm:time-tai->time-utc! ntime ntime 'time-monotonic->time-utc))) @@ -429,14 +531,14 @@ (define (time-monotonic->time-tai! time-in) (if (not (eq? (time-type time-in) time-monotonic)) - (tm:time-error 'time-monotonic->time-tai 'incompatible-time-types time-in)) + (tm:time-error 'time-monotonic->time-tai! '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)) - (tm:time-error 'time-utc->time-monotonic 'incompatible-time-types time-in)) - (let ((ntime (tm:time-utc->time-tai! time-in (make-time-unnormalized #f #f #f) + (tm:time-error 'time-utc->time-monotonic 'incompatible-time-types time-in)) + (let ((ntime (tm:time-utc->time-tai! time-in (make-time #f #f #f) 'time-utc->time-monotonic))) (set-time-type! ntime time-monotonic) ntime)) @@ -444,7 +546,7 @@ (define (time-utc->time-monotonic! time-in) (if (not (eq? (time-type time-in) time-utc)) - (tm:time-error 'time-utc->time-monotonic! 'incompatible-time-types time-in)) + (tm:time-error 'time-utc->time-montonic! 'incompatible-time-types time-in)) (let ((ntime (tm:time-utc->time-tai! time-in time-in 'time-utc->time-monotonic!))) (set-time-type! ntime time-monotonic) @@ -460,34 +562,60 @@ (define (time-tai->time-monotonic! time-in) (if (not (eq? (time-type time-in) time-tai)) - (tm:time-error 'time-tai->time-monotonic! 'incompatible-time-types time-in)) + (tm:time-error 'time-tai->time-monotonic! 'incompatible-time-types time-in)) (set-time-type! time-in time-monotonic) time-in) -;; -- Date Structures +;; -- date structures -;; SCSH portability (define-record-type :date - (make-date nanosecond second minute - hour day month - year - zone-offset) + (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!) + (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!)) +;; redefine setters + +(define tm:set-date-nanosecond! set-date-nanosecond!) +(define tm:set-date-second! set-date-second!) +(define tm:set-date-minute! set-date-minute!) +(define tm:set-date-hour! set-date-hour!) +(define tm:set-date-day! set-date-day!) +(define tm:set-date-month! set-date-month!) +(define tm:set-date-year! set-date-year!) +(define tm:set-date-zone-offset! set-date-zone-offset!) + +(define (set-date-second! date val) + (tm:time-error 'set-date-second! 'dates-are-immutable date)) + +(define (set-date-minute! date val) + (tm:time-error 'set-date-minute! 'dates-are-immutable date)) + +(define (set-date-day! date val) + (tm:time-error 'set-date-day! 'dates-are-immutable date)) + +(define (set-date-month! date val) + (tm:time-error 'set-date-month! 'dates-are-immutable date)) + +(define (set-date-year! date val) + (tm:time-error 'set-date-year! 'dates-are-immutable date)) + +(define (set-date-zone-offset! date val) + (tm:time-error 'set-date-zone-offset! 'dates-are-immutable date)) + ;; gives the julian day which starts at noon. (define (tm: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))) + ;; SCSH portability: use binary - + (y (- (- (+ year 4800) a) (if (negative? year) -1 0))) + (m (- (+ month (* 12 a)) 3))) (+ day (quotient (+ (* 153 m) 2) 5) (* 365 y) @@ -496,7 +624,26 @@ (quotient y 400) -32045))) -;; gives the seconds/date/month/year +(define (tm:char-pos char str index len) + (cond + ((>= index len) #f) + ((char=? (string-ref str index) char) + index) + (else + (tm:char-pos char str (+ index 1) len)))) + +(define (tm:split-real r) + (if (integer? r) + (values r 0) + (let ((str (number->string (exact->inexact r)))) + (let ((ppos (tm:char-pos #\. str 0 (string-length str)))) + (if ppos + (values + (string->number (substring str 0 ppos)) + (string->number (substring str (+ ppos 1) (string-length str)))) + (values r 0)))))) + +;; gives the seconds/date/month/year (define (tm:decode-julian-day-number jdn) (let* ((days (truncate jdn)) (a (+ days 32044)) @@ -518,8 +665,8 @@ ;; differently from MzScheme's.... ;; This should be written to be OS specific. -(define (tm:local-tz-offset utc-time) - ;; SCSH portability +;; SCSH portability: use scsh's DATE procedure +(define (tm:local-tz-offset) (date:tz-secs (date))) ;; special thing -- ignores nanos @@ -530,111 +677,78 @@ tm:sid) tm:tai-epoch-in-jd)) -(define (tm:leap-second? second) - (and (assoc second tm:leap-second-table) #t)) +(define (tm:find proc l) + (if (null? l) + #f + (if (proc (car l)) + #t + (tm:find proc (cdr l))))) + +(define (tm:tai-before-leap-second? second) + (tm:find (lambda (x) + (= second (- (+ (car x) (cdr x)) 1))) + tm:leap-second-table)) + +(define (tm:time->date time tz-offset ttype) + (if (not (eq? (time-type time) ttype)) + (tm:time-error 'time->date 'incompatible-time-types time)) + (let* ( (offset (:optional tz-offset (tm:local-tz-offset))) ) + (receive (secs date month year) + (tm:decode-julian-day-number + (tm:time->julian-day-number (time-second time) offset)) + (let* ( (hours (quotient secs (* 60 60))) + (rem (remainder secs (* 60 60))) + (minutes (quotient rem 60)) + (seconds (remainder rem 60)) ) + (make-date (time-nanosecond time) + seconds + minutes + hours + date + month + year + offset))))) + +(define (time-tai->date time . tz-offset) + (if (tm:tai-before-leap-second? (time-second time)) + ;; if it's *right* before the leap, we need to pretend to subtract a second ... + (let ((d (tm:time->date (subtract-duration! (time-tai->time-utc time) (make-time time-duration 0 1)) tz-offset time-utc))) + (tm:set-date-second! d 60) + d) + (tm:time->date (time-tai->time-utc time) tz-offset time-utc))) (define (time-utc->date time . tz-offset) - (if (not (eq? (time-type time) time-utc)) - (tm:time-error 'time->date 'incompatible-time-types time)) - (let* ((offset (if (null? tz-offset) - (tm:local-tz-offset time) - (car tz-offset))) - (leap-second? (tm:leap-second? (+ offset (time-second time)))) - (jdn (tm:time->julian-day-number (if leap-second? - (- (time-second time) 1) - (time-second time)) - offset))) + (tm:time->date time tz-offset time-utc)) - (call-with-values (lambda () (tm:decode-julian-day-number jdn)) - (lambda (secs date month year) - (let* ((hours (quotient secs (* 60 60))) - (rem (remainder 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)) - (tm:time-error 'time->date 'incompatible-time-types time)) - (let* ((offset (if (null? tz-offset) - (tm:local-tz-offset (time-tai->time-utc time)) - (car tz-offset))) - (seconds (- (time-second time) - (tm:leap-second-delta (time-second time)))) - (leap-second? (tm:leap-second? (+ offset seconds))) - (jdn (tm:time->julian-day-number (if leap-second? - (- seconds 1) - seconds) - offset))) - (call-with-values (lambda () (tm:decode-julian-day-number jdn)) - (lambda (secs date month year) - (let* ((hours (quotient secs (* 60 60))) - (rem (remainder 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. +;; again, time-monotonic is the same as time tai (define (time-monotonic->date time . tz-offset) - (if (not (eq? (time-type time) time-monotonic)) - (tm:time-error 'time->date 'incompatible-time-types time)) - (let* ((offset (if (null? tz-offset) - (tm:local-tz-offset (time-monotonic->time-utc time)) - (car tz-offset))) - (seconds (- (time-second time) - (tm:leap-second-delta (time-second time)))) - (leap-second? (tm:leap-second? (+ offset seconds))) - (jdn (tm:time->julian-day-number (if leap-second? - (- seconds 1) - seconds) - offset))) - (call-with-values (lambda () (tm:decode-julian-day-number jdn)) - (lambda (secs date month year) - (let* ((hours (quotient secs (* 60 60))) - (rem (remainder 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)))))) + (tm:time->date time tz-offset time-monotonic)) (define (date->time-utc date) - (let* ((jdays (- (tm:encode-julian-day-number (date-day date) - (date-month date) - (date-year date)) - tm:tai-epoch-in-jd)) - ;; jdays is an integer plus 1/2, - (jdays-1/2 (- 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)))))) + (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)) + (offset (date-zone-offset date)) ) + (let ( (jdays (- (tm:encode-julian-day-number day month year) + tm:tai-epoch-in-jd)) ) + (make-time + time-utc + nanosecond + (+ (* (- jdays 1/2) 24 60 60) + (* hour 60 60) + (* minute 60) + second + (- offset)) + )))) -(define (date->time-tai date) - (time-utc->time-tai! (date->time-utc date))) +(define (date->time-tai d) + (if (= (date-second d) 60) + (subtract-duration! (time-utc->time-tai! (date->time-utc d)) (make-time time-duration 0 1)) + (time-utc->time-tai! (date->time-utc d)))) (define (date->time-monotonic date) (time-utc->time-monotonic! (date->time-utc date))) @@ -647,14 +761,13 @@ (define (leap-year? date) (tm: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 tm: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))) +;; tm:year-day fixed: adding wrong number of days. +(define tm:month-assoc '((0 . 0) (1 . 31) (2 . 59) (3 . 90) (4 . 120) + (5 . 151) (6 . 181) (7 . 212) (8 . 243) + (9 . 273) (10 . 304) (11 . 334))) (define (tm:year-day day month year) - (let ((days-pr (assoc month tm:month-assoc))) + (let ((days-pr (assoc (- month 1) tm:month-assoc))) (if (not days-pr) (tm:time-error 'date-year-day 'invalid-month-specification month)) (if (and (tm:leap-year? year) (> month 2)) @@ -677,55 +790,54 @@ (tm:week-day (date-day date) (date-month date) (date-year date))) (define (tm: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))) + (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) - (tm:days-before-first-week date day-of-week-starting-week)) - 7)) + (tm: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) - (tm:local-tz-offset time) - (car tz-offset))))) +(define (current-date . tz-offset) + (time-utc->date (current-time time-utc) + (:optional tz-offset (tm:local-tz-offset)))) ;; given a 'two digit' number, find the year within 50 years +/- (define (tm:natural-year n) - (let* ((current-year (date-year (current-date))) - (current-century (* (quotient current-year 100) 100))) + (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))))) + ((>= 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))) + (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)) + (offset (date-zone-offset date)) ) (+ (tm:encode-julian-day-number day month year) (- 1/2) - (+ (/ (+ (* hour 60 60) - (* minute 60) - second - (/ nanosecond tm:nano)) - tm:sid))))) + ;; SCSH portability: use binary / + (+ (/ (/ (+ (* hour 60 60) + (* minute 60) + second + (/ nanosecond tm:nano)) + tm:sid) + (- offset)))))) (define (date->modified-julian-day date) (- (date->julian-day date) @@ -734,22 +846,22 @@ (define (time-utc->julian-day time) (if (not (eq? (time-type time) time-utc)) - (tm:time-error 'time->date 'incompatible-time-types time)) + (tm:time-error 'time-utc->julian-day 'incompatible-time-types time)) (+ (/ (+ (time-second time) (/ (time-nanosecond time) tm:nano)) tm:sid) tm:tai-epoch-in-jd)) (define (time-utc->modified-julian-day time) (- (time-utc->julian-day time) - 4800001/2)) + 4800001/2)) (define (time-tai->julian-day time) (if (not (eq? (time-type time) time-tai)) - (tm:time-error 'time->date 'incompatible-time-types time)) - (+ (/ (+ (- (time-second time) - (tm:leap-second-delta (time-second time))) - (/ (time-nanosecond time) tm:nano)) - tm:sid) + (tm:time-error 'time-tai->julian-day 'incompatible-time-types time)) + (+ (/ (+ (- (time-second time) + (tm:leap-second-delta (time-second time))) + (/ (time-nanosecond time) tm:nano)) + tm:sid) tm:tai-epoch-in-jd)) (define (time-tai->modified-julian-day time) @@ -759,11 +871,11 @@ ;; this is the same as time-tai->julian-day (define (time-monotonic->julian-day time) (if (not (eq? (time-type time) time-monotonic)) - (tm:time-error 'time->date 'incompatible-time-types time)) - (+ (/ (+ (- (time-second time) - (tm:leap-second-delta (time-second time))) - (/ (time-nanosecond time) tm:nano)) - tm:sid) + (tm:time-error 'time-monotonic->julian-day 'incompatible-time-types time)) + (+ (/ (+ (- (time-second time) + (tm:leap-second-delta (time-second time))) + (/ (time-nanosecond time) tm:nano)) + tm:sid) tm:tai-epoch-in-jd)) @@ -773,23 +885,20 @@ (define (julian-day->time-utc jdn) - (let ((secs (* tm:sid (- jdn tm:tai-epoch-in-jd)))) - (receive (seconds parts) - (tm:split-real secs) - (make-time time-utc - (* parts tm:nano) - seconds)))) + (let ( (nanosecs (* tm:nano tm:sid (- jdn tm:tai-epoch-in-jd))) ) + (make-time time-utc + (remainder nanosecs tm:nano) + (floor (/ nanosecs tm:nano))))) (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 (:optional tz-offset (tm:local-tz-offset time)))) - (time-utc->date time offset))) + (let ((offset (:optional tz-offset (tm:local-tz-offset)))) + (time-utc->date (julian-day->time-utc jdn) offset))) (define (modified-julian-day->date jdn . tz-offset) (let ((offset (:optional tz-offset (tm:local-tz-offset)))) @@ -810,18 +919,25 @@ (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. +;; returns a string rep. of number N, of minimum LENGTH, +;; padded with character PAD-WITH. If PAD-WITH if #f, +;; no padding is done, and it's as if number->string was used. +;; if string is longer than LENGTH, it's as if number->string was used. (define (tm:padding n pad-with length) - (let* ((str (number->string n)) - (str-len (string-length str))) - (if (or (>= str-len 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)))) + str + (let* ( (new-str (make-string length pad-with)) + (new-str-offset (- (string-length new-str) + str-len)) ) + (do ((i 0 (+ i 1))) + ((>= i (string-length str))) + (string-set! new-str (+ new-str-offset i) + (string-ref str i))) + new-str)))) (define (tm:last-n-digits i n) (abs (remainder i (expt 10 n)))) @@ -842,9 +958,9 @@ (let ((len (vector-length haystack))) (define (tm:vector-find-int index) (cond - ((>= index len) #f) - ((comparator needle (vector-ref haystack index)) index) - (else (tm:vector-find-int (+ index 1))))) + ((>= index len) #f) + ((comparator needle (vector-ref haystack index)) index) + (else (tm:vector-find-int (+ index 1))))) (tm:vector-find-int 0))) (define (tm:locale-abbr-weekday->index string) @@ -860,39 +976,43 @@ (tm:vector-find string tm: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 (tm:locale-print-time-zone date port) - (tm:tz-printer (date-zone-offset date) port)) -;; FIXME: we should use strftime to determine this dynamically if possible. +;; do nothing. +;; Your implementation might want to do something... +;; +(define (tm:locale-print-time-zone date port) + (values)) + ;; Again, locale specific. (define (tm:locale-am/pm hr) (if (> hr 11) tm:locale-pm tm:locale-am)) (define (tm:tz-printer offset port) (cond - ((= offset 0) (display "Z" port)) - ((negative? offset) (display "-" port)) - (else (display "+" port))) + ((= 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 (tm:padding hours #\0 2) port) (display (tm:padding minutes #\0 2) port)))) -;; SCSH portability -(define char-tab (ascii->char 9)) - ;; 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 tm:directives + +;; SCSH portability: use #\space instead of #\Space and +;; (ascii->char 9) instead of #\Tab + +(define char-tab (ascii->char 9)) + +(define tm:directives (list (cons #\~ (lambda (date pad-with port) (display #\~ port))) - + (cons #\a (lambda (date pad-with port) (display (tm:locale-abbr-weekday (date-week-day date)) port))) @@ -910,9 +1030,9 @@ (cons #\d (lambda (date pad-with port) (display (tm:padding (date-day date) #\0 2) - port))) + port))) (cons #\D (lambda (date pad-with port) - (display (date->string date "~m/~d/~y") port))) + (display (date->string date "~m/~d/~y") port))) (cons #\e (lambda (date pad-with port) (display (tm:padding (date-day date) #\space 2) @@ -927,6 +1047,7 @@ pad-with 2) port)) (receive (i f) + ;;; SCSH portability: make use of / binary (tm:split-real (/ (date-nanosecond date) (* tm:nano 1.0))) @@ -957,8 +1078,8 @@ port))) (cons #\k (lambda (date pad-with port) (display (tm:padding (date-hour date) - #\space 2) - port))) + #\0 2) + port))) (cons #\l (lambda (date pad-with port) (let ((hr (if (> (date-hour date) 12) (- (date-hour date) 12) (date-hour date)))) @@ -987,12 +1108,12 @@ (cons #\S (lambda (date pad-with port) (if (> (date-nanosecond date) tm:nano) - (display (tm:padding (+ (date-second date) 1) - pad-with 2) - port) - (display (tm:padding (date-second date) - pad-with 2) - port)))) + (display (tm:padding (+ (date-second date) 1) + pad-with 2) + port) + (display (tm:padding (date-second date) + pad-with 2) + port)))) (cons #\t (lambda (date pad-with port) (display char-tab port))) (cons #\T (lambda (date pad-with port) @@ -1033,13 +1154,13 @@ (cons #\1 (lambda (date pad-with port) (display (date->string date "~Y-~m-~d") port))) (cons #\2 (lambda (date pad-with port) - (display (date->string date "~H:~M:~S~z") port))) + (display (date->string date "~k:~M:~S~z") port))) (cons #\3 (lambda (date pad-with port) - (display (date->string date "~H:~M:~S") port))) + (display (date->string date "~k:~M:~S") port))) (cons #\4 (lambda (date pad-with port) - (display (date->string date "~Y-~m-~dT~H:~M:~S~z") port))) + (display (date->string date "~Y-~m-~dT~k:~M:~S~z") port))) (cons #\5 (lambda (date pad-with port) - (display (date->string date "~Y-~m-~dT~H:~M:~S") port))) + (display (date->string date "~Y-~m-~dT~k:~M:~S") port))) )) @@ -1050,70 +1171,56 @@ (define (tm:date-printer date index format-string str-len port) (if (>= index str-len) (values) - (let ((current-char (string-ref format-string index))) - (if (not (char=? current-char #\~)) - (begin - (display current-char port) - (tm:date-printer date (+ index 1) format-string str-len port)) - (if (= (+ index 1) str-len) ; bad format string. - (tm:time-error 'tm:date-printer 'bad-date-format-string - format-string) - (let ((pad-char? (string-ref format-string (+ index 1)))) + (let ( (current-char (string-ref format-string index)) ) + (if (not (char=? current-char #\~)) + (begin + (display current-char port) + (tm:date-printer date (+ index 1) format-string str-len port)) + (if (= (+ index 1) str-len) ; bad format string. + (tm:time-error 'tm:date-printer 'bad-date-format-string + format-string) + (let ( (pad-char? (string-ref format-string (+ index 1))) ) (cond - ((char=? pad-char? #\-) - (if (= (+ index 2) str-len) ; bad format string. - (tm:time-error 'tm:date-printer - 'bad-date-format-string - format-string) - (let ((formatter (tm:get-formatter - (string-ref format-string - (+ index 2))))) - (if (not formatter) - (tm:time-error 'tm:date-printer - 'bad-date-format-string - format-string) - (begin - (formatter date #f port) - (tm:date-printer date - (+ index 3) - format-string - str-len - port)))))) - - ((char=? pad-char? #\_) - (if (= (+ index 2) str-len) ; bad format string. - (tm:time-error 'tm:date-printer - 'bad-date-format-string - format-string) - (let ((formatter (tm:get-formatter - (string-ref format-string - (+ index 2))))) - (if (not formatter) - (tm:time-error 'tm:date-printer - 'bad-date-format-string - format-string) - (begin - (formatter date #\space port) - (tm:date-printer date - (+ index 3) - format-string - str-len - port)))))) - (else - (let ((formatter (tm:get-formatter - (string-ref format-string - (+ index 1))))) - (if (not formatter) - (tm:time-error 'tm:date-printer - 'bad-date-format-string - format-string) - (begin - (formatter date #\0 port) - (tm:date-printer date - (+ index 2) - format-string - str-len - port)))))))))))) + ((char=? pad-char? #\-) + (if (= (+ index 2) str-len) ; bad format string. + (tm:time-error 'tm:date-printer 'bad-date-format-string + format-string) + (let ( (formatter (tm:get-formatter + (string-ref format-string + (+ index 2)))) ) + (if (not formatter) + (tm:time-error 'tm:date-printer 'bad-date-format-string + format-string) + (begin + (formatter date #f port) + (tm:date-printer date (+ index 3) + format-string str-len port)))))) + + ((char=? pad-char? #\_) + (if (= (+ index 2) str-len) ; bad format string. + (tm:time-error 'tm:date-printer 'bad-date-format-string + format-string) + (let ( (formatter (tm:get-formatter + (string-ref format-string + (+ index 2)))) ) + (if (not formatter) + (tm:time-error 'tm:date-printer 'bad-date-format-string + format-string) + (begin + (formatter date #\space port) + (tm:date-printer date (+ index 3) + format-string str-len port)))))) + (else + (let ( (formatter (tm:get-formatter + (string-ref format-string + (+ index 1)))) ) + (if (not formatter) + (tm:time-error 'tm:date-printer 'bad-date-format-string + format-string) + (begin + (formatter date #\0 port) + (tm:date-printer date (+ index 2) + format-string str-len port)))))))))))) (define (date->string date . format-string) @@ -1121,32 +1228,34 @@ (fmt-str (:optional format-string "~c")) ) (tm:date-printer date 0 fmt-str (string-length fmt-str) str-port) (get-output-string str-port))) - -(define (tm:char->int ch) - (case ch - ((#\0) 0) - ((#\1) 1) - ((#\2) 2) - ((#\3) 3) - ((#\4) 4) - ((#\5) 5) - ((#\6) 6) - ((#\7) 7) - ((#\8) 8) - ((#\9) 9) - (else (tm:time-error 'bad-date-template-string - (list "Non-integer character" ch))))) -;; read an integer upto n characters long on port; upto -> #f is any length +(define (tm:char->int ch) + (cond + ((char=? ch #\0) 0) + ((char=? ch #\1) 1) + ((char=? ch #\2) 2) + ((char=? ch #\3) 3) + ((char=? ch #\4) 4) + ((char=? ch #\5) 5) + ((char=? ch #\6) 6) + ((char=? ch #\7) 7) + ((char=? ch #\8) 8) + ((char=? ch #\9) 9) + (else (tm:time-error 'string->date 'bad-date-template-string + (list "Non-integer character" ch ))))) + +;; read an integer upto n characters long on port; upto -> #f if any length (define (tm:integer-reader upto port) - (let loop ((accum 0) (nchars 0)) + (define (accum-int port accum nchars) (let ((ch (peek-char port))) (if (or (eof-object? ch) (not (char-numeric? ch)) - (and upto (>= nchars upto))) + (and upto (>= nchars upto ))) accum - (loop (+ (* accum 10) (tm:char->int (read-char port))) - (+ nchars 1)))))) + (accum-int port (+ (* accum 10) (tm:char->int (read-char + port))) (+ + nchars 1))))) + (accum-int port 0 0)) (define (tm:make-integer-reader upto) (lambda (port) @@ -1154,24 +1263,24 @@ ;; read *exactly* n characters and convert to integer; could be padded (define (tm:integer-reader-exact n port) - (let ((padding-ok #t)) + (let ( (padding-ok #t) ) (define (accum-int port accum nchars) (let ((ch (peek-char port))) (cond - ((>= nchars n) accum) - ((eof-object? ch) - (tm:time-error 'string->date 'bad-date-template-string - "Premature ending to integer read.")) - ((char-numeric? ch) - (set! padding-ok #f) - (accum-int port (+ (* accum 10) (tm:char->int (read-char - port))) - (+ nchars 1))) - (padding-ok - (read-char port) ; consume padding - (accum-int port accum (+ nchars 1))) - (else ; padding where it shouldn't be - (tm:time-error 'string->date 'bad-date-template-string + ((>= nchars n) accum) + ((eof-object? ch) + (tm:time-error 'string->date 'bad-date-template-string + "Premature ending to integer read.")) + ((char-numeric? ch) + (set! padding-ok #f) + (accum-int port (+ (* accum 10) (tm:char->int (read-char + port))) + (+ nchars 1))) + (padding-ok + (read-char port) ; consume padding + (accum-int port accum (+ nchars 1))) + (else ; padding where it shouldn't be + (tm:time-error 'string->date 'bad-date-template-string "Non-numeric characters in integer read."))))) (accum-int port 0 0))) @@ -1188,59 +1297,59 @@ (tm:time-error 'string->date 'bad-date-template-string (list "Invalid time zone +/-" ch))) (if (or (char=? ch #\Z) (char=? ch #\z)) - 0 - (begin - (cond - ((char=? ch #\+) (set! positive? #t)) - ((char=? ch #\-) (set! positive? #f)) - (else - (tm:time-error 'string->date 'bad-date-template-string - (list "Invalid time zone +/-" ch)))) - (let ((ch (read-char port))) - (if (eof-object? ch) - (tm:time-error 'string->date 'bad-date-template-string - (list "Invalid time zone number" ch))) - (set! offset (* (tm:char->int ch) - 10 60 60))) - (let ((ch (read-char port))) - (if (eof-object? 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)))) - (let ((ch (read-char port))) - (if (eof-object? ch) - (tm:time-error 'string->date 'bad-date-template-string - (list "Invalid time zone number" ch))) - (set! offset (+ offset (* (tm:char->int ch) - 10 60)))) - (let ((ch (read-char port))) - (if (eof-object? ch) - (tm:time-error 'string->date 'bad-date-template-string - (list "Invalid time zone number" ch))) - (set! offset (+ offset (* (tm:char->int ch) - 60)))) - (if positive? offset (- offset))))))) + 0 + (begin + (cond + ((char=? ch #\+) (set! positive? #t)) + ((char=? ch #\-) (set! positive? #f)) + (else + (tm:time-error 'string->date 'bad-date-template-string + (list "Invalid time zone +/-" ch)))) + (let ((ch (read-char port))) + (if (eof-object? ch) + (tm:time-error 'string->date 'bad-date-template-string + (list "Invalid time zone number" ch))) + (set! offset (* (tm:char->int ch) + 10 60 60))) + (let ((ch (read-char port))) + (if (eof-object? 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)))) + (let ((ch (read-char port))) + (if (eof-object? ch) + (tm:time-error 'string->date 'bad-date-template-string + (list "Invalid time zone number" ch))) + (set! offset (+ offset (* (tm:char->int ch) + 10 60)))) + (let ((ch (read-char port))) + (if (eof-object? ch) + (tm:time-error 'string->date 'bad-date-template-string + (list "Invalid time zone number" ch))) + (set! offset (+ offset (* (tm:char->int ch) + 60)))) + (if positive? offset (- offset))))))) ;; looking at a char, read the char string, run thru indexer, return index (define (tm:locale-reader port 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 (tm:time-error 'string->date - 'bad-date-template-string - (list "Invalid string for " 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 (tm:time-error 'string->date + 'bad-date-template-string + (list "Invalid string for " indexer)))))) (define (tm:make-locale-reader indexer) (lambda (port) (tm:locale-reader port indexer))) - + (define (tm:make-char-id-reader char) (lambda (port) (if (char=? char (read-char port)) @@ -1261,64 +1370,66 @@ ;; object (here, always the date) and (probably) side-effects it. ;; In some cases (e.g., ~A) the action is to do nothing -(define tm:read-directives - (let ((ireader4 (tm:make-integer-reader 4)) - (ireader2 (tm:make-integer-reader 2)) - (ireaderf (tm:make-integer-reader #f)) - (eireader2 (tm:make-integer-exact-reader 2)) - (eireader4 (tm:make-integer-exact-reader 4)) - (locale-reader-abbr-weekday (tm:make-locale-reader - tm:locale-abbr-weekday->index)) - (locale-reader-long-weekday (tm:make-locale-reader - tm:locale-long-weekday->index)) - (locale-reader-abbr-month (tm:make-locale-reader - tm:locale-abbr-month->index)) - (locale-reader-long-month (tm:make-locale-reader - tm:locale-long-month->index)) - (char-fail (lambda (ch) #t)) - (do-nothing (lambda (val object) (values)))) - +(define tm:read-directives + (let ( (ireader4 (tm:make-integer-reader 4)) + (ireader2 (tm:make-integer-reader 2)) + (ireaderf (tm:make-integer-reader #f)) + (eireader2 (tm:make-integer-exact-reader 2)) + (eireader4 (tm:make-integer-exact-reader 4)) + (locale-reader-abbr-weekday (tm:make-locale-reader + tm:locale-abbr-weekday->index)) + (locale-reader-long-weekday (tm:make-locale-reader + tm:locale-long-weekday->index)) + (locale-reader-abbr-month (tm:make-locale-reader + tm:locale-abbr-month->index)) + (locale-reader-long-month (tm:make-locale-reader + tm:locale-long-month->index)) + (char-fail (lambda (ch) #t)) + (do-nothing (lambda (val object) (values))) + ) + (list (list #\~ char-fail (tm:make-char-id-reader #\~) do-nothing) (list #\a char-alphabetic? locale-reader-abbr-weekday do-nothing) (list #\A char-alphabetic? locale-reader-long-weekday do-nothing) (list #\b char-alphabetic? locale-reader-abbr-month (lambda (val object) - (set-date-month! object val))) + (tm:set-date-month! object val))) (list #\B char-alphabetic? locale-reader-long-month (lambda (val object) - (set-date-month! object val))) + (tm:set-date-month! object val))) (list #\d char-numeric? ireader2 (lambda (val object) - (set-date-day! + (tm:set-date-day! object val))) (list #\e char-fail eireader2 (lambda (val object) - (set-date-day! object val))) + (tm:set-date-day! object val))) (list #\h char-alphabetic? locale-reader-abbr-month (lambda (val object) - (set-date-month! object val))) + (tm:set-date-month! object val))) (list #\H char-numeric? ireader2 (lambda (val object) - (set-date-hour! object val))) + (tm:set-date-hour! object val))) (list #\k char-fail eireader2 (lambda (val object) - (set-date-hour! object val))) + (tm:set-date-hour! object val))) (list #\m char-numeric? ireader2 (lambda (val object) - (set-date-month! object val))) + (tm:set-date-month! object val))) (list #\M char-numeric? ireader2 (lambda (val object) - (set-date-minute! + (tm:set-date-minute! object val))) (list #\S char-numeric? ireader2 (lambda (val object) - (set-date-second! object val))) - (list #\y char-fail eireader2 + (tm:set-date-second! object val))) + (list #\y char-fail eireader2 (lambda (val object) - (set-date-year! object (tm:natural-year val)))) + (tm:set-date-year! object (tm:natural-year val)))) (list #\Y char-numeric? ireader4 (lambda (val object) - (set-date-year! object val))) + (tm:set-date-year! object val))) (list #\z (lambda (c) (or (char=? c #\Z) (char=? c #\z) (char=? c #\+) (char=? c #\-))) tm:zone-reader (lambda (val object) - (set-date-zone-offset! object val)))))) + (tm:set-date-zone-offset! object val))) + ))) (define (tm:string->date date index format-string str-len port template-string) (define (skip-until port skipper) @@ -1328,80 +1439,51 @@ (if (not (skipper ch)) (begin (read-char port) (skip-until port skipper)))))) (if (>= index str-len) - (begin - (values)) - (let ((current-char (string-ref format-string index))) - (if (not (char=? current-char #\~)) - (let ((port-char (read-char port))) - (if (or (eof-object? port-char) - (not (char=? current-char port-char))) - (tm:time-error 'string->date - 'bad-date-format-string template-string)) - (tm:string->date date - (+ index 1) - format-string - str-len - port - template-string)) - ;; otherwise, it's an escape, we hope - (if (> (+ index 1) str-len) - (tm:time-error 'string->date - 'bad-date-format-string template-string) - (let* ((format-char (string-ref format-string (+ index 1))) - (format-info (assoc format-char tm:read-directives))) - (if (not format-info) - (tm:time-error 'string->date - 'bad-date-format-string template-string) - (begin - (let ((skipper (cadr format-info)) - (reader (caddr format-info)) - (actor (cadddr format-info))) - (skip-until port skipper) - (let ((val (reader port))) - (if (eof-object? val) - (tm:time-error 'string->date - 'bad-date-format-string - template-string) - (actor val date))) - (tm:string->date date - (+ index 2) - format-string - str-len - port - template-string)))))))))) + (begin + (values)) + (let ( (current-char (string-ref format-string index)) ) + (if (not (char=? current-char #\~)) + (let ((port-char (read-char port))) + (if (or (eof-object? port-char) + (not (char=? current-char port-char))) + (tm:time-error 'string->date 'bad-date-format-string template-string)) + (tm:string->date date (+ index 1) format-string str-len port template-string)) + ;; otherwise, it's an escape, we hope + (if (> (+ index 1) str-len) + (tm:time-error 'string->date 'bad-date-format-string template-string) + (let* ( (format-char (string-ref format-string (+ index 1))) + (format-info (assoc format-char tm:read-directives)) ) + (if (not format-info) + (tm:time-error 'string->date 'bad-date-format-string template-string) + (begin + (let ((skipper (cadr format-info)) + (reader (caddr format-info)) + (actor (cadddr format-info))) + (skip-until port skipper) + (let ((val (reader port))) + (if (eof-object? val) + (tm:time-error 'string->date 'bad-date-format-string template-string) + (actor val date))) + (tm:string->date date (+ index 2) format-string str-len port template-string)))))))))) (define (string->date input-string template-string) (define (tm:date-ok? date) (and (date-nanosecond date) - (date-second date) - (date-minute date) - (date-hour date) - (date-day date) - (date-month date) - (date-year date) - (date-zone-offset date))) - (let ((newdate (make-date 0 0 0 0 #f #f #f #f))) + (date-second date) + (date-minute date) + (date-hour date) + (date-day date) + (date-month date) + (date-year date) + (date-zone-offset date))) + (let ( (newdate (make-date 0 0 0 0 #f #f #f (tm:local-tz-offset))) ) (tm:string->date newdate - 0 - template-string - (string-length template-string) - (open-input-string input-string) - template-string) - (if (not (date-zone-offset newdate)) - (begin - ;; this is necessary to get DST right -- as far as we can - ;; get it right (think of the double/missing hour in the - ;; night when we are switching between normal time and DST). - (set-date-zone-offset! newdate - (tm:local-tz-offset - (make-time time-utc 0 0))) - (set-date-zone-offset! newdate - (tm:local-tz-offset - (date->time-utc newdate))))) + 0 + template-string + (string-length template-string) + (open-input-string input-string) + template-string) (if (tm:date-ok? newdate) - newdate - (tm:time-error - 'string->date - 'bad-date-format-string - (list "Incomplete date read. " newdate template-string))))) -;;; srfi-19.scm ends here \ No newline at end of file + newdate + (tm:time-error 'string->date 'bad-date-format-string (list "Incomplete date read. " newdate template-string))))) +