;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;;; Boston, MA 02111-1307 USA
;;;
+;;; As a special exception, the Free Software Foundation gives permission
+;;; for additional uses of the text contained in its release of GUILE.
+;;;
+;;; The exception is that, if you link the GUILE library with other files
+;;; to produce an executable, this does not by itself cause the
+;;; resulting executable to be covered by the GNU General Public License.
+;;; Your use of that executable is in no way restricted on account of
+;;; linking the GUILE library code into it.
+;;;
+;;; This exception does not however invalidate any other reasons why
+;;; the executable file might be covered by the GNU General Public License.
+;;;
+;;; This exception applies only to the code released by the
+;;; Free Software Foundation under the name GUILE. If you copy
+;;; code from other Free Software Foundation releases into a copy of
+;;; GUILE, as the General Public License permits, the exception does
+;;; not apply to the code that you add in this way. To avoid misleading
+;;; anyone as to the status of such modified files, you must delete
+;;; this exception notice from them.
+;;;
+;;; If you write modifications of your own for GUILE, it is your choice
+;;; whether to permit this exception to apply to your modifications.
+;;; If you do not wish that, delete this exception notice.
+;;;
;;; Originally from SRFI reference implementation by Will Fitzgerald.
;;; Ported to Guile by Rob Browning <rlb@cs.utexas.edu>
;; 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)
date->string
string->date))
-;; :OPTIONAL is nice
-
-(define-syntax :optional
- (syntax-rules ()
- ((_ val default-value)
- (if (null? val) default-value (car val)))))
+(cond-expand-provide (current-module) '(srfi-19))
(define time-tai 'time-tai)
(define time-utc 'time-utc)
;; (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))
;; 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)
;; -- 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)
(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))
;; 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)))
(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)
(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)
(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)))
(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)))
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)
(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)
(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)))
(let ((padding-ok #t))
(define (accum-int port accum nchars)
(let ((ch (peek-char port)))
- (cond
- ((>= nchars n) accum)
- ((eof-object? ch)
- (priv:time-error 'string->date 'bad-date-template-string
+ (cond
+ ((>= nchars n) accum)
+ ((eof-object? ch)
+ (priv: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) (priv:char->int (read-char
- port)))
- (+ nchars 1)))
- (padding-ok
- (read-ch port) ; consume padding
- (accum-int prot accum (+ nchars 1)))
- (else ; padding where it shouldn't be
- (priv:time-error 'string->date 'bad-date-template-string
+ ((char-numeric? ch)
+ (set! padding-ok #f)
+ (accum-int port
+ (+ (* accum 10) (priv: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
+ (priv:time-error 'string->date 'bad-date-template-string
"Non-numeric characters in integer read.")))))
(accum-int port 0 0)))