source: project/release/5/srfi-19/trunk/srfi-19-tmctm.scm @ 38668

Last change on this file since 38668 was 38668, checked in by Kon Lovett, 5 months ago

remove redundant -local, use -strict-types (#t is-a type? see -io zone-reader NOTE), isolate tm:ctm

File size: 3.0 KB
Line 
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
Note: See TracBrowser for help on using the repository browser.