From 5e1fb41f97dd7e6dba57d7e3646196acafcd8cee Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Wed, 23 May 2001 17:00:22 +0000 Subject: [PATCH] * srfi-19.scm (:optional): renamed to optional to avoid reader keywords conflict. Time passes... Removed :optional altogether and just handle optional args directly. Thanks to Matthias Koeppe for the report of this and the two bits below. (priv:decode-julian-day-number): add inexact->exact for truncate result. (time-utc->date): add inexact->exact and floor so quotient will work. --- srfi/srfi-19.scm | 69 ++++++++++++++++++++++++++++++------------------ 1 file changed, 44 insertions(+), 25 deletions(-) diff --git a/srfi/srfi-19.scm b/srfi/srfi-19.scm index ee51aee1a..8a398e3ad 100644 --- a/srfi/srfi-19.scm +++ b/srfi/srfi-19.scm @@ -27,7 +27,6 @@ ;; functions that do more work in a "chunk". (define-module (srfi srfi-19) - :use-module (ice-9 syncase) :use-module (srfi srfi-6) :use-module (srfi srfi-8) :use-module (srfi srfi-9) @@ -121,13 +120,6 @@ (cond-expand-provide (current-module) '(srfi-19)) -;; 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) (define time-monotonic 'time-monotonic) @@ -386,7 +378,7 @@ ;; (priv:current-time-ms-time time-gc current-gc-milliseconds)) (define (current-time . clock-type) - (let ((clock-type (optional clock-type time-utc))) + (let ((clock-type (if (null? clock-type) time-utc (car clock-type)))) (cond ((eq? clock-type time-tai) (priv:current-time-tai)) ((eq? clock-type time-utc) (priv:current-time-utc)) @@ -401,7 +393,7 @@ ;; This will be implementation specific. (define (time-resolution . clock-type) - (let ((clock-type (optional clock-type time-utc))) + (let ((clock-type (if (null? clock-type) time-utc (car clock-type)))) (case clock-type ((time-tai) 1000) ((time-utc) 1000) @@ -573,11 +565,14 @@ ;; -- 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-unnormalized nanosecond second minute - hour day month - year - zone-offset) + (make-date nanosecond second minute + hour day month + year + zone-offset) date? (nanosecond date-nanosecond) (second date-second) @@ -588,6 +583,28 @@ (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)) @@ -608,7 +625,7 @@ ;; gives the seconds/date/month/year (define (priv:decode-julian-day-number jdn) - (let* ((days (truncate jdn)) + (let* ((days (inexact->exact (truncate jdn))) (a (+ days 32044)) (b (quotient (+ (* 4 a) 3) 146097)) (c (- a (quotient (* 146097 b) 4))) @@ -642,7 +659,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 (optional tz-offset (priv:local-tz-offset))) + (let* ((offset (if (null? tz-offset) (priv:local-tz-offset) (car tz-offset))) (leap-second? (priv:leap-second? (+ offset (time-second time)))) (jdn (priv:time->julian-day-number (if leap-second? (- (time-second time) 1) @@ -651,8 +668,9 @@ (call-with-values (lambda () (priv:decode-julian-day-number jdn)) (lambda (secs date month year) - (let* ((hours (quotient secs (* 60 60))) - (rem (remainder secs (* 60 60))) + (let* ((int-secs (inexact->exact (floor secs))) + (hours (quotient int-secs (* 60 60))) + (rem (remainder int-secs (* 60 60))) (minutes (quotient rem 60)) (seconds (remainder rem 60))) (make-date (time-nanosecond time) @@ -667,7 +685,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 (optional tz-offset (priv:local-tz-offset))) + (let* ((offset (if (null? tz-offset) (priv:local-tz-offset) (car tz-offset))) (seconds (- (time-second time) (priv:leap-second-delta (time-second time)))) (leap-second? (priv:leap-second? (+ offset seconds))) @@ -695,7 +713,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 (optional tz-offset (priv:local-tz-offset))) + (let* ((offset (if (null? tz-offset) (priv:local-tz-offset) (car tz-offset))) (seconds (- (time-second time) (priv:leap-second-delta (time-second time)))) (leap-second? (priv:leap-second? (+ offset seconds))) @@ -792,8 +810,9 @@ 7)) (define (current-date . tz-offset) - (time-utc->date (current-time time-utc) - (optional tz-offset (priv:local-tz-offset)))) + (time-utc->date + (current-time time-utc) + (if (null? tz-offset) (priv:local-tz-offset) (car tz-offset)))) ;; given a 'two digit' number, find the year within 50 years +/- (define (priv:natural-year n) @@ -878,11 +897,11 @@ (time-utc->time-monotonic! (julian-day->time-utc jdn))) (define (julian-day->date jdn . tz-offset) - (let ((offset (optional tz-offset (priv:local-tz-offset)))) + (let ((offset (if (null? tz-offset) (priv:local-tz-offset) (car tz-offset)))) (time-utc->date (julian-day->time-utc jdn) offset))) (define (modified-julian-day->date jdn . tz-offset) - (let ((offset (optional tz-offset (priv:local-tz-offset)))) + (let ((offset (if (null? tz-offset) (priv:local-tz-offset) (car tz-offset)))) (julian-day->date (+ jdn 4800001/2) offset))) (define (modified-julian-day->time-utc jdn) @@ -1209,7 +1228,7 @@ (define (date->string date . format-string) (let ((str-port (open-output-string)) - (fmt-str (optional format-string "~c"))) + (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))) -- 2.20.1