1 /* time.c -- R7RS time routines */
2 /* Copyright (c) 2011-2012 Alex Shinn. All rights reserved. */
3 /* Copyright (c) 2012 Alan Watson. All rights reserved. */
4 /* BSD-style license: http://synthcode.com/license.txt */
5
6 #include <chibi/eval.h>
7
8 #ifdef _WIN32
9 #define WIN32_LEAN_AND_MEAN
10 #include <windows.h>
11 #elif !defined(PLAN9)
12 #include <sys/time.h>
13 #else
14 typedef long time_t;
15 #endif
16
17 #if SEXP_USE_NTP_GETTIME
18 #include <sys/timex.h>
19
20 /* We can determine the clock resolution by calling ntp_adjtime() and */
21 /* seeing if the STA_NANO bit of the status word is set. If it is, we */
22 /* have nanosecond resolution, otherwise we have microsecond resolution. */
23
24 /* The time member of the ntptimeval struct may be either a struct */
25 /* timeval (with the fraction in microseconds) or a struct timespec */
26 /* (with the fraction in nanoseconds). */
27
28 /* However, there are systems (e.g., Ubuntu 10.4 on X86_64) that use */
29 /* nanosecond resolution but still declare the time member of struct */
30 /* ntptimeval to be a struct timeval. Therefore, we explicitly use casts */
31 /* to access this member either as a struct timeval or struct timespec */
32 /* depending on the resolution. */
33
34 static double ntp_resolution = 0.0;
35
determine_ntp_resolution(void)36 static void determine_ntp_resolution (void) {
37 struct timex tx;
38 tx.modes = 0;
39 if (ntp_adjtime(&tx) < 0) {
40 ntp_resolution = 0;
41 } else if (tx.status & STA_NANO) {
42 ntp_resolution = 1e-9;
43 } else {
44 ntp_resolution = 1e-6;
45 }
46 }
47
current_ntp_clock_values(double * second,int * leap_second_indicator)48 static void current_ntp_clock_values (double *second, int *leap_second_indicator) {
49 struct ntptimeval ntv;
50 int status = ntp_gettime(&ntv);
51 if (ntp_resolution != 0 && (
52 status == TIME_OK ||
53 status == TIME_INS ||
54 status == TIME_DEL ||
55 status == TIME_OOP ||
56 status == TIME_WAIT)) {
57 if (ntp_resolution == 1e-6) {
58 struct timeval *tv = (struct timeval *) &ntv.time;
59 *second = tv->tv_sec + ntp_resolution * tv->tv_usec;
60 } else {
61 struct timespec *ts = (struct timespec *) &ntv.time;
62 *second = ts->tv_sec + ntp_resolution * ts->tv_nsec;
63 }
64 *leap_second_indicator = (status == TIME_OOP);
65 } else {
66 *second = current_clock_second();
67 *leap_second_indicator = 0;
68 }
69 }
70
sexp_current_ntp_clock_values(sexp ctx,sexp self,sexp_sint_t n)71 sexp sexp_current_ntp_clock_values (sexp ctx, sexp self, sexp_sint_t n) {
72 double second;
73 int leap_second_indicator;
74 sexp_gc_var3(res, car, cdr);
75 current_ntp_clock_values (&second, &leap_second_indicator);
76 sexp_gc_preserve3(ctx, res, car, cdr);
77 cdr = sexp_make_boolean(leap_second_indicator);
78 car = sexp_make_flonum(ctx, second);
79 res = sexp_cons(ctx, car, cdr);
80 sexp_gc_release3(ctx);
81 return res;
82 }
83
84 #endif /* def SEXP_USE_NTP_GETTIME */
85
sexp_current_clock_second(sexp ctx,sexp self,sexp_sint_t n)86 sexp sexp_current_clock_second (sexp ctx, sexp self, sexp_sint_t n) {
87 #ifdef _WIN32
88 ULONGLONG t;
89 SYSTEMTIME st;
90 FILETIME ft;
91 ULARGE_INTEGER uli;
92 GetLocalTime(&st);
93 (void) SystemTimeToFileTime(&st, &ft);
94 /* Convert Win32 FILETIME to UNIX time */
95 uli.LowPart = ft.dwLowDateTime;
96 uli.HighPart = ft.dwHighDateTime;
97 t = uli.QuadPart - (11644473600LL * 10 * 1000 * 1000);
98 return sexp_make_flonum(ctx, ((double)t / (10 * 1000 * 1000)));
99 #elif !defined(PLAN9)
100 struct timeval tv;
101 struct timezone tz;
102 if (gettimeofday(&tv, &tz))
103 return sexp_user_exception(ctx, self, "couldn't gettimeofday", SEXP_FALSE);
104 return sexp_make_flonum(ctx, tv.tv_sec + tv.tv_usec / 1000000.0);
105 #else
106 time_t res = time(NULL);
107 return sexp_make_flonum(ctx, res);
108 #endif
109 }
110
sexp_init_library(sexp ctx,sexp self,sexp_sint_t n,sexp env,const char * version,const sexp_abi_identifier_t abi)111 sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, const sexp_abi_identifier_t abi) {
112 if (!(sexp_version_compatible(ctx, version, sexp_version)
113 && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER)))
114 return sexp_global(ctx, SEXP_G_ABI_ERROR);
115 sexp_define_foreign(ctx, env, "current-clock-second", 0, sexp_current_clock_second);
116 #if SEXP_USE_NTP_GETTIME
117 determine_ntp_resolution();
118 sexp_define_foreign(ctx, env, "current-ntp-clock-values", 0, sexp_current_ntp_clock_values);
119 #endif
120 return SEXP_VOID;
121 }
122