reverted borken version.

git-svn-id: svn+ssh://svn.gnucash.org/repo/gnucash/trunk@4274 57a11ea4-9604-0410-9ed3-97b8803252fd

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)
+  :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>=?
-           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))
 
-(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>=?
+ 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
+  (make-date-unnormalized nanosecond second minute
-             hour day month
+                          hour day month
-             year
+                          year
-             zone-offset)
+                          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)))
+        (let* ((hours    (quotient secs (* 60 60)))
-               (hours    (quotient int-secs (* 60 60)))
+               (rem      (remainder secs (* 60 60)))
-               (rem      (remainder int-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
+  (time-utc->date (current-time time-utc)
-   (current-time time-utc)
+                  (:optional tz-offset (priv:local-tz-offset))))
-   (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)
@@ -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))
+  (call-with-output-string
-        (fmt-str (if (null? format-string) "~c" (car format-string))))
+   (lambda (str-port)
-    (priv:date-printer date 0 fmt-str (string-length fmt-str) str-port)
+     (let ((fmt-str (:optional format-string "~c")))
-    (get-output-string str-port)))
+       (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)
+  (define (read-char-string result)
-      (let ((ch (peek-char port)))
+    (let ((ch (peek-char port)))
-        (if (char-alphabetic? ch)
+      (if (char-alphabetic? ch)
-            (begin (write-char (read-char port) string-port) 
+          (read-char-string (cons (read-char port) result))
-                   (read-char-string))
+          (list->string (reverse result)))))
-            (get-output-string string-port))))
+  
-    (let* ((str (read-char-string)) 
+  (let* ((str (read-char-string '())) 
-           (index (indexer str)))
+         (index (indexer str)))
-      (if index index (priv:time-error 'string->date
+    (if index index (priv:time-error 'string->date
-                                       'bad-date-template-string
+                                     'bad-date-template-string
-                                       (list "Invalid string for " indexer))))))
+                                     (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