* 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.

diff --git a/srfi/srfi-19.scm b/srfi/srfi-19.scm
index ee51aee..8a398e3 100644 (file)
--- 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)))