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

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

Save.

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 seconds->time/type
93  nanoseconds->time
94  nanoseconds->seconds
95  milliseconds->time
96  milliseconds->seconds
97  time->nanoseconds
98  time->milliseconds
99  time->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;; Time record-type operations
161
162(define (time-type tim)
163  (check-time 'time-type tim)
164  (tm:time-type tim) )
165
166(define (time-nanosecond tim)
167  (check-time 'time-nanosecond tim)
168  (tm:time-nanosecond tim) )
169
170(define (time-second tim)
171  (check-time 'time-second tim)
172  (tm:time-second tim) )
173
174(define (set-time-type! tim tt)
175  (check-time 'set-time-type! tim)
176  (check-time-type 'set-time-type! tt)
177  (tm:time-type-set! tim tt) )
178
179(define (set-time-nanosecond! tim ns)
180  (check-time 'set-time-nanosecond! tim)
181  (check-time-nanoseconds 'set-time-nanosecond! ns)
182  (tm:time-nanosecond-set! tim ns) )
183
184(define (set-time-second! tim sec)
185  (check-time 'set-time-second! tim)
186  (check-time-seconds 'set-time-second! sec)
187  (tm:time-second-set! tim sec) )
188
189;; Seconds Conversion
190
191(define (nanoseconds->time ns . args)
192  (let-optionals args ((tt 'duration))
193    (receive (ns sec)
194        (tm:nanoseconds->time-values ns)
195      (check-time-elements 'nanoseconds->time tt ns sec)
196      (tm:make-time tt ns sec) ) ) )
197
198(define (nanoseconds->seconds ns)
199  (check-real 'nanoseconds->seconds ns)
200  (tm:nanoseconds->seconds ns) )
201
202(define (milliseconds->time ms . args)
203  (check-raw-milliseconds 'milliseconds->time ms)
204  (let-optionals args ((tt 'duration))
205    (receive (ns sec)
206        (tm:milliseconds->time-values ms)
207      (check-time-elements 'milliseconds->time tt ns sec)
208      (tm:make-time tt ns sec) ) ) )
209
210(define (milliseconds->seconds ms)
211  (check-raw-milliseconds 'milliseconds->seconds ms)
212  (tm:milliseconds->seconds ms) )
213
214;; Converts a seconds value, may be fractional, into a time type.
215;; The type of time default is time-duration.
216
217(define (seconds->time sec . args)
218  (check-raw-seconds 'seconds->time/type sec)
219  (let-optionals args ((tt 'duration))
220    (check-time-type 'seconds->time/type tt)
221    (tm:seconds->time sec tt) ) )
222
223(define seconds->time/type seconds->time)
224
225(define (time->nanoseconds tim)
226  (check-time 'time->nanoseconds tim)
227  (tm:time->nanoseconds tim) )
228
229(define (time->milliseconds tim)
230  (check-time 'time->milliseconds tim)
231  (tm:time->milliseconds tim) )
232
233(define (time->seconds tim)
234  (check-time 'time->seconds tim)
235  (tm:time->seconds tim) )
236
237;; Current time routines
238
239(define (current-time . args)
240  (let-optionals args ((tt 'utc))
241    (case tt
242      ((monotonic) (tm:current-time-monotonic))
243      ((utc)       (tm:current-time-utc))
244      ((tai)       (tm:current-time-tai))
245      ((gc)        (tm:current-time-gc))
246      ((process)   (tm:current-time-process))
247      ((thread)    (tm:current-time-thread))
248      (else
249        (error-time-type 'current-time tt)) ) ) )
250
251;; -- Time Resolution
252;; This is the resolution of the clock in nanoseconds.
253;; This will be implementation specific.
254
255(define (time-resolution . args)
256  (let-optionals args ((tt 'utc))
257    (check-time-type 'time-resolution tt)
258    (tm:time-resolution tt) ) )
259
260;; SRFI-18 Routines
261
262(define (srfi-18-time->time srfi-18-tim)
263  (seconds->time (srfi-18:time->seconds srfi-18-tim) 'duration) )
264
265(define (time->srfi-18-time tim)
266  (check-time 'time->srfi-18-time tim)
267  (srfi-18:seconds->time (tm:time->seconds tim)) )
268
269;; Time Comparison
270
271(define (time-compare tim1 tim2)
272  (check-time-compare 'time-compare tim1 tim2)
273  (let ((dif (tm:time-compare tim1 tim2)))
274    (cond ((negative? dif)  -1)
275          ((positive? dif)  1)
276          (else             0) ) ) )
277
278(define (time=? tim1 tim2)
279  (check-time-compare 'time=? tim1 tim2)
280  (tm:time=? tim1 tim2) )
281
282(define (time>? tim1 tim2)
283  (check-time-compare 'time>? tim1 tim2)
284  (tm:time>? tim1 tim2) )
285
286(define (time<? tim1 tim2)
287  (check-time-compare 'time<? tim1 tim2)
288  (tm:time<? tim1 tim2) )
289
290(define (time>=? tim1 tim2)
291  (check-time-compare 'time>=? tim1 tim2)
292  (tm:time>=? tim1 tim2) )
293
294(define (time<=? tim1 tim2)
295  (check-time-compare 'time<=? tim1 tim2)
296  (tm:time<=? tim1 tim2) )
297
298(define (time-max tim1 . rest)
299  (check-time 'time-max tim1)
300  (let ((tt (tm:time-type tim1)))
301    (let loop ((acc tim1) (ls rest))
302      (if (null? ls) acc
303          (let ((tim (car ls)))
304            (check-time-and-type 'time-max tim tt)
305            (loop (tm:time-max acc tim) (cdr ls)) ) ) ) ) )
306
307(define (time-min tim1 . rest)
308  (check-time 'time-min tim1)
309  (let ((tt (tm:time-type tim1)))
310    (let loop ((acc tim1) (ls rest))
311      (if (null? ls) acc
312          (let ((tim (car ls)))
313            (check-time-and-type 'time-min tim tt)
314            (loop (tm:time-min acc tim) (cdr ls)) ) ) ) ) )
315
316;; Time Arithmetic
317
318(define (time-difference tim1 tim2)
319  (check-time-compare 'time-difference tim1 tim2)
320  (tm:time-difference tim1 tim2 (tm:some-time 'duration)) )
321
322(define (add-duration tim dur)
323  (check-time-aritmetic 'add-duration tim dur)
324  (tm:add-duration tim dur (tm:as-some-time tim)) )
325
326(define (subtract-duration tim dur)
327  (check-time-aritmetic 'subtract-duration tim dur)
328  (tm:subtract-duration tim dur (tm:as-some-time tim)) )
329
330(define (divide-duration dur num)
331  (check-duration 'divide-duration dur)
332  (tm:divide-duration dur num (tm:some-time 'duration)) )
333
334(define (multiply-duration dur num)
335  (check-duration 'multiply-duration dur)
336  (tm:multiply-duration dur num (tm:some-time 'duration)) )
337
338(define (time-abs tim)
339  (check-time 'time-abs tim)
340  (tm:time-abs tim (tm:as-some-time tim)) )
341
342(define (time-negate tim)
343  (check-time 'time-negate tim)
344  (tm:time-negate tim (tm:as-some-time tim)) )
345
346;;
347
348(define (time-difference! tim1 tim2)
349  (check-time-compare 'time-difference! tim1 tim2)
350  (tm:time-difference tim1 tim2 tim1) )
351
352(define (add-duration! tim dur)
353  (check-time-aritmetic 'add-duration! tim dur)
354  (tm:add-duration tim dur tim) )
355
356(define (subtract-duration! tim dur)
357  (check-time-aritmetic 'subtract-duration! tim dur)
358  (tm:subtract-duration tim dur tim) )
359
360(define (divide-duration! dur num)
361  (check-duration 'divide-duration! dur)
362  (tm:divide-duration dur num dur) )
363
364(define (multiply-duration! dur num)
365  (check-duration 'multiply-duration! dur)
366  (tm:multiply-duration dur num dur) )
367
368(define (time-abs! tim)
369  (check-time 'time-abs! tim)
370  (tm:time-abs tim tim) )
371
372(define (time-negate! tim)
373  (check-time 'time-negate! tim)
374  (tm:time-negate tim tim) )
375
376;;
377
378(define (time-negative? tim)
379  (check-time 'time-negative? tim)
380  ;nanoseconds irrelevant
381  (negative? (tm:time-second tim)) )
382
383(define (time-positive? tim)
384  (check-time 'time-positive? tim)
385  ;nanoseconds irrelevant
386  (positive? (tm:time-second tim)) )
387
388(define (time-zero? tim)
389  (check-time 'time-zero? tim)
390  (and (zero? (tm:time-nanosecond tim))
391       (zero? (tm:time-second tim))) )
392
393;; Time Type Conversion
394
395;;
396
397(define (time-tai->time-utc tim)
398  (check-time-and-type 'time-tai->time-utc tim 'tai)
399  (tm:time-tai->time-utc tim (tm:any-time)) )
400
401(define (time-tai->time-monotonic tim)
402  (check-time-and-type 'time-tai->time-monotonic tim 'tai)
403  (tm:time-tai->time-monotonic tim (tm:any-time)) )
404
405(define (time-utc->time-tai tim)
406  (check-time-and-type 'time-utc->time-tai tim 'utc)
407  (tm:time-utc->time-tai tim (tm:any-time)) )
408
409(define (time-utc->time-monotonic tim)
410  (check-time-and-type 'time-utc->time-monotonic tim 'utc)
411  (tm:time-utc->time-monotonic tim (tm:any-time)) )
412
413(define (time-monotonic->time-utc tim)
414  (check-time-and-type 'time-monotoinc->time-utc tim 'monotonic)
415  (let ((ntim (tm:copy-time tim)))
416    (tm:time-monotonic->time-utc ntim ntim) ) )
417
418(define (time-monotonic->time-tai tim)
419  (check-time-and-type 'time-monotoinc->time-tai tim 'monotonic)
420  (tm:time-monotonic->time-tai tim (tm:any-time)) )
421
422;;
423
424(define (time-tai->time-utc! tim)
425  (check-time-and-type 'time-tai->time-utc! tim 'tai)
426  (tm:time-tai->time-utc tim tim) )
427
428(define (time-tai->time-monotonic! tim)
429  (check-time-and-type 'time-tai->time-monotonic! tim 'tai)
430  (tm:time-tai->time-monotonic tim tim) )
431
432(define (time-utc->time-tai! tim)
433  (check-time-and-type 'time-utc->time-tai! tim 'utc)
434  (tm:time-utc->time-tai tim tim) )
435
436(define (time-utc->time-monotonic! tim)
437  (check-time-and-type 'time-utc->time-monotonic! tim 'utc)
438  (tm:time-utc->time-monotonic tim tim) )
439
440(define (time-monotonic->time-utc! tim)
441  (check-time-and-type 'time-monotoinc->time-utc! tim 'monotonic)
442  (tm:time-monotonic->time-utc tim tim) )
443
444(define (time-monotonic->time-tai! tim)
445  (check-time-and-type 'time-monotoinc->time-tai! tim 'monotonic)
446  (tm:time-monotonic->time-tai tim tim) )
447
448) ;module srfi-19-time
Note: See TracBrowser for help on using the repository browser.