source: project/release/4/srfi-19/trunk/srfi-19-time.scm @ 15755

Last change on this file since 15755 was 15755, checked in by Kon Lovett, 11 years ago

Split into time & date modules.

File size: 12.8 KB
Line 
1;;;; srfi-19-time.scm
2;;;; Chicken port, Kon Lovett, Dec '05
3
4;; SRFI-19: Time Data Types and Procedures.
5;;
6;; Copyright (C) I/NET, Inc. (2000, 2002, 2003). All Rights Reserved.
7;; Copyright (C) Neodesic Corporation (2000). All Rights Reserved.
8;;
9;; This document and translations of it may be copied and furnished to others,
10;; and derivative works that comment on or otherwise explain it or assist in its
11;; implementation may be prepared, copied, published and distributed, in whole or
12;; in part, without restriction of any kind, provided that the above copyright
13;; notice and this paragraph are included on all such copies and derivative works.
14;; However, this document itself may not be modified in any way, such as by
15;; removing the copyright notice or references to the Scheme Request For
16;; Implementation process or editors, except as needed for the purpose of
17;; developing SRFIs in which case the procedures for copyrights defined in the SRFI
18;; process must be followed, or as required to translate it into languages other
19;; than English.
20;;
21;; The limited permissions granted above are perpetual and will not be revoked
22;; by the authors or their successors or assigns.
23;;
24;; This document and the information contained herein is provided on an "AS IS"
25;; basis and THE AUTHOR AND THE SRFI EDITORS DISCLAIM ALL WARRANTIES, EXPRESS OR
26;; IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTY THAT THE USE OF THE
27;; INFORMATION HEREIN WILL NOT INFRINGE ANY RIGHTS OR ANY IMPLIED WARRANTIES OF
28;; MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
29
30(module srfi-19-time (;export
31  ; SRFI-19
32  time-tai
33  time-utc
34  time-monotonic
35  time-thread
36  time-process
37  time-duration
38  time-gc
39  current-time
40  time-resolution
41  make-time
42  time-type
43  time-nanosecond
44  time-second
45  set-time-type!
46  set-time-nanosecond!
47  set-time-second!
48  copy-time
49  time<=?
50  time<?
51  time=?
52  time>=?
53  time>?
54  time-difference
55  time-difference!
56  add-duration
57  add-duration!
58  subtract-duration
59  subtract-duration!
60  time-monotonic->time-tai
61  time-monotonic->time-tai!
62  time-monotonic->time-utc
63  time-monotonic->time-utc!
64  time-tai->time-monotonic
65  time-tai->time-monotonic!
66  time-tai->time-utc
67  time-tai->time-utc!
68  time-utc->time-monotonic
69  time-utc->time-monotonic!
70  time-utc->time-tai
71  time-utc->time-tai!
72  ; Extensions
73  one-second-duration
74  one-nanosecond-duration
75  zero-time
76  make-duration
77  divide-duration
78  divide-duration!
79  multiply-duration
80  multiply-duration!
81  time->srfi-18-time
82  srfi-18-time->time
83  time-max
84  time-min
85  time-negative?
86  time-positive?
87  time-zero?
88  time-abs
89  time-abs!
90  time-negate
91  time-negate!
92  seconds->time/type
93  time->nanoseconds
94  nanoseconds->time
95  nanoseconds->seconds
96  time->milliseconds
97  time->seconds
98  milliseconds->time
99  milliseconds->seconds
100  time-compare)
101
102  (import (except scheme zero? negative? positive? real?)
103          chicken
104          #;srfi-8
105          #;(only srfi-18 seconds->time time->seconds)
106          (prefix srfi-18 srfi-18:)
107          (only numbers zero? negative? positive? real?)
108          miscmacros
109          type-checks
110          type-errors
111          srfi-19-support)
112
113  (require-library #;srfi-8 srfi-18 numbers miscmacros
114                   type-checks type-errors
115                   srfi-19-support)
116
117;;;
118
119;; Time Type Constants (not used internally)
120
121(define time-duration   'duration)
122(define time-gc         'gc)
123(define time-monotonic  'monotonic)
124(define time-process    'process)
125(define time-tai        'tai)
126(define time-thread     'thread)
127(define time-utc        'utc)
128
129;; Time CTORs
130
131(define (one-second-duration) (tm:make-time 'duration 0 1))
132(define (one-nanosecond-duration) (tm:make-time 'duration 1 0))
133(define (zero-time tt) (check-time-type 'zero-time tt) (tm:make-time tt 0 0))
134
135(define (make-time tt ns sec)
136  (check-time-elements 'make-time tt ns sec)
137  (tm:make-time tt ns sec) )
138
139(define (make-duration
140          #!key (days 0)
141                (hours 0) (minutes 0) (seconds 0)
142                (milliseconds 0) (microseconds 0) (nanoseconds 0))
143  (check-real 'make-duration days "days")
144  (check-real 'make-duration hours "hours")
145  (check-real 'make-duration minutes "minutes")
146  (check-real 'make-duration seconds "seconds")
147  (check-real 'make-duration milliseconds "milliseconds")
148  (check-real 'make-duration microseconds "microseconds")
149  (check-real 'make-duration nanoseconds "nanoseconds")
150  (receive (ns sec)
151      (tm:duration-elements->time-values days hours minutes seconds
152                                         milliseconds microseconds nanoseconds)
153    (check-time-elements 'make-duration 'duration ns sec)
154    (tm:make-time 'duration ns sec) ) )
155
156(define (copy-time tim)
157  (check-time 'copy-time tim)
158  (tm:copy-time tim) )
159
160;; Converts a seconds value, may be fractional, into a time type.
161;; The type of time default is time-duration.
162
163(define (seconds->time/type sec . args)
164  (check-raw-seconds 'seconds->time/type sec)
165  (let-optionals args ((tt 'duration))
166    (check-time-type 'seconds->time/type tt)
167    (tm:seconds->time sec tt) ) )
168
169;; Time record-type operations
170
171(define (time-type tim)
172  (check-time 'time-type tim)
173  (tm:time-type tim) )
174
175(define (time-nanosecond tim)
176  (check-time 'time-nanosecond tim)
177  (tm:time-nanosecond tim) )
178
179(define (time-second tim)
180  (check-time 'time-second tim)
181  (tm:time-second tim) )
182
183(define (set-time-type! tim tt)
184  (check-time 'set-time-type! tim)
185  (check-time-type 'set-time-type! tt)
186  (tm:time-type-set! tim tt) )
187
188(define (set-time-nanosecond! tim ns)
189  (check-time 'set-time-nanosecond! tim)
190  (check-time-nanoseconds 'set-time-nanosecond! ns)
191  (tm:time-nanosecond-set! tim ns) )
192
193(define (set-time-second! tim sec)
194  (check-time 'set-time-second! tim)
195  (check-time-seconds 'set-time-second! sec)
196  (tm:time-second-set! tim sec) )
197
198;; Seconds Conversion
199
200(define (nanoseconds->time ns . args)
201  (let-optionals args ((tt 'duration))
202    (receive (ns sec)
203        (tm:nanoseconds->time-values ns)
204      (check-time-elements 'nanoseconds->time tt ns sec)
205      (tm:make-time tt ns sec) ) ) )
206
207(define (nanoseconds->seconds ns)
208  (check-real 'nanoseconds->seconds ns)
209  (tm:nanoseconds->seconds ns) )
210
211(define (milliseconds->time ms . args)
212  (check-raw-milliseconds 'milliseconds->time ms)
213  (let-optionals args ((tt 'duration))
214    (receive (ns sec)
215        (tm:milliseconds->time-values ms)
216      (check-time-elements 'milliseconds->time tt ns sec)
217      (tm:make-time tt ns sec) ) ) )
218
219(define (milliseconds->seconds ms)
220  (check-raw-milliseconds 'milliseconds->seconds ms)
221  (tm:milliseconds->seconds ms) )
222
223(define (time->nanoseconds tim)
224  (check-time 'time->nanoseconds tim)
225  (tm:time->nanoseconds tim) )
226
227(define (time->milliseconds tim)
228  (check-time 'time->milliseconds tim)
229  (tm:time->milliseconds tim) )
230
231(define (time->seconds tim)
232  (check-time 'time->seconds tim)
233  (tm:time->seconds tim) )
234
235;; Current time routines
236
237(define (current-time . args)
238  (let-optionals args ((tt 'utc))
239    (case tt
240      ((monotonic) (tm:current-time-monotonic))
241      ((utc)       (tm:current-time-utc))
242      ((tai)       (tm:current-time-tai))
243      ((gc)        (tm:current-time-gc))
244      ((process)   (tm:current-time-process))
245      ((thread)    (tm:current-time-thread))
246      (else
247        (error-time-type 'current-time tt)) ) ) )
248
249;; -- Time Resolution
250;; This is the resolution of the clock in nanoseconds.
251;; This will be implementation specific.
252
253(define (time-resolution . args)
254  (let-optionals args ((tt 'utc))
255    (check-time-type 'time-resolution tt)
256    (tm:time-resolution tt) ) )
257
258;; SRFI-18 Routines
259
260(define (srfi-18-time->time srfi-18-tim)
261  (seconds->time/type (srfi-18:time->seconds srfi-18-tim) 'duration) )
262
263(define (time->srfi-18-time tim)
264  (check-time 'time->srfi-18-time tim)
265  (srfi-18:seconds->time (tm:time->seconds tim)) )
266
267;; Time Comparison
268
269(define (time-compare tim1 tim2)
270  (check-time-compare 'time-compare tim1 tim2)
271  (let ((dif (tm:time-compare tim1 tim2)))
272    (cond ((negative? dif)  -1)
273          ((positive? dif)  1)
274          (else             0) ) ) )
275
276(define (time=? tim1 tim2)
277  (check-time-compare 'time=? tim1 tim2)
278  (tm:time=? tim1 tim2) )
279
280(define (time>? tim1 tim2)
281  (check-time-compare 'time>? tim1 tim2)
282  (tm:time>? tim1 tim2) )
283
284(define (time<? tim1 tim2)
285  (check-time-compare 'time<? tim1 tim2)
286  (tm:time<? tim1 tim2) )
287
288(define (time>=? tim1 tim2)
289  (check-time-compare 'time>=? tim1 tim2)
290  (tm:time>=? tim1 tim2) )
291
292(define (time<=? tim1 tim2)
293  (check-time-compare 'time<=? tim1 tim2)
294  (tm:time<=? tim1 tim2) )
295
296(define (time-max tim1 . rest)
297  (check-time 'time-max tim1)
298  (let ((tt (tm:time-type tim1)))
299    (let loop ((acc tim1) (ls rest))
300      (if (null? ls) acc
301          (let ((tim (car ls)))
302            (check-time-and-type 'time-max tim tt)
303            (loop (tm:time-max acc tim) (cdr ls)) ) ) ) ) )
304
305(define (time-min tim1 . rest)
306  (check-time 'time-min tim1)
307  (let ((tt (tm:time-type tim1)))
308    (let loop ((acc tim1) (ls rest))
309      (if (null? ls) acc
310          (let ((tim (car ls)))
311            (check-time-and-type 'time-min tim tt)
312            (loop (tm:time-min acc tim) (cdr ls)) ) ) ) ) )
313
314;; Time Arithmetic
315
316(define (time-difference tim1 tim2)
317  (check-time-compare 'time-difference tim1 tim2)
318  (tm:time-difference tim1 tim2 (tm:some-time 'duration)) )
319
320(define (add-duration tim dur)
321  (check-time-aritmetic 'add-duration tim dur)
322  (tm:add-duration tim dur (tm:as-some-time tim)) )
323
324(define (subtract-duration tim dur)
325  (check-time-aritmetic 'subtract-duration tim dur)
326  (tm:subtract-duration tim dur (tm:as-some-time tim)) )
327
328(define (divide-duration dur num)
329  (check-duration 'divide-duration dur)
330  (tm:divide-duration dur num (tm:some-time 'duration)) )
331
332(define (multiply-duration dur num)
333  (check-duration 'multiply-duration dur)
334  (tm:multiply-duration dur num (tm:some-time 'duration)) )
335
336(define (time-abs tim)
337  (check-time 'time-abs tim)
338  (tm:time-abs tim (tm:as-some-time tim)) )
339
340(define (time-negate tim)
341  (check-time 'time-negate tim)
342  (tm:time-negate tim (tm:as-some-time tim)) )
343
344;;
345
346(define (time-difference! tim1 tim2)
347  (check-time-compare 'time-difference! tim1 tim2)
348  (tm:time-difference tim1 tim2 tim1) )
349
350(define (add-duration! tim dur)
351  (check-time-aritmetic 'add-duration! tim dur)
352  (tm:add-duration tim dur tim) )
353
354(define (subtract-duration! tim dur)
355  (check-time-aritmetic 'subtract-duration! tim dur)
356  (tm:subtract-duration tim dur tim) )
357
358(define (divide-duration! dur num)
359  (check-duration 'divide-duration! dur)
360  (tm:divide-duration dur num dur) )
361
362(define (multiply-duration! dur num)
363  (check-duration 'multiply-duration! dur)
364  (tm:multiply-duration dur num dur) )
365
366(define (time-abs! tim)
367  (check-time 'time-abs! tim)
368  (tm:time-abs tim tim) )
369
370(define (time-negate! tim)
371  (check-time 'time-negate! tim)
372  (tm:time-negate tim tim) )
373
374;;
375
376(define (time-negative? tim)
377  (check-time 'time-negative? tim)
378  ;nanoseconds irrelevant
379  (negative? (tm:time-second tim)) )
380
381(define (time-positive? tim)
382  (check-time 'time-positive? tim)
383  ;nanoseconds irrelevant
384  (positive? (tm:time-second tim)) )
385
386(define (time-zero? tim)
387  (check-time 'time-zero? tim)
388  (and (zero? (tm:time-nanosecond tim))
389       (zero? (tm:time-second tim))) )
390
391;; Time Type Conversion
392
393;;
394
395(define (time-tai->time-utc tim)
396  (check-time-and-type 'time-tai->time-utc tim 'tai)
397  (tm:time-tai->time-utc tim (tm:any-time)) )
398
399(define (time-tai->time-monotonic tim)
400  (check-time-and-type 'time-tai->time-monotonic tim 'tai)
401  (tm:time-tai->time-monotonic tim (tm:any-time)) )
402
403(define (time-utc->time-tai tim)
404  (check-time-and-type 'time-utc->time-tai tim 'utc)
405  (tm:time-utc->time-tai tim (tm:any-time)) )
406
407(define (time-utc->time-monotonic tim)
408  (check-time-and-type 'time-utc->time-monotonic tim 'utc)
409  (tm:time-utc->time-monotonic tim (tm:any-time)) )
410
411(define (time-monotonic->time-utc tim)
412  (check-time-and-type 'time-monotoinc->time-utc tim 'monotonic)
413  (let ((ntim (tm:copy-time tim)))
414    (tm:time-monotonic->time-utc ntim ntim) ) )
415
416(define (time-monotonic->time-tai tim)
417  (check-time-and-type 'time-monotoinc->time-tai tim 'monotonic)
418  (tm:time-monotonic->time-tai tim (tm:any-time)) )
419
420;;
421
422(define (time-tai->time-utc! tim)
423  (check-time-and-type 'time-tai->time-utc! tim 'tai)
424  (tm:time-tai->time-utc tim tim) )
425
426(define (time-tai->time-monotonic! tim)
427  (check-time-and-type 'time-tai->time-monotonic! tim 'tai)
428  (tm:time-tai->time-monotonic tim tim) )
429
430(define (time-utc->time-tai! tim)
431  (check-time-and-type 'time-utc->time-tai! tim 'utc)
432  (tm:time-utc->time-tai tim tim) )
433
434(define (time-utc->time-monotonic! tim)
435  (check-time-and-type 'time-utc->time-monotonic! tim 'utc)
436  (tm:time-utc->time-monotonic tim tim) )
437
438(define (time-monotonic->time-utc! tim)
439  (check-time-and-type 'time-monotoinc->time-utc! tim 'monotonic)
440  (tm:time-monotonic->time-utc tim tim) )
441
442(define (time-monotonic->time-tai! tim)
443  (check-time-and-type 'time-monotoinc->time-tai! tim 'monotonic)
444  (tm:time-monotonic->time-tai tim tim) )
445
446) ;module srfi-19-time
Note: See TracBrowser for help on using the repository browser.