dmbcs/guile
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

* srfi-19.scm (:optional): renamed to optional to avoid reader

Browse source 
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.
This commit is contained in:
Rob Browning 2001-05-23 17:00:22 +00:00
commit 5e1fb41f97
1 changed files with 44 additions and 25 deletions
Download patch file Download diff file Expand all files Collapse all files

69
srfi/srfi-19.scm
View file

@ -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)))