source: project/release/5/srfi-19/tags/4.1.0/srfi-19-time.scm @ 38113

Last change on this file since 38113 was 38113, checked in by Kon Lovett, 6 weeks ago

rel 4.1.0

File size: 12.5 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
31
32(;export
33  ;;SRFI-19
34  time-tai
35  time-utc
36  time-monotonic
37  time-thread
38  time-process
39  time-duration
40  time-gc
41  current-time
42  time-resolution
43  make-time
44  time-type
45  time-nanosecond
46  time-second
47  set-time-type!
48  set-time-nanosecond!
49  set-time-second!
50  copy-time
51  time<=?
52  time<?
53  time=?
54  time>=?
55  time>?
56  time-difference
57  time-difference!
58  add-duration
59  add-duration!
60  subtract-duration
61  subtract-duration!
62  time-monotonic->time-tai
63  time-monotonic->time-tai!
64  time-monotonic->time-utc
65  time-monotonic->time-utc!
66  time-tai->time-monotonic
67  time-tai->time-monotonic!
68  time-tai->time-utc
69  time-tai->time-utc!
70  time-utc->time-monotonic
71  time-utc->time-monotonic!
72  time-utc->time-tai
73  time-utc->time-tai!
74  ;;Extensions
75  time-record-printer-format
76  one-second-duration
77  one-nanosecond-duration
78  zero-time
79  make-duration
80  divide-duration
81  divide-duration!
82  multiply-duration
83  multiply-duration!
84  time->srfi-18-time
85  srfi-18-time->time
86  time-max
87  time-min
88  time-negative?
89  time-positive?
90  time-zero?
91  time-abs
92  time-abs!
93  time-negate
94  time-negate!
95  seconds->time
96  nanoseconds->time
97  nanoseconds->seconds
98  milliseconds->time
99  milliseconds->seconds
100  time->nanoseconds
101  time->milliseconds
102  time->seconds
103  time-compare)
104
105(import scheme)
106(import (chicken base))
107(import (prefix (only srfi-18 seconds->time time->seconds) srfi-18:))
108#;(import srfi-8)
109(import miscmacros)
110(import type-checks)
111(import type-errors)
112(import srfi-19-support)
113
114;;;
115
116;; Time Type Constants (not used internally)
117
118(define time-duration   'duration)
119(define time-gc         'gc)
120(define time-monotonic  'monotonic)
121(define time-process    'process)
122(define time-tai        'tai)
123(define time-thread     'thread)
124(define time-utc        'utc)
125
126;; Time CTORs
127
128(define (one-second-duration) (tm:make-time 'duration 0 1))
129(define (one-nanosecond-duration) (tm:make-time 'duration 1 0))
130(define (zero-time tt) (check-time-type 'zero-time tt) (tm:make-time tt 0 0))
131
132(define (make-time tt ns sec)
133  (check-time-elements 'make-time tt ns sec)
134  (tm:make-time tt ns sec) )
135
136(define (make-duration
137          #!key (days 0)
138                (hours 0) (minutes 0) (seconds 0)
139                (milliseconds 0) (microseconds 0) (nanoseconds 0))
140  (check-real 'make-duration days "days")
141  (check-real 'make-duration hours "hours")
142  (check-real 'make-duration minutes "minutes")
143  (check-real 'make-duration seconds "seconds")
144  (check-real 'make-duration milliseconds "milliseconds")
145  (check-real 'make-duration microseconds "microseconds")
146  (check-real 'make-duration nanoseconds "nanoseconds")
147  (receive (ns sec)
148      (tm:duration-elements->time-values days hours minutes seconds
149                                         milliseconds microseconds nanoseconds)
150    (check-time-elements 'make-duration 'duration ns sec)
151    (tm:make-time 'duration ns sec) ) )
152
153(define (copy-time tim)
154  (tm:copy-time (check-time 'copy-time tim)) )
155
156;; Time record-type operations
157
158(define (time-type tim)
159  (tm:time-type (check-time 'time-type tim)) )
160
161(define (time-nanosecond tim)
162  (tm:time-nanosecond (check-time 'time-nanosecond tim)) )
163
164(define (time-second tim)
165  (tm:time-second (check-time 'time-second tim)) )
166
167(define (set-time-type! tim tt)
168  (tm:time-type-set!
169    (check-time 'set-time-type! tim)
170    (check-time-type 'set-time-type! tt)) )
171
172(define (set-time-nanosecond! tim ns)
173  (tm:time-nanosecond-set!
174    (check-time 'set-time-nanosecond! tim)
175    (check-time-nanoseconds 'set-time-nanosecond! ns)) )
176
177(define (set-time-second! tim sec)
178  (tm:time-second-set!
179    (check-time 'set-time-second! tim)
180    (check-time-seconds 'set-time-second! sec)) )
181
182;; Seconds Conversion
183
184(define (nanoseconds->time ns . args)
185  (let-optionals args ((tt 'duration))
186    (receive (ns sec) (tm:nanoseconds->time-values ns)
187      (check-time-elements 'nanoseconds->time tt ns sec)
188      (tm:make-time tt ns sec) ) ) )
189
190(define (nanoseconds->seconds ns)
191  (tm:nanoseconds->seconds (check-real 'nanoseconds->seconds ns)) )
192
193(define (milliseconds->time ms . args)
194  (check-raw-milliseconds 'milliseconds->time ms)
195  (let-optionals args ((tt 'duration))
196    (receive (ns sec) (tm:milliseconds->time-values ms)
197      (check-time-elements 'milliseconds->time tt ns sec)
198      (tm:make-time tt ns sec) ) ) )
199
200(define (milliseconds->seconds ms)
201  (check-raw-milliseconds 'milliseconds->seconds ms)
202  (tm:milliseconds->seconds ms) )
203
204;; Converts a seconds value, may be fractional, into a time type.
205;; The type of time default is time-duration.
206
207(define (seconds->time sec . args)
208  (let-optionals args ((tt 'duration))
209    (tm:seconds->time
210      (check-raw-seconds 'seconds->time sec)
211      (check-time-type 'seconds->time tt)) ) )
212
213(define (time->nanoseconds tim)
214  (tm:time->nanoseconds (check-time 'time->nanoseconds tim)) )
215
216(define (time->milliseconds tim)
217  (tm:time->milliseconds (check-time 'time->milliseconds tim)) )
218
219(define (time->seconds tim)
220  (tm:time->seconds (check-time 'time->seconds tim)) )
221
222;; Current time routines
223
224(define (current-time . args)
225  (let-optionals args ((tt 'utc))
226    (case tt
227      ((monotonic) (tm:current-time-monotonic))
228      ((utc)       (tm:current-time-utc))
229      ((tai)       (tm:current-time-tai))
230      ((gc)        (tm:current-time-gc))
231      ((process)   (tm:current-time-process))
232      ((thread)    (tm:current-time-thread))
233      (else
234        (error-time-type 'current-time tt)) ) ) )
235
236;; -- Time Resolution
237;; This is the resolution of the clock in nanoseconds.
238;; This will be implementation specific.
239
240(define (time-resolution . args)
241  (let-optionals args ((tt 'utc))
242    (tm:time-resolution (check-time-type 'time-resolution tt)) ) )
243
244;; SRFI-18 Routines
245
246(define (srfi-18-time->time srfi-18-tim)
247  (tm:seconds->time
248    (srfi-18:time->seconds srfi-18-tim)
249    'duration) )
250
251(define (time->srfi-18-time tim)
252  (srfi-18:seconds->time
253    (exact->inexact
254      (tm:time->seconds (check-time 'time->srfi-18-time tim)))) )
255
256;; Time Comparison
257
258(define (time-compare tim1 tim2)
259  (check-time-compare 'time-compare tim1 tim2)
260  (let ((dif (tm:time-compare tim1 tim2)))
261    (cond
262      ((negative? dif)  -1)
263      ((positive? dif)  1)
264      (else             0) ) ) )
265
266(define (time=? tim1 tim2)
267  (check-time-compare 'time=? tim1 tim2)
268  (tm:time=? tim1 tim2) )
269
270(define (time>? tim1 tim2)
271  (check-time-compare 'time>? tim1 tim2)
272  (tm:time>? tim1 tim2) )
273
274(define (time<? tim1 tim2)
275  (check-time-compare 'time<? tim1 tim2)
276  (tm:time<? tim1 tim2) )
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-max tim1 . rest)
287  (let ((tt (tm:time-type (check-time 'time-max tim1))))
288    (let loop ((acc tim1) (ls rest))
289      (if (null? ls)
290        acc
291        (let ((tim (car ls)))
292          (check-time-and-type 'time-max tim tt)
293          (loop (tm:time-max acc tim) (cdr ls)) ) ) ) ) )
294
295(define (time-min tim1 . rest)
296  (let ((tt (tm:time-type (check-time 'time-min tim1))))
297    (let loop ((acc tim1) (ls rest))
298      (if (null? ls)
299        acc
300        (let ((tim (car ls)))
301          (check-time-and-type 'time-min tim tt)
302          (loop (tm:time-min acc tim) (cdr ls)) ) ) ) ) )
303
304;; Time Arithmetic
305
306(define (time-difference tim1 tim2)
307  (check-time-compare 'time-difference tim1 tim2)
308  (tm:time-difference tim1 tim2 (tm:some-time 'duration)) )
309
310(define (add-duration tim dur)
311  (check-time-aritmetic 'add-duration tim dur)
312  (tm:add-duration tim dur (tm:as-some-time tim)) )
313
314(define (subtract-duration tim dur)
315  (check-time-aritmetic 'subtract-duration tim dur)
316  (tm:subtract-duration tim dur (tm:as-some-time tim)) )
317
318(define (divide-duration dur num)
319  (check-duration 'divide-duration dur)
320  (tm:divide-duration dur num (tm:some-time 'duration)) )
321
322(define (multiply-duration dur num)
323  (check-duration 'multiply-duration dur)
324  (tm:multiply-duration dur num (tm:some-time 'duration)) )
325
326(define (time-abs tim)
327  (check-time 'time-abs tim)
328  (tm:time-abs tim (tm:as-some-time tim)) )
329
330(define (time-negate tim)
331  (check-time 'time-negate tim)
332  (tm:time-negate tim (tm:as-some-time tim)) )
333
334;;
335
336(define (time-difference! tim1 tim2)
337  (check-time-compare 'time-difference! tim1 tim2)
338  (tm:time-difference tim1 tim2 tim1) )
339
340(define (add-duration! tim dur)
341  (check-time-aritmetic 'add-duration! tim dur)
342  (tm:add-duration tim dur tim) )
343
344(define (subtract-duration! tim dur)
345  (check-time-aritmetic 'subtract-duration! tim dur)
346  (tm:subtract-duration tim dur tim) )
347
348(define (divide-duration! dur num)
349  (check-duration 'divide-duration! dur)
350  (tm:divide-duration dur num dur) )
351
352(define (multiply-duration! dur num)
353  (check-duration 'multiply-duration! dur)
354  (tm:multiply-duration dur num dur) )
355
356(define (time-abs! tim)
357  (check-time 'time-abs! tim)
358  (tm:time-abs tim tim) )
359
360(define (time-negate! tim)
361  (check-time 'time-negate! tim)
362  (tm:time-negate tim tim) )
363
364;;
365
366(define (time-negative? tim)
367  ;nanoseconds irrelevant
368  (negative? (tm:time-second (check-time 'time-negative? tim))) )
369
370(define (time-positive? tim)
371  ;nanoseconds irrelevant
372  (positive? (tm:time-second (check-time 'time-positive? tim))) )
373
374(define (time-zero? tim)
375  (check-time 'time-zero? tim)
376  (and
377    (zero? (tm:time-nanosecond tim))
378    (zero? (tm:time-second tim))) )
379
380;; Time Type Conversion
381
382;;
383
384(define (time-tai->time-utc tim)
385  (check-time-and-type 'time-tai->time-utc tim 'tai)
386  (tm:time-tai->time-utc tim (tm:any-time)) )
387
388(define (time-tai->time-monotonic tim)
389  (check-time-and-type 'time-tai->time-monotonic tim 'tai)
390  (tm:time-tai->time-monotonic tim (tm:any-time)) )
391
392(define (time-utc->time-tai tim)
393  (check-time-and-type 'time-utc->time-tai tim 'utc)
394  (tm:time-utc->time-tai tim (tm:any-time)) )
395
396(define (time-utc->time-monotonic tim)
397  (check-time-and-type 'time-utc->time-monotonic tim 'utc)
398  (tm:time-utc->time-monotonic tim (tm:any-time)) )
399
400(define (time-monotonic->time-utc tim)
401  (check-time-and-type 'time-monotoinc->time-utc tim 'monotonic)
402  (let ((ntim (tm:copy-time tim)))
403    (tm:time-monotonic->time-utc ntim ntim) ) )
404
405(define (time-monotonic->time-tai tim)
406  (check-time-and-type 'time-monotoinc->time-tai tim 'monotonic)
407  (tm:time-monotonic->time-tai tim (tm:any-time)) )
408
409;;
410
411(define (time-tai->time-utc! tim)
412  (check-time-and-type 'time-tai->time-utc! tim 'tai)
413  (tm:time-tai->time-utc tim tim) )
414
415(define (time-tai->time-monotonic! tim)
416  (check-time-and-type 'time-tai->time-monotonic! tim 'tai)
417  (tm:time-tai->time-monotonic tim tim) )
418
419(define (time-utc->time-tai! tim)
420  (check-time-and-type 'time-utc->time-tai! tim 'utc)
421  (tm:time-utc->time-tai tim tim) )
422
423(define (time-utc->time-monotonic! tim)
424  (check-time-and-type 'time-utc->time-monotonic! tim 'utc)
425  (tm:time-utc->time-monotonic tim tim) )
426
427(define (time-monotonic->time-utc! tim)
428  (check-time-and-type 'time-monotoinc->time-utc! tim 'monotonic)
429  (tm:time-monotonic->time-utc tim tim) )
430
431(define (time-monotonic->time-tai! tim)
432  (check-time-and-type 'time-monotoinc->time-tai! tim 'monotonic)
433  (tm:time-monotonic->time-tai tim tim) )
434
435) ;module srfi-19-time
Note: See TracBrowser for help on using the repository browser.