Commit | Line | Data |
---|---|---|
c7abe4f3 | 1 | /* Copyright (C) 1995,1996,1997,1998, 1999 Free Software Foundation, Inc. |
0f2d19dd JB |
2 | * |
3 | * This program is free software; you can redistribute it and/or modify | |
4 | * it under the terms of the GNU General Public License as published by | |
5 | * the Free Software Foundation; either version 2, or (at your option) | |
6 | * any later version. | |
7 | * | |
8 | * This program is distributed in the hope that it will be useful, | |
9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of | |
10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
11 | * GNU General Public License for more details. | |
12 | * | |
13 | * You should have received a copy of the GNU General Public License | |
14 | * along with this software; see the file COPYING. If not, write to | |
82892bed JB |
15 | * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, |
16 | * Boston, MA 02111-1307 USA | |
0f2d19dd JB |
17 | * |
18 | * As a special exception, the Free Software Foundation gives permission | |
19 | * for additional uses of the text contained in its release of GUILE. | |
20 | * | |
21 | * The exception is that, if you link the GUILE library with other files | |
22 | * to produce an executable, this does not by itself cause the | |
23 | * resulting executable to be covered by the GNU General Public License. | |
24 | * Your use of that executable is in no way restricted on account of | |
25 | * linking the GUILE library code into it. | |
26 | * | |
27 | * This exception does not however invalidate any other reasons why | |
28 | * the executable file might be covered by the GNU General Public License. | |
29 | * | |
30 | * This exception applies only to the code released by the | |
31 | * Free Software Foundation under the name GUILE. If you copy | |
32 | * code from other Free Software Foundation releases into a copy of | |
33 | * GUILE, as the General Public License permits, the exception does | |
34 | * not apply to the code that you add in this way. To avoid misleading | |
35 | * anyone as to the status of such modified files, you must delete | |
36 | * this exception notice from them. | |
37 | * | |
38 | * If you write modifications of your own for GUILE, it is your choice | |
39 | * whether to permit this exception to apply to your modifications. | |
82892bed | 40 | * If you do not wish that, delete this exception notice. */ |
0f2d19dd JB |
41 | \f |
42 | ||
43 | #include <stdio.h> | |
44 | #include "_scm.h" | |
876c87ce | 45 | #include "feature.h" |
20e6290e JB |
46 | |
47 | #include "stime.h" | |
48 | ||
0f2d19dd JB |
49 | #ifdef HAVE_UNISTD_H |
50 | #include <unistd.h> | |
51 | #endif | |
52 | ||
53 | \f | |
54 | # ifdef HAVE_SYS_TYPES_H | |
55 | # include <sys/types.h> | |
56 | # endif | |
57 | ||
58 | # ifdef TIME_WITH_SYS_TIME | |
59 | # include <sys/time.h> | |
60 | # include <time.h> | |
61 | # else | |
62 | # ifdef HAVE_SYS_TIME_H | |
63 | # include <sys/time.h> | |
64 | # else | |
65 | # ifdef HAVE_TIME_H | |
66 | # include <time.h> | |
67 | # endif | |
68 | # endif | |
69 | # endif | |
70 | ||
b1978258 GH |
71 | #ifdef HAVE_SYS_TIMES_H |
72 | # include <sys/times.h> | |
73 | #endif | |
74 | ||
75 | #ifdef HAVE_SYS_TIMEB_H | |
76 | # include <sys/timeb.h> | |
77 | #endif | |
0f2d19dd | 78 | |
b9525b92 GH |
79 | #ifndef tzname /* For SGI. */ |
80 | extern char *tzname[]; /* RS6000 and others reject char **tzname. */ | |
81 | #endif | |
82 | ||
4d3bacdd JB |
83 | #ifdef MISSING_STRPTIME_DECL |
84 | extern char *strptime (); | |
85 | #endif | |
86 | ||
cda55316 | 87 | /* This should be figured out by autoconf. */ |
a2fc27b5 JB |
88 | #if ! defined(CLKTCK) && defined(CLK_TCK) |
89 | # define CLKTCK CLK_TCK | |
90 | #endif | |
91 | #if ! defined(CLKTCK) && defined(CLOCKS_PER_SEC) | |
0f2d19dd | 92 | # define CLKTCK CLOCKS_PER_SEC |
a2fc27b5 JB |
93 | #endif |
94 | #if ! defined(CLKTCK) | |
0f2d19dd | 95 | # define CLKTCK 60 |
0f2d19dd JB |
96 | #endif |
97 | ||
a2fc27b5 | 98 | |
0f2d19dd JB |
99 | #ifdef __STDC__ |
100 | # define timet time_t | |
101 | #else | |
102 | # define timet long | |
103 | #endif | |
104 | ||
105 | #ifdef HAVE_TIMES | |
0f2d19dd JB |
106 | static |
107 | long mytime() | |
0f2d19dd JB |
108 | { |
109 | struct tms time_buffer; | |
110 | times(&time_buffer); | |
111 | return time_buffer.tms_utime + time_buffer.tms_stime; | |
112 | } | |
113 | #else | |
114 | # ifdef LACK_CLOCK | |
115 | # define mytime() ((time((timet*)0) - scm_your_base) * CLKTCK) | |
116 | # else | |
117 | # define mytime clock | |
118 | # endif | |
119 | #endif | |
120 | ||
19468eff | 121 | extern int errno; |
0f2d19dd JB |
122 | |
123 | #ifdef HAVE_FTIME | |
124 | ||
125 | struct timeb scm_your_base = {0}; | |
126 | SCM_PROC(s_get_internal_real_time, "get-internal-real-time", 0, 0, 0, scm_get_internal_real_time); | |
0f2d19dd JB |
127 | SCM |
128 | scm_get_internal_real_time() | |
0f2d19dd JB |
129 | { |
130 | struct timeb time_buffer; | |
55c4d089 JB |
131 | |
132 | SCM tmp; | |
133 | ftime (&time_buffer); | |
0f2d19dd | 134 | time_buffer.time -= scm_your_base.time; |
55c4d089 JB |
135 | tmp = scm_long2num (time_buffer.millitm - scm_your_base.millitm); |
136 | tmp = scm_sum (tmp, | |
137 | scm_product (SCM_MAKINUM (1000), | |
138 | SCM_MAKINUM (time_buffer.time))); | |
139 | return scm_quotient (scm_product (tmp, SCM_MAKINUM (CLKTCK)), | |
140 | SCM_MAKINUM (1000)); | |
141 | }; | |
0f2d19dd JB |
142 | |
143 | #else | |
144 | ||
145 | timet scm_your_base = 0; | |
146 | SCM_PROC(s_get_internal_real_time, "get-internal-real-time", 0, 0, 0, scm_get_internal_real_time); | |
0f2d19dd JB |
147 | SCM |
148 | scm_get_internal_real_time() | |
0f2d19dd | 149 | { |
19468eff | 150 | return scm_long2num((time((timet*)0) - scm_your_base) * (int)CLKTCK); |
0f2d19dd JB |
151 | } |
152 | #endif | |
153 | ||
6afcd3b2 GH |
154 | SCM_PROC (s_times, "times", 0, 0, 0, scm_times); |
155 | SCM | |
156 | scm_times (void) | |
157 | { | |
158 | #ifdef HAVE_TIMES | |
159 | struct tms t; | |
160 | clock_t rv; | |
161 | ||
a8741caa | 162 | SCM result = scm_make_vector (SCM_MAKINUM(5), SCM_UNDEFINED); |
6afcd3b2 GH |
163 | rv = times (&t); |
164 | if (rv == -1) | |
165 | scm_syserror (s_times); | |
166 | SCM_VELTS (result)[0] = scm_long2num (rv); | |
167 | SCM_VELTS (result)[1] = scm_long2num (t.tms_utime); | |
168 | SCM_VELTS (result)[2] = scm_long2num (t.tms_stime); | |
169 | SCM_VELTS (result)[3] = scm_long2num (t.tms_cutime); | |
170 | SCM_VELTS (result)[4] = scm_long2num (t.tms_cstime); | |
171 | return result; | |
172 | #else | |
173 | scm_sysmissing (s_times); | |
174 | #endif | |
175 | } | |
176 | ||
0e958795 JB |
177 | #ifndef HAVE_TZSET |
178 | /* GNU-WIN32's cygwin.dll doesn't have this. */ | |
179 | #define tzset() | |
180 | #endif | |
0f2d19dd JB |
181 | |
182 | ||
183 | static long scm_my_base = 0; | |
184 | ||
185 | SCM_PROC(s_get_internal_run_time, "get-internal-run-time", 0, 0, 0, scm_get_internal_run_time); | |
0f2d19dd JB |
186 | SCM |
187 | scm_get_internal_run_time() | |
0f2d19dd | 188 | { |
19468eff | 189 | return scm_long2num(mytime()-scm_my_base); |
0f2d19dd JB |
190 | } |
191 | ||
192 | SCM_PROC(s_current_time, "current-time", 0, 0, 0, scm_current_time); | |
0f2d19dd JB |
193 | SCM |
194 | scm_current_time() | |
0f2d19dd | 195 | { |
19468eff GH |
196 | timet timv; |
197 | ||
198 | SCM_DEFER_INTS; | |
199 | if ((timv = time (0)) == -1) | |
200 | scm_syserror (s_current_time); | |
201 | SCM_ALLOW_INTS; | |
202 | return scm_long2num((long) timv); | |
203 | } | |
204 | ||
1bf9865d | 205 | SCM_PROC (s_gettimeofday, "gettimeofday", 0, 0, 0, scm_gettimeofday); |
19468eff | 206 | SCM |
1bf9865d | 207 | scm_gettimeofday (void) |
19468eff GH |
208 | { |
209 | #ifdef HAVE_GETTIMEOFDAY | |
210 | struct timeval time; | |
211 | ||
212 | SCM_DEFER_INTS; | |
213 | if (gettimeofday (&time, NULL) == -1) | |
1bf9865d | 214 | scm_syserror (s_gettimeofday); |
19468eff GH |
215 | SCM_ALLOW_INTS; |
216 | return scm_cons (scm_long2num ((long) time.tv_sec), | |
217 | scm_long2num ((long) time.tv_usec)); | |
218 | #else | |
219 | # ifdef HAVE_FTIME | |
220 | struct timeb time; | |
221 | ||
222 | ftime(&time); | |
223 | return scm_cons (scm_long2num ((long) time.time), | |
9a81afca | 224 | SCM_MAKINUM (time.millitm * 1000)); |
19468eff GH |
225 | # else |
226 | timet timv; | |
227 | ||
228 | SCM_DEFER_INTS; | |
229 | if ((timv = time (0)) == -1) | |
1bf9865d | 230 | scm_syserror (s_gettimeofday); |
19468eff GH |
231 | SCM_ALLOW_INTS; |
232 | return scm_cons (scm_long2num (timv), SCM_MAKINUM (0)); | |
233 | # endif | |
234 | #endif | |
235 | } | |
236 | ||
237 | static SCM | |
238 | filltime (struct tm *bd_time, int zoff, char *zname) | |
239 | { | |
a8741caa | 240 | SCM result = scm_make_vector (SCM_MAKINUM(11), SCM_UNDEFINED); |
19468eff GH |
241 | |
242 | SCM_VELTS (result)[0] = SCM_MAKINUM (bd_time->tm_sec); | |
243 | SCM_VELTS (result)[1] = SCM_MAKINUM (bd_time->tm_min); | |
244 | SCM_VELTS (result)[2] = SCM_MAKINUM (bd_time->tm_hour); | |
245 | SCM_VELTS (result)[3] = SCM_MAKINUM (bd_time->tm_mday); | |
246 | SCM_VELTS (result)[4] = SCM_MAKINUM (bd_time->tm_mon); | |
247 | SCM_VELTS (result)[5] = SCM_MAKINUM (bd_time->tm_year); | |
248 | SCM_VELTS (result)[6] = SCM_MAKINUM (bd_time->tm_wday); | |
249 | SCM_VELTS (result)[7] = SCM_MAKINUM (bd_time->tm_yday); | |
250 | SCM_VELTS (result)[8] = SCM_MAKINUM (bd_time->tm_isdst); | |
251 | SCM_VELTS (result)[9] = SCM_MAKINUM (zoff); | |
b9525b92 | 252 | SCM_VELTS (result)[10] = zname ? scm_makfrom0str (zname) : SCM_BOOL_F; |
19468eff GH |
253 | return result; |
254 | } | |
255 | ||
ef9ff3fd GH |
256 | static char tzvar[3] = "TZ"; |
257 | extern char ** environ; | |
258 | ||
259 | static char ** | |
3eeba8d4 | 260 | setzone (SCM zone, int pos, const char *subr) |
b9525b92 | 261 | { |
ef9ff3fd | 262 | char **oldenv = 0; |
b9525b92 GH |
263 | |
264 | if (!SCM_UNBNDP (zone)) | |
265 | { | |
ef9ff3fd | 266 | static char *tmpenv[2]; |
b9525b92 GH |
267 | char *buf; |
268 | ||
ef9ff3fd | 269 | /* if zone was supplied, set the environment temporarily. */ |
89958ad0 JB |
270 | SCM_ASSERT (SCM_NIMP (zone) && SCM_ROSTRINGP (zone), zone, pos, subr); |
271 | SCM_COERCE_SUBSTR (zone); | |
ef9ff3fd GH |
272 | buf = scm_must_malloc (SCM_LENGTH (zone) + sizeof (tzvar) + 1, |
273 | subr); | |
274 | sprintf (buf, "%s=%s", tzvar, SCM_ROCHARS (zone)); | |
275 | oldenv = environ; | |
276 | tmpenv[0] = buf; | |
277 | tmpenv[1] = 0; | |
278 | environ = tmpenv; | |
b9525b92 GH |
279 | tzset(); |
280 | } | |
ef9ff3fd | 281 | return oldenv; |
b9525b92 GH |
282 | } |
283 | ||
284 | static void | |
3eeba8d4 | 285 | restorezone (SCM zone, char **oldenv, const char *subr) |
b9525b92 GH |
286 | { |
287 | if (!SCM_UNBNDP (zone)) | |
288 | { | |
ef9ff3fd GH |
289 | scm_must_free (environ[0]); |
290 | environ = oldenv; | |
b9525b92 GH |
291 | tzset(); |
292 | } | |
293 | } | |
294 | ||
295 | ||
19468eff GH |
296 | SCM_PROC (s_localtime, "localtime", 1, 1, 0, scm_localtime); |
297 | SCM | |
298 | scm_localtime (SCM time, SCM zone) | |
299 | { | |
300 | timet itime; | |
4edc089c | 301 | struct tm *ltptr, lt, *utc; |
19468eff GH |
302 | SCM result; |
303 | int zoff; | |
304 | char *zname = 0; | |
ef9ff3fd | 305 | char **oldenv; |
19468eff GH |
306 | int err; |
307 | ||
308 | itime = scm_num2long (time, (char *) SCM_ARG1, s_localtime); | |
309 | SCM_DEFER_INTS; | |
ef9ff3fd | 310 | oldenv = setzone (zone, SCM_ARG2, s_localtime); |
4edc089c | 311 | ltptr = localtime (&itime); |
19468eff | 312 | err = errno; |
4edc089c | 313 | if (ltptr) |
19468eff | 314 | { |
4d3bacdd | 315 | const char *ptr; |
ef9ff3fd GH |
316 | |
317 | /* copy zone name before calling gmtime or tzset. */ | |
b9525b92 | 318 | #ifdef HAVE_TM_ZONE |
ef9ff3fd | 319 | ptr = ltptr->tm_zone; |
b9525b92 GH |
320 | #else |
321 | # ifdef HAVE_TZNAME | |
ef9ff3fd | 322 | ptr = tzname[ (ltptr->tm_isdst == 1) ? 1 : 0 ]; |
4edc089c GH |
323 | # else |
324 | scm_misc_error (s_localtime, "Not fully implemented on this platform", | |
da5b3eb1 | 325 | SCM_EOL); |
4edc089c | 326 | # endif |
b9525b92 | 327 | #endif |
ef9ff3fd GH |
328 | zname = scm_must_malloc (strlen (ptr) + 1, s_localtime); |
329 | strcpy (zname, ptr); | |
19468eff | 330 | } |
ef9ff3fd GH |
331 | /* the struct is copied in case localtime and gmtime share a buffer. */ |
332 | if (ltptr) | |
333 | lt = *ltptr; | |
334 | utc = gmtime (&itime); | |
335 | if (utc == NULL) | |
336 | err = errno; | |
337 | restorezone (zone, oldenv, s_localtime); | |
b9525b92 | 338 | /* delayed until zone has been restored. */ |
19468eff | 339 | errno = err; |
4edc089c | 340 | if (utc == NULL || ltptr == NULL) |
19468eff GH |
341 | scm_syserror (s_localtime); |
342 | ||
343 | /* calculate timezone offset in seconds west of UTC. */ | |
4edc089c GH |
344 | zoff = (utc->tm_hour - lt.tm_hour) * 3600 + (utc->tm_min - lt.tm_min) * 60 |
345 | + utc->tm_sec - lt.tm_sec; | |
346 | if (utc->tm_year < lt.tm_year) | |
19468eff | 347 | zoff -= 24 * 60 * 60; |
4edc089c | 348 | else if (utc->tm_year > lt.tm_year) |
19468eff | 349 | zoff += 24 * 60 * 60; |
4edc089c | 350 | else if (utc->tm_yday < lt.tm_yday) |
19468eff | 351 | zoff -= 24 * 60 * 60; |
4edc089c | 352 | else if (utc->tm_yday > lt.tm_yday) |
19468eff GH |
353 | zoff += 24 * 60 * 60; |
354 | ||
4edc089c | 355 | result = filltime (<, zoff, zname); |
19468eff | 356 | SCM_ALLOW_INTS; |
ef9ff3fd | 357 | scm_must_free (zname); |
19468eff GH |
358 | return result; |
359 | } | |
19468eff GH |
360 | |
361 | SCM_PROC (s_gmtime, "gmtime", 1, 0, 0, scm_gmtime); | |
362 | SCM | |
363 | scm_gmtime (SCM time) | |
364 | { | |
365 | timet itime; | |
366 | struct tm *bd_time; | |
367 | SCM result; | |
368 | ||
369 | itime = scm_num2long (time, (char *) SCM_ARG1, s_gmtime); | |
370 | SCM_DEFER_INTS; | |
371 | bd_time = gmtime (&itime); | |
372 | if (bd_time == NULL) | |
373 | scm_syserror (s_gmtime); | |
374 | result = filltime (bd_time, 0, "GMT"); | |
375 | SCM_ALLOW_INTS; | |
376 | return result; | |
377 | } | |
378 | ||
b9525b92 GH |
379 | /* copy time components from a Scheme object to a struct tm. */ |
380 | static void | |
3eeba8d4 | 381 | bdtime2c (SCM sbd_time, struct tm *lt, int pos, const char *subr) |
19468eff | 382 | { |
55a7fc62 GH |
383 | SCM *velts; |
384 | int i; | |
385 | ||
b9525b92 | 386 | SCM_ASSERT (SCM_NIMP (sbd_time) && SCM_VECTORP (sbd_time) |
55a7fc62 | 387 | && SCM_LENGTH (sbd_time) == 11, |
b9525b92 | 388 | sbd_time, pos, subr); |
55a7fc62 GH |
389 | velts = SCM_VELTS (sbd_time); |
390 | for (i = 0; i < 10; i++) | |
391 | { | |
392 | SCM_ASSERT (SCM_INUMP (velts[i]), sbd_time, pos, subr); | |
393 | } | |
394 | SCM_ASSERT (SCM_FALSEP (velts[10]) | |
395 | || (SCM_NIMP (velts[10]) && SCM_STRINGP (velts[10])), | |
396 | sbd_time, pos, subr); | |
397 | ||
398 | lt->tm_sec = SCM_INUM (velts[0]); | |
399 | lt->tm_min = SCM_INUM (velts[1]); | |
400 | lt->tm_hour = SCM_INUM (velts[2]); | |
401 | lt->tm_mday = SCM_INUM (velts[3]); | |
402 | lt->tm_mon = SCM_INUM (velts[4]); | |
403 | lt->tm_year = SCM_INUM (velts[5]); | |
404 | lt->tm_wday = SCM_INUM (velts[6]); | |
405 | lt->tm_yday = SCM_INUM (velts[7]); | |
406 | lt->tm_isdst = SCM_INUM (velts[8]); | |
c7abe4f3 | 407 | #ifdef HAVE_TM_ZONE |
55a7fc62 GH |
408 | lt->tm_gmtoff = SCM_INUM (velts[9]); |
409 | if (SCM_FALSEP (velts[10])) | |
410 | lt->tm_zone = NULL; | |
411 | else | |
412 | lt->tm_zone = SCM_CHARS (velts[10]); | |
c7abe4f3 | 413 | #endif |
b9525b92 GH |
414 | } |
415 | ||
416 | SCM_PROC (s_mktime, "mktime", 1, 1, 0, scm_mktime); | |
417 | SCM | |
418 | scm_mktime (SCM sbd_time, SCM zone) | |
419 | { | |
420 | timet itime; | |
421 | struct tm lt, *utc; | |
422 | SCM result; | |
423 | int zoff; | |
424 | char *zname = 0; | |
ef9ff3fd | 425 | char **oldenv; |
b9525b92 GH |
426 | int err; |
427 | ||
b9525b92 | 428 | bdtime2c (sbd_time, <, SCM_ARG1, s_mktime); |
19468eff GH |
429 | |
430 | SCM_DEFER_INTS; | |
ef9ff3fd | 431 | oldenv = setzone (zone, SCM_ARG2, s_mktime); |
19468eff | 432 | itime = mktime (<); |
b9525b92 | 433 | err = errno; |
19468eff | 434 | |
b9525b92 GH |
435 | if (itime != -1) |
436 | { | |
4d3bacdd | 437 | const char *ptr; |
ef9ff3fd GH |
438 | |
439 | /* copy zone name before calling gmtime or tzset. */ | |
b9525b92 | 440 | #ifdef HAVE_TM_ZONE |
ef9ff3fd | 441 | ptr = lt.tm_zone; |
b9525b92 GH |
442 | #else |
443 | # ifdef HAVE_TZNAME | |
ef9ff3fd | 444 | ptr = tzname[ (lt.tm_isdst == 1) ? 1 : 0 ]; |
4edc089c | 445 | # else |
ef9ff3fd | 446 | scm_misc_error (s_mktime, "Not fully implemented on this platform", |
da5b3eb1 | 447 | SCM_EOL); |
4edc089c | 448 | # endif |
b9525b92 | 449 | #endif |
ef9ff3fd GH |
450 | zname = scm_must_malloc (strlen (ptr) + 1, s_mktime); |
451 | strcpy (zname, ptr); | |
b9525b92 | 452 | } |
ef9ff3fd GH |
453 | |
454 | /* get timezone offset in seconds west of UTC. */ | |
455 | utc = gmtime (&itime); | |
456 | if (utc == NULL) | |
457 | err = errno; | |
458 | ||
459 | restorezone (zone, oldenv, s_mktime); | |
b9525b92 GH |
460 | /* delayed until zone has been restored. */ |
461 | errno = err; | |
462 | if (utc == NULL || itime == -1) | |
463 | scm_syserror (s_mktime); | |
464 | ||
19468eff GH |
465 | zoff = (utc->tm_hour - lt.tm_hour) * 3600 + (utc->tm_min - lt.tm_min) * 60 |
466 | + utc->tm_sec - lt.tm_sec; | |
467 | if (utc->tm_year < lt.tm_year) | |
468 | zoff -= 24 * 60 * 60; | |
469 | else if (utc->tm_year > lt.tm_year) | |
470 | zoff += 24 * 60 * 60; | |
471 | else if (utc->tm_yday < lt.tm_yday) | |
472 | zoff -= 24 * 60 * 60; | |
473 | else if (utc->tm_yday > lt.tm_yday) | |
474 | zoff += 24 * 60 * 60; | |
475 | ||
19468eff GH |
476 | result = scm_cons (scm_long2num ((long) itime), |
477 | filltime (<, zoff, zname)); | |
478 | SCM_ALLOW_INTS; | |
ef9ff3fd | 479 | scm_must_free (zname); |
19468eff | 480 | return result; |
0f2d19dd JB |
481 | } |
482 | ||
19468eff GH |
483 | SCM_PROC (s_tzset, "tzset", 0, 0, 0, scm_tzset); |
484 | SCM | |
485 | scm_tzset (void) | |
0f2d19dd | 486 | { |
19468eff GH |
487 | tzset(); |
488 | return SCM_UNSPECIFIED; | |
0f2d19dd JB |
489 | } |
490 | ||
b9525b92 GH |
491 | SCM_PROC (s_strftime, "strftime", 2, 0, 0, scm_strftime); |
492 | ||
493 | SCM | |
494 | scm_strftime (format, stime) | |
495 | SCM format; | |
496 | SCM stime; | |
497 | { | |
498 | struct tm t; | |
499 | ||
500 | char *tbuf; | |
501 | int size = 50; | |
502 | char *fmt; | |
503 | int len; | |
ef9ff3fd | 504 | SCM result; |
b9525b92 | 505 | |
89958ad0 | 506 | SCM_ASSERT (SCM_NIMP (format) && SCM_ROSTRINGP (format), format, SCM_ARG1, |
b9525b92 GH |
507 | s_strftime); |
508 | bdtime2c (stime, &t, SCM_ARG2, s_strftime); | |
509 | ||
89958ad0 | 510 | SCM_COERCE_SUBSTR (format); |
b9525b92 GH |
511 | fmt = SCM_ROCHARS (format); |
512 | len = SCM_ROLENGTH (format); | |
513 | ||
514 | tbuf = scm_must_malloc (size, s_strftime); | |
515 | while ((len = strftime (tbuf, size, fmt, &t)) == size) | |
516 | { | |
517 | scm_must_free (tbuf); | |
518 | size *= 2; | |
519 | tbuf = scm_must_malloc (size, s_strftime); | |
520 | } | |
ef9ff3fd GH |
521 | result = scm_makfromstr (tbuf, len, 0); |
522 | scm_must_free (tbuf); | |
523 | return result; | |
b9525b92 GH |
524 | } |
525 | ||
526 | SCM_PROC (s_strptime, "strptime", 2, 0, 0, scm_strptime); | |
527 | ||
528 | SCM | |
529 | scm_strptime (format, string) | |
530 | SCM format; | |
531 | SCM string; | |
532 | { | |
533 | #ifdef HAVE_STRPTIME | |
534 | struct tm t; | |
535 | char *fmt, *str, *rest; | |
536 | ||
537 | SCM_ASSERT (SCM_NIMP (format) && SCM_ROSTRINGP (format), format, SCM_ARG1, | |
538 | s_strptime); | |
539 | SCM_ASSERT (SCM_NIMP (string) && SCM_ROSTRINGP (string), string, SCM_ARG2, | |
540 | s_strptime); | |
541 | ||
89958ad0 JB |
542 | SCM_COERCE_SUBSTR (format); |
543 | SCM_COERCE_SUBSTR (string); | |
b9525b92 GH |
544 | fmt = SCM_ROCHARS (format); |
545 | str = SCM_ROCHARS (string); | |
546 | ||
547 | /* initialize the struct tm */ | |
548 | #define tm_init(field) t.field = 0 | |
549 | tm_init (tm_sec); | |
550 | tm_init (tm_min); | |
551 | tm_init (tm_hour); | |
552 | tm_init (tm_mday); | |
553 | tm_init (tm_mon); | |
554 | tm_init (tm_year); | |
555 | tm_init (tm_wday); | |
556 | tm_init (tm_yday); | |
557 | #undef tm_init | |
558 | ||
559 | t.tm_isdst = -1; | |
560 | SCM_DEFER_INTS; | |
561 | if ((rest = strptime (str, fmt, &t)) == NULL) | |
562 | scm_syserror (s_strptime); | |
563 | ||
564 | SCM_ALLOW_INTS; | |
565 | return scm_cons (filltime (&t, 0, NULL), SCM_MAKINUM (rest - str)); | |
566 | ||
567 | #else | |
568 | scm_sysmissing (s_strptime); | |
569 | #endif | |
570 | } | |
571 | ||
0f2d19dd JB |
572 | void |
573 | scm_init_stime() | |
0f2d19dd JB |
574 | { |
575 | scm_sysintern("internal-time-units-per-second", | |
19468eff | 576 | scm_long2num((long)CLKTCK)); |
0f2d19dd JB |
577 | |
578 | #ifdef HAVE_FTIME | |
579 | if (!scm_your_base.time) ftime(&scm_your_base); | |
580 | #else | |
581 | if (!scm_your_base) time(&scm_your_base); | |
582 | #endif | |
583 | ||
584 | if (!scm_my_base) scm_my_base = mytime(); | |
585 | ||
876c87ce | 586 | scm_add_feature ("current-time"); |
0f2d19dd JB |
587 | #include "stime.x" |
588 | } | |
589 |