1 | ;;;; srfi-19-tmctm.scm -*- Scheme -*- |
---|
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 | ;; Issues |
---|
31 | ;; |
---|
32 | ;; - current-milliseconds is since process start but current-seconds is since |
---|
33 | ;; epoch start. |
---|
34 | |
---|
35 | ;; Bugs |
---|
36 | ;; |
---|
37 | ;; - assumes process start on a second boundary which is !? |
---|
38 | |
---|
39 | ;; Notes |
---|
40 | ;; |
---|
41 | ;; - w/o define-inline .o = 6920, w/ = 6428 !? |
---|
42 | |
---|
43 | (declare (disable-interrupts)) |
---|
44 | |
---|
45 | (module srfi-19-tmctm |
---|
46 | |
---|
47 | (;export |
---|
48 | tm:current-time-values) |
---|
49 | |
---|
50 | (import scheme) |
---|
51 | (import (chicken base)) |
---|
52 | (import (chicken type)) |
---|
53 | ;(import (only (chicken time) current-seconds current-milliseconds)) |
---|
54 | |
---|
55 | ;from library.scm |
---|
56 | |
---|
57 | #> |
---|
58 | #define C_a_get_current_seconds(ptr, c, dummy) C_int64_to_num(ptr, time(NULL)) |
---|
59 | <# |
---|
60 | |
---|
61 | (: current-milliseconds (-> integer)) |
---|
62 | (: current-seconds (-> integer)) |
---|
63 | |
---|
64 | (define-inline (current-milliseconds) |
---|
65 | (##core#inline_allocate ("C_a_i_current_milliseconds" 7) #f)) |
---|
66 | |
---|
67 | (define-inline (current-seconds) |
---|
68 | (##core#inline_allocate ("C_a_get_current_seconds" 7) #f)) |
---|
69 | |
---|
70 | ;;; |
---|
71 | |
---|
72 | (include "srfi-19-common") |
---|
73 | |
---|
74 | ;; Current time |
---|
75 | |
---|
76 | (: subsecond-ms (integer --> fixnum)) |
---|
77 | (: ms->ns (fixnum --> fixnum)) |
---|
78 | |
---|
79 | (define-inline (subsecond-ms ms) (remainder ms MS/S)) |
---|
80 | (define-inline (ms->ns ms) (* ms NS/MS)) |
---|
81 | |
---|
82 | (: tm:current-time-values (-> fixnum integer)) |
---|
83 | |
---|
84 | (define (tm:current-time-values) |
---|
85 | ;per #chicken irc example (still not n'sync) |
---|
86 | (let* ( |
---|
87 | (a-s (current-seconds)) |
---|
88 | (a-ms (current-milliseconds)) |
---|
89 | (b-s (current-seconds)) |
---|
90 | (b-ms (current-milliseconds)) ) |
---|
91 | (if (= a-s b-s) |
---|
92 | (values (ms->ns (subsecond-ms a-ms)) a-s) |
---|
93 | (values (ms->ns (subsecond-ms b-ms)) b-s) ) ) ) |
---|
94 | |
---|
95 | ) ;module srfi-19-tmctm |
---|