SRFI-19 patch, or: strange syncase implications

[Matthias Koeppe]

I tried to actually use the new SRFI-19 (time/date) module but found
several problems.

 1)  The implementation expects `quotient' to work on a inexact real
     first argument, though R5RS only defines behavior for integer
     arguments.  Since Guile follows R5RS here, I had to fix a few
     calls to `quotient'; see the patch below.

 2)  For some reason, in the definition of the `date' record type,
     `make-date-unnormalized' was made the constructor, but
     `make-date' was used everywhere; see the patch below.

 3)  The implementation uses a simple syntax definition to provide a
     syntax for extracting optional arguments, but this seems to cause
     breakage.  In the patch, I have used (ice-9 optargs) instead of
     (ice-9 syncase) for handling optional arguments in order to work
     around the problem.

Here is information on how to reproduce the syntax-rules breakage (with
the unpatched srfi-19.scm):  Type

        (date->string (make-date-unnormalized 0 1 2 3 4 5 6 7) "~Y")

Guile hangs until interrupted.  No backtrace is available.  Once (I
think I was tracing `priv:date-printer'), I got 

        "lazy-catch handler did return."

I believe this must be related to the syncase system because the
problems went away when I used (ice-9 optargs) instead of (ice-9
syncase).

Index: srfi/srfi-19.scm
===================================================================
RCS file: /cvs/guile/guile-core/srfi/srfi-19.scm,v
retrieving revision 1.3
diff -u -r1.3 srfi-19.scm
--- srfi/srfi-19.scm    2001/05/23 05:04:55     1.3
+++ srfi/srfi-19.scm    2001/05/23 14:33:25
@@ -27,7 +27,7 @@
 ;; functions that do more work in a "chunk".
 
 (define-module (srfi srfi-19)
-  :use-module (ice-9 syncase)
+  :use-module (ice-9 optargs)
   :use-module (srfi srfi-6)
   :use-module (srfi srfi-8)
   :use-module (srfi srfi-9)
@@ -121,13 +121,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)
@@ -385,8 +378,7 @@
 ;;(define (priv:current-time-gc)
 ;;  (priv:current-time-ms-time time-gc current-gc-milliseconds))
 
-(define (current-time . clock-type)
-  (let ((clock-type (:optional clock-type time-utc)))
+(define* (current-time #:optional (clock-type time-utc))
     (cond
      ((eq? clock-type time-tai) (priv:current-time-tai))
      ((eq? clock-type time-utc) (priv:current-time-utc))
@@ -394,14 +386,13 @@
      ((eq? clock-type time-thread) (priv:current-time-thread))
      ((eq? clock-type time-process) (priv:current-time-process))
      ;;     ((eq? clock-type time-gc) (priv:current-time-gc))
-     (else (priv:time-error 'current-time 'invalid-clock-type clock-type)))))
+     (else (priv: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.
 
-(define (time-resolution . clock-type)
-  (let ((clock-type (:optional clock-type time-utc)))
+(define* (time-resolution #:optional (clock-type time-utc))
     (case clock-type
       ((time-tai) 1000)
       ((time-utc) 1000)
@@ -409,7 +400,7 @@
       ((time-process) priv:ns-per-guile-tick)
       ;;     ((eq? clock-type time-thread) 1000)
       ;;     ((eq? clock-type time-gc) 10000)
-      (else (priv:time-error 'time-resolution 'invalid-clock-type 
clock-type)))))
+      (else (priv:time-error 'time-resolution 'invalid-clock-type 
clock-type))))
 
 ;; -- Time comparisons
 
@@ -574,7 +565,7 @@
 ;; -- Date Structures
 
 (define-record-type date
-  (make-date-unnormalized nanosecond second minute
+  (make-date nanosecond second minute
                           hour day month
                           year
                           zone-offset)
@@ -608,7 +599,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)))
@@ -639,11 +630,10 @@
 (define (priv:leap-second? second)
   (and (assoc second priv:leap-second-table) #t))
 
-(define (time-utc->date time . tz-offset)
+(define* (time-utc->date time #:optional (offset (priv:local-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)))
-         (leap-second? (priv:leap-second? (+ offset (time-second time))))
+  (let* ((leap-second? (priv:leap-second? (+ offset (time-second time))))
          (jdn (priv:time->julian-day-number (if leap-second?
                                                 (- (time-second time) 1)
                                                 (time-second time))
@@ -651,8 +641,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)
@@ -664,11 +655,10 @@
                      year
                      offset))))))
 
-(define (time-tai->date time  . tz-offset)
+(define* (time-tai->date time #:optional (offset (priv:local-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)))
-         (seconds (- (time-second time)
+  (let* ((seconds (- (time-second time)
                      (priv:leap-second-delta (time-second time))))
          (leap-second? (priv:leap-second? (+ offset seconds)))
          (jdn (priv:time->julian-day-number (if leap-second?
@@ -692,11 +682,10 @@
                      offset))))))
 
 ;; this is the same as time-tai->date.
-(define (time-monotonic->date time . tz-offset)
+(define* (time-monotonic->date time #:optional (offset (priv:local-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)))
-         (seconds (- (time-second time)
+  (let* ((seconds (- (time-second time)
                      (priv:leap-second-delta (time-second time))))
          (leap-second? (priv:leap-second? (+ offset seconds)))
          (jdn (priv:time->julian-day-number (if leap-second?
@@ -791,9 +780,9 @@
                (priv:days-before-first-week  date day-of-week-starting-week))
             7))
 
-(define (current-date . tz-offset) 
+(define* (current-date #:optional (offset (priv:local-tz-offset)))
   (time-utc->date (current-time time-utc)
-                  (:optional tz-offset (priv:local-tz-offset))))
+                 offset))
 
 ;; given a 'two digit' number, find the year within 50 years +/-
 (define (priv:natural-year n)
@@ -876,14 +865,12 @@
 
 (define (julian-day->time-monotonic jdn)
   (time-utc->time-monotonic! (julian-day->time-utc jdn)))
+
+(define* (julian-day->date jdn #:optional (offset (priv:local-tz-offset)))
+  (time-utc->date (julian-day->time-utc jdn) offset))
 
-(define (julian-day->date jdn . 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 (:optional tz-offset (priv:local-tz-offset))))
-    (julian-day->date (+ jdn 4800001/2) offset)))
+(define* (modified-julian-day->date jdn #:optional (offset 
(priv:local-tz-offset)))
+  (julian-day->date (+ jdn 4800001/2) offset))
 
 (define (modified-julian-day->time-utc jdn)
   (julian-day->time-utc (+ jdn 4800001/2)))
@@ -1142,7 +1129,7 @@
   (if (>= index str-len)
       (values)
       (let ((current-char (string-ref format-string index)))
-        (if (not (char=? current-char #\~))
+         (if (not (char=? current-char #\~))
             (begin
               (display current-char port)
               (priv:date-printer date (+ index 1) format-string str-len port))
@@ -1207,11 +1194,11 @@
                                                port))))))))))))
 
 
-(define (date->string date .  format-string)
-  (let ((str-port (open-output-string))
-        (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* (date->string date #:optional (format-string "~c"))
+  (with-output-to-string
+    (lambda ()
+      (priv:date-printer date 0 format-string (string-length format-string)
+                        (current-output-port)))))
 
 (define (priv:char->int ch)
   (case ch


-- 
Matthias Köppe -- http://www.math.uni-magdeburg.de/~mkoeppe