Commit | Line | Data |
---|---|---|
19468eff | 1 | /* Copyright (C) 1995,1996,1997 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 | ||
83 | char *strptime (); | |
84 | ||
cda55316 | 85 | /* This should be figured out by autoconf. */ |
0f2d19dd JB |
86 | #ifdef CLK_TCK |
87 | # define CLKTCK CLK_TCK | |
88 | # ifdef CLOCKS_PER_SEC | |
cda55316 | 89 | # if defined (unix) || defined (__unix) |
0f2d19dd JB |
90 | # ifndef ARM_ULIB |
91 | # include <sys/times.h> | |
92 | # endif | |
93 | # define LACK_CLOCK | |
94 | /* This is because clock() might be POSIX rather than ANSI. | |
95 | This occurs on HP-UX machines */ | |
96 | # endif | |
97 | # endif | |
98 | #else | |
99 | # ifdef CLOCKS_PER_SEC | |
100 | # define CLKTCK CLOCKS_PER_SEC | |
101 | # else | |
102 | # define LACK_CLOCK | |
103 | # define CLKTCK 60 | |
104 | # endif | |
105 | #endif | |
106 | ||
0f2d19dd JB |
107 | #ifdef __STDC__ |
108 | # define timet time_t | |
109 | #else | |
110 | # define timet long | |
111 | #endif | |
112 | ||
113 | #ifdef HAVE_TIMES | |
0f2d19dd JB |
114 | static |
115 | long mytime() | |
0f2d19dd JB |
116 | { |
117 | struct tms time_buffer; | |
118 | times(&time_buffer); | |
119 | return time_buffer.tms_utime + time_buffer.tms_stime; | |
120 | } | |
121 | #else | |
122 | # ifdef LACK_CLOCK | |
123 | # define mytime() ((time((timet*)0) - scm_your_base) * CLKTCK) | |
124 | # else | |
125 | # define mytime clock | |
126 | # endif | |
127 | #endif | |
128 | ||
19468eff | 129 | extern int errno; |
0f2d19dd JB |
130 | |
131 | #ifdef HAVE_FTIME | |
132 | ||
23858ad1 MD |
133 | extern int ftime (struct timeb *); |
134 | ||
0f2d19dd JB |
135 | struct timeb scm_your_base = {0}; |
136 | SCM_PROC(s_get_internal_real_time, "get-internal-real-time", 0, 0, 0, scm_get_internal_real_time); | |
0f2d19dd JB |
137 | SCM |
138 | scm_get_internal_real_time() | |
0f2d19dd JB |
139 | { |
140 | struct timeb time_buffer; | |
141 | long tmp; | |
142 | ftime(&time_buffer); | |
143 | time_buffer.time -= scm_your_base.time; | |
144 | tmp = time_buffer.millitm - scm_your_base.millitm; | |
145 | tmp = time_buffer.time*1000L + tmp; | |
146 | tmp *= CLKTCK; | |
147 | tmp /= 1000; | |
19468eff | 148 | return scm_long2num (tmp); |
0f2d19dd JB |
149 | } |
150 | ||
151 | #else | |
152 | ||
153 | timet scm_your_base = 0; | |
154 | SCM_PROC(s_get_internal_real_time, "get-internal-real-time", 0, 0, 0, scm_get_internal_real_time); | |
0f2d19dd JB |
155 | SCM |
156 | scm_get_internal_real_time() | |
0f2d19dd | 157 | { |
19468eff | 158 | return scm_long2num((time((timet*)0) - scm_your_base) * (int)CLKTCK); |
0f2d19dd JB |
159 | } |
160 | #endif | |
161 | ||
6afcd3b2 GH |
162 | SCM_PROC (s_times, "times", 0, 0, 0, scm_times); |
163 | SCM | |
164 | scm_times (void) | |
165 | { | |
166 | #ifdef HAVE_TIMES | |
167 | struct tms t; | |
168 | clock_t rv; | |
169 | ||
170 | SCM result = scm_make_vector (SCM_MAKINUM(5), SCM_UNDEFINED, SCM_UNDEFINED); | |
171 | rv = times (&t); | |
172 | if (rv == -1) | |
173 | scm_syserror (s_times); | |
174 | SCM_VELTS (result)[0] = scm_long2num (rv); | |
175 | SCM_VELTS (result)[1] = scm_long2num (t.tms_utime); | |
176 | SCM_VELTS (result)[2] = scm_long2num (t.tms_stime); | |
177 | SCM_VELTS (result)[3] = scm_long2num (t.tms_cutime); | |
178 | SCM_VELTS (result)[4] = scm_long2num (t.tms_cstime); | |
179 | return result; | |
180 | #else | |
181 | scm_sysmissing (s_times); | |
182 | #endif | |
183 | } | |
184 | ||
0e958795 JB |
185 | #ifndef HAVE_TZSET |
186 | /* GNU-WIN32's cygwin.dll doesn't have this. */ | |
187 | #define tzset() | |
188 | #endif | |
0f2d19dd JB |
189 | |
190 | ||
191 | static long scm_my_base = 0; | |
192 | ||
193 | SCM_PROC(s_get_internal_run_time, "get-internal-run-time", 0, 0, 0, scm_get_internal_run_time); | |
0f2d19dd JB |
194 | SCM |
195 | scm_get_internal_run_time() | |
0f2d19dd | 196 | { |
19468eff | 197 | return scm_long2num(mytime()-scm_my_base); |
0f2d19dd JB |
198 | } |
199 | ||
200 | SCM_PROC(s_current_time, "current-time", 0, 0, 0, scm_current_time); | |
0f2d19dd JB |
201 | SCM |
202 | scm_current_time() | |
0f2d19dd | 203 | { |
19468eff GH |
204 | timet timv; |
205 | ||
206 | SCM_DEFER_INTS; | |
207 | if ((timv = time (0)) == -1) | |
208 | scm_syserror (s_current_time); | |
209 | SCM_ALLOW_INTS; | |
210 | return scm_long2num((long) timv); | |
211 | } | |
212 | ||
1bf9865d | 213 | SCM_PROC (s_gettimeofday, "gettimeofday", 0, 0, 0, scm_gettimeofday); |
19468eff | 214 | SCM |
1bf9865d | 215 | scm_gettimeofday (void) |
19468eff GH |
216 | { |
217 | #ifdef HAVE_GETTIMEOFDAY | |
218 | struct timeval time; | |
219 | ||
220 | SCM_DEFER_INTS; | |
221 | if (gettimeofday (&time, NULL) == -1) | |
1bf9865d | 222 | scm_syserror (s_gettimeofday); |
19468eff GH |
223 | SCM_ALLOW_INTS; |
224 | return scm_cons (scm_long2num ((long) time.tv_sec), | |
225 | scm_long2num ((long) time.tv_usec)); | |
226 | #else | |
227 | # ifdef HAVE_FTIME | |
228 | struct timeb time; | |
229 | ||
230 | ftime(&time); | |
231 | return scm_cons (scm_long2num ((long) time.time), | |
9a81afca | 232 | SCM_MAKINUM (time.millitm * 1000)); |
19468eff GH |
233 | # else |
234 | timet timv; | |
235 | ||
236 | SCM_DEFER_INTS; | |
237 | if ((timv = time (0)) == -1) | |
1bf9865d | 238 | scm_syserror (s_gettimeofday); |
19468eff GH |
239 | SCM_ALLOW_INTS; |
240 | return scm_cons (scm_long2num (timv), SCM_MAKINUM (0)); | |
241 | # endif | |
242 | #endif | |
243 | } | |
244 | ||
245 | static SCM | |
246 | filltime (struct tm *bd_time, int zoff, char *zname) | |
247 | { | |
248 | SCM result = scm_make_vector(SCM_MAKINUM(11), SCM_UNDEFINED, SCM_UNDEFINED); | |
249 | ||
250 | SCM_VELTS (result)[0] = SCM_MAKINUM (bd_time->tm_sec); | |
251 | SCM_VELTS (result)[1] = SCM_MAKINUM (bd_time->tm_min); | |
252 | SCM_VELTS (result)[2] = SCM_MAKINUM (bd_time->tm_hour); | |
253 | SCM_VELTS (result)[3] = SCM_MAKINUM (bd_time->tm_mday); | |
254 | SCM_VELTS (result)[4] = SCM_MAKINUM (bd_time->tm_mon); | |
255 | SCM_VELTS (result)[5] = SCM_MAKINUM (bd_time->tm_year); | |
256 | SCM_VELTS (result)[6] = SCM_MAKINUM (bd_time->tm_wday); | |
257 | SCM_VELTS (result)[7] = SCM_MAKINUM (bd_time->tm_yday); | |
258 | SCM_VELTS (result)[8] = SCM_MAKINUM (bd_time->tm_isdst); | |
259 | SCM_VELTS (result)[9] = SCM_MAKINUM (zoff); | |
b9525b92 | 260 | SCM_VELTS (result)[10] = zname ? scm_makfrom0str (zname) : SCM_BOOL_F; |
19468eff GH |
261 | return result; |
262 | } | |
263 | ||
b9525b92 GH |
264 | static char * |
265 | setzone (SCM zone, int pos, char *subr) | |
266 | { | |
267 | char *oldtz = 0; | |
268 | ||
269 | if (!SCM_UNBNDP (zone)) | |
270 | { | |
271 | char *buf; | |
272 | ||
273 | /* if zone was supplied, set the environment variable TZ temporarily. */ | |
89958ad0 JB |
274 | SCM_ASSERT (SCM_NIMP (zone) && SCM_ROSTRINGP (zone), zone, pos, subr); |
275 | SCM_COERCE_SUBSTR (zone); | |
b9525b92 GH |
276 | buf = malloc (SCM_LENGTH (zone) + 4); |
277 | if (buf == 0) | |
278 | scm_memory_error (subr); | |
279 | oldtz = getenv ("TZ"); | |
280 | if (oldtz != NULL) | |
281 | oldtz = oldtz - 3; | |
89958ad0 | 282 | sprintf (buf, "TZ=%s", SCM_ROCHARS (zone)); |
b9525b92 GH |
283 | if (putenv (buf) < 0) |
284 | scm_syserror (subr); | |
285 | tzset(); | |
286 | } | |
287 | return oldtz; | |
288 | } | |
289 | ||
290 | static void | |
291 | restorezone (SCM zone, char *oldzone) | |
292 | { | |
293 | if (!SCM_UNBNDP (zone)) | |
294 | { | |
295 | int rv; | |
296 | ||
297 | if (oldzone) | |
298 | rv = putenv (oldzone); | |
299 | else | |
300 | rv = putenv ("TZ"); | |
301 | if (rv < 0) | |
302 | scm_syserror ("restorezone"); | |
303 | tzset(); | |
304 | } | |
305 | } | |
306 | ||
307 | ||
19468eff GH |
308 | SCM_PROC (s_localtime, "localtime", 1, 1, 0, scm_localtime); |
309 | SCM | |
310 | scm_localtime (SCM time, SCM zone) | |
311 | { | |
312 | timet itime; | |
4edc089c | 313 | struct tm *ltptr, lt, *utc; |
19468eff GH |
314 | SCM result; |
315 | int zoff; | |
316 | char *zname = 0; | |
b9525b92 | 317 | char *oldtz; |
19468eff GH |
318 | int err; |
319 | ||
320 | itime = scm_num2long (time, (char *) SCM_ARG1, s_localtime); | |
321 | SCM_DEFER_INTS; | |
b9525b92 | 322 | oldtz = setzone (zone, SCM_ARG2, s_localtime); |
4edc089c | 323 | ltptr = localtime (&itime); |
19468eff | 324 | err = errno; |
4edc089c GH |
325 | /* copied in case localtime and gmtime share a buffer. */ |
326 | if (ltptr) | |
327 | lt = *ltptr; | |
19468eff GH |
328 | utc = gmtime (&itime); |
329 | if (utc == NULL) | |
330 | err = errno; | |
4edc089c | 331 | if (ltptr) |
19468eff | 332 | { |
b9525b92 | 333 | #ifdef HAVE_TM_ZONE |
4edc089c | 334 | zname = lt.tm_zone; |
b9525b92 GH |
335 | #else |
336 | # ifdef HAVE_TZNAME | |
19468eff | 337 | /* must be copied before calling tzset again. */ |
4edc089c | 338 | char *ptr = tzname[ (lt.tm_isdst == 1) ? 1 : 0 ]; |
19468eff GH |
339 | |
340 | zname = scm_must_malloc (strlen (ptr) + 1, s_localtime); | |
341 | strcpy (zname, ptr); | |
4edc089c GH |
342 | # else |
343 | scm_misc_error (s_localtime, "Not fully implemented on this platform", | |
da5b3eb1 | 344 | SCM_EOL); |
4edc089c | 345 | # endif |
b9525b92 | 346 | #endif |
19468eff | 347 | } |
b9525b92 GH |
348 | restorezone (zone, oldtz); |
349 | /* delayed until zone has been restored. */ | |
19468eff | 350 | errno = err; |
4edc089c | 351 | if (utc == NULL || ltptr == NULL) |
19468eff GH |
352 | scm_syserror (s_localtime); |
353 | ||
354 | /* calculate timezone offset in seconds west of UTC. */ | |
4edc089c GH |
355 | zoff = (utc->tm_hour - lt.tm_hour) * 3600 + (utc->tm_min - lt.tm_min) * 60 |
356 | + utc->tm_sec - lt.tm_sec; | |
357 | if (utc->tm_year < lt.tm_year) | |
19468eff | 358 | zoff -= 24 * 60 * 60; |
4edc089c | 359 | else if (utc->tm_year > lt.tm_year) |
19468eff | 360 | zoff += 24 * 60 * 60; |
4edc089c | 361 | else if (utc->tm_yday < lt.tm_yday) |
19468eff | 362 | zoff -= 24 * 60 * 60; |
4edc089c | 363 | else if (utc->tm_yday > lt.tm_yday) |
19468eff GH |
364 | zoff += 24 * 60 * 60; |
365 | ||
4edc089c | 366 | result = filltime (<, zoff, zname); |
19468eff GH |
367 | SCM_ALLOW_INTS; |
368 | return result; | |
369 | } | |
19468eff GH |
370 | |
371 | SCM_PROC (s_gmtime, "gmtime", 1, 0, 0, scm_gmtime); | |
372 | SCM | |
373 | scm_gmtime (SCM time) | |
374 | { | |
375 | timet itime; | |
376 | struct tm *bd_time; | |
377 | SCM result; | |
378 | ||
379 | itime = scm_num2long (time, (char *) SCM_ARG1, s_gmtime); | |
380 | SCM_DEFER_INTS; | |
381 | bd_time = gmtime (&itime); | |
382 | if (bd_time == NULL) | |
383 | scm_syserror (s_gmtime); | |
384 | result = filltime (bd_time, 0, "GMT"); | |
385 | SCM_ALLOW_INTS; | |
386 | return result; | |
387 | } | |
388 | ||
b9525b92 GH |
389 | /* copy time components from a Scheme object to a struct tm. */ |
390 | static void | |
391 | bdtime2c (SCM sbd_time, struct tm *lt, int pos, char *subr) | |
19468eff | 392 | { |
b9525b92 | 393 | SCM_ASSERT (SCM_NIMP (sbd_time) && SCM_VECTORP (sbd_time) |
3cef7514 | 394 | && SCM_LENGTH (sbd_time) == 11 |
b9525b92 | 395 | && SCM_INUMP (SCM_VELTS (sbd_time)[0]) |
19468eff GH |
396 | && SCM_INUMP (SCM_VELTS (sbd_time)[1]) |
397 | && SCM_INUMP (SCM_VELTS (sbd_time)[2]) | |
398 | && SCM_INUMP (SCM_VELTS (sbd_time)[3]) | |
399 | && SCM_INUMP (SCM_VELTS (sbd_time)[4]) | |
400 | && SCM_INUMP (SCM_VELTS (sbd_time)[5]) | |
b9525b92 GH |
401 | && SCM_INUMP (SCM_VELTS (sbd_time)[6]) |
402 | && SCM_INUMP (SCM_VELTS (sbd_time)[7]) | |
19468eff | 403 | && SCM_INUMP (SCM_VELTS (sbd_time)[8]), |
b9525b92 GH |
404 | sbd_time, pos, subr); |
405 | lt->tm_sec = SCM_INUM (SCM_VELTS (sbd_time)[0]); | |
406 | lt->tm_min = SCM_INUM (SCM_VELTS (sbd_time)[1]); | |
407 | lt->tm_hour = SCM_INUM (SCM_VELTS (sbd_time)[2]); | |
408 | lt->tm_mday = SCM_INUM (SCM_VELTS (sbd_time)[3]); | |
409 | lt->tm_mon = SCM_INUM (SCM_VELTS (sbd_time)[4]); | |
410 | lt->tm_year = SCM_INUM (SCM_VELTS (sbd_time)[5]); | |
411 | lt->tm_wday = SCM_INUM (SCM_VELTS (sbd_time)[6]); | |
412 | lt->tm_yday = SCM_INUM (SCM_VELTS (sbd_time)[7]); | |
413 | lt->tm_isdst = SCM_INUM (SCM_VELTS (sbd_time)[8]); | |
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; | |
425 | char *oldtz = 0; | |
426 | int err; | |
427 | ||
428 | SCM_ASSERT (SCM_NIMP (sbd_time) && SCM_VECTORP (sbd_time), sbd_time, | |
429 | SCM_ARG1, s_mktime); | |
430 | bdtime2c (sbd_time, <, SCM_ARG1, s_mktime); | |
19468eff GH |
431 | |
432 | SCM_DEFER_INTS; | |
b9525b92 | 433 | oldtz = setzone (zone, SCM_ARG2, s_mktime); |
19468eff | 434 | itime = mktime (<); |
b9525b92 | 435 | err = errno; |
19468eff GH |
436 | |
437 | /* timezone offset in seconds west of UTC. */ | |
438 | utc = gmtime (&itime); | |
b9525b92 GH |
439 | if (utc == NULL) |
440 | err = errno; | |
441 | ||
442 | if (itime != -1) | |
443 | { | |
444 | #ifdef HAVE_TM_ZONE | |
73f19016 | 445 | zname = lt.tm_zone; |
b9525b92 GH |
446 | #else |
447 | # ifdef HAVE_TZNAME | |
448 | /* must be copied before calling tzset again. */ | |
449 | char *ptr = tzname[ (lt.tm_isdst == 1) ? 1 : 0 ]; | |
450 | ||
451 | zname = scm_must_malloc (strlen (ptr) + 1, s_mktime); | |
452 | strcpy (zname, ptr); | |
4edc089c GH |
453 | # else |
454 | scm_misc_error (s_localtime, "Not fully implemented on this platform", | |
da5b3eb1 | 455 | SCM_EOL); |
4edc089c | 456 | # endif |
b9525b92 GH |
457 | #endif |
458 | } | |
459 | restorezone (zone, oldtz); | |
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; | |
479 | return result; | |
0f2d19dd JB |
480 | } |
481 | ||
19468eff GH |
482 | SCM_PROC (s_tzset, "tzset", 0, 0, 0, scm_tzset); |
483 | SCM | |
484 | scm_tzset (void) | |
0f2d19dd | 485 | { |
19468eff GH |
486 | tzset(); |
487 | return SCM_UNSPECIFIED; | |
0f2d19dd JB |
488 | } |
489 | ||
b9525b92 GH |
490 | SCM_PROC (s_strftime, "strftime", 2, 0, 0, scm_strftime); |
491 | ||
492 | SCM | |
493 | scm_strftime (format, stime) | |
494 | SCM format; | |
495 | SCM stime; | |
496 | { | |
497 | struct tm t; | |
498 | ||
499 | char *tbuf; | |
500 | int size = 50; | |
501 | char *fmt; | |
502 | int len; | |
503 | ||
89958ad0 | 504 | SCM_ASSERT (SCM_NIMP (format) && SCM_ROSTRINGP (format), format, SCM_ARG1, |
b9525b92 GH |
505 | s_strftime); |
506 | bdtime2c (stime, &t, SCM_ARG2, s_strftime); | |
507 | ||
89958ad0 | 508 | SCM_COERCE_SUBSTR (format); |
b9525b92 GH |
509 | fmt = SCM_ROCHARS (format); |
510 | len = SCM_ROLENGTH (format); | |
511 | ||
512 | tbuf = scm_must_malloc (size, s_strftime); | |
513 | while ((len = strftime (tbuf, size, fmt, &t)) == size) | |
514 | { | |
515 | scm_must_free (tbuf); | |
516 | size *= 2; | |
517 | tbuf = scm_must_malloc (size, s_strftime); | |
518 | } | |
519 | return scm_makfromstr (tbuf, len, 0); | |
520 | } | |
521 | ||
522 | SCM_PROC (s_strptime, "strptime", 2, 0, 0, scm_strptime); | |
523 | ||
524 | SCM | |
525 | scm_strptime (format, string) | |
526 | SCM format; | |
527 | SCM string; | |
528 | { | |
529 | #ifdef HAVE_STRPTIME | |
530 | struct tm t; | |
531 | char *fmt, *str, *rest; | |
532 | ||
533 | SCM_ASSERT (SCM_NIMP (format) && SCM_ROSTRINGP (format), format, SCM_ARG1, | |
534 | s_strptime); | |
535 | SCM_ASSERT (SCM_NIMP (string) && SCM_ROSTRINGP (string), string, SCM_ARG2, | |
536 | s_strptime); | |
537 | ||
89958ad0 JB |
538 | SCM_COERCE_SUBSTR (format); |
539 | SCM_COERCE_SUBSTR (string); | |
b9525b92 GH |
540 | fmt = SCM_ROCHARS (format); |
541 | str = SCM_ROCHARS (string); | |
542 | ||
543 | /* initialize the struct tm */ | |
544 | #define tm_init(field) t.field = 0 | |
545 | tm_init (tm_sec); | |
546 | tm_init (tm_min); | |
547 | tm_init (tm_hour); | |
548 | tm_init (tm_mday); | |
549 | tm_init (tm_mon); | |
550 | tm_init (tm_year); | |
551 | tm_init (tm_wday); | |
552 | tm_init (tm_yday); | |
553 | #undef tm_init | |
554 | ||
555 | t.tm_isdst = -1; | |
556 | SCM_DEFER_INTS; | |
557 | if ((rest = strptime (str, fmt, &t)) == NULL) | |
558 | scm_syserror (s_strptime); | |
559 | ||
560 | SCM_ALLOW_INTS; | |
561 | return scm_cons (filltime (&t, 0, NULL), SCM_MAKINUM (rest - str)); | |
562 | ||
563 | #else | |
564 | scm_sysmissing (s_strptime); | |
565 | #endif | |
566 | } | |
567 | ||
0f2d19dd JB |
568 | void |
569 | scm_init_stime() | |
0f2d19dd JB |
570 | { |
571 | scm_sysintern("internal-time-units-per-second", | |
19468eff | 572 | scm_long2num((long)CLKTCK)); |
0f2d19dd JB |
573 | |
574 | #ifdef HAVE_FTIME | |
575 | if (!scm_your_base.time) ftime(&scm_your_base); | |
576 | #else | |
577 | if (!scm_your_base) time(&scm_your_base); | |
578 | #endif | |
579 | ||
580 | if (!scm_my_base) scm_my_base = mytime(); | |
581 | ||
876c87ce | 582 | scm_add_feature ("current-time"); |
0f2d19dd JB |
583 | #include "stime.x" |
584 | } | |
585 |