libguile/stime.c

   1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 Free Software Foundation, Inc.
   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
  15  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  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.
  40  * If you do not wish that, delete this exception notice.  */
  41
  42
  43 \f
  44
  45 #include <stdio.h>
  46 #include <errno.h>
  47
  48 #include "libguile/_scm.h"
  49 #include "libguile/feature.h"
  50 #include "libguile/strings.h"
  51 #include "libguile/vectors.h"
  52
  53 #include "libguile/validate.h"
  54 #include "libguile/stime.h"
  55
  56 #ifdef HAVE_UNISTD_H
  57 #include <unistd.h>
  58 #endif
  59
  60 \f
  61 # ifdef HAVE_SYS_TYPES_H
  62 #  include <sys/types.h>
  63 # endif
  64
  65 #ifdef HAVE_STRING_H
  66 #include <string.h>
  67 #endif
  68
  69 # ifdef TIME_WITH_SYS_TIME
  70 #  include <sys/time.h>
  71 #  include <time.h>
  72 # else
  73 #  ifdef HAVE_SYS_TIME_H
  74 #   include <sys/time.h>
  75 #  else
  76 #   ifdef HAVE_TIME_H
  77 #    include <time.h>
  78 #   endif
  79 #  endif
  80 # endif
  81
  82 #ifdef HAVE_SYS_TIMES_H
  83 # include <sys/times.h>
  84 #endif
  85
  86 #ifdef HAVE_SYS_TIMEB_H
  87 # include <sys/timeb.h>
  88 #endif
  89
  90 #ifndef tzname /* For SGI.  */
  91 extern char *tzname[]; /* RS6000 and others reject char **tzname.  */
  92 #endif
  93 #if defined (__MINGW32__)
  94 # define tzname _tzname
  95 #endif
  96
  97 #ifdef MISSING_STRPTIME_DECL
  98 extern char *strptime ();
  99 #endif
 100
 101 /* This should be figured out by autoconf.  */
 102 #if ! defined(CLKTCK) && defined(CLK_TCK)
 103 #  define CLKTCK ((int) CLK_TCK)
 104 #endif
 105 #if ! defined(CLKTCK) && defined(CLOCKS_PER_SEC)
 106 #  define CLKTCK ((int) CLOCKS_PER_SEC)
 107 #endif
 108 #if ! defined(CLKTCK)
 109 #  define CLKTCK 60
 110 #endif
 111
 112 #ifdef __STDC__
 113 # define timet time_t
 114 #else
 115 # define timet long
 116 #endif
 117
 118 #ifdef HAVE_TIMES
 119 static
 120 timet mytime()
 121 {
 122   struct tms time_buffer;
 123   times(&time_buffer);
 124   return time_buffer.tms_utime + time_buffer.tms_stime;
 125 }
 126 #else
 127 # ifdef LACK_CLOCK
 128 #    define mytime() ((time((timet*)0) - scm_your_base) * CLKTCK)
 129 # else
 130 #  define mytime clock
 131 # endif
 132 #endif
 133
 134 #ifdef HAVE_FTIME
 135 struct timeb scm_your_base = {0};
 136 #else
 137 timet scm_your_base = 0;
 138 #endif
 139
 140 SCM_DEFINE (scm_get_internal_real_time, "get-internal-real-time", 0, 0, 0,
 141            (),
 142             "Return the number of time units since the interpreter was\n"
 143             "started.")
 144 #define FUNC_NAME s_scm_get_internal_real_time
 145 {
 146 #ifdef HAVE_FTIME
 147   struct timeb time_buffer;
 148
 149   SCM tmp;
 150   ftime (&time_buffer);
 151   time_buffer.time -= scm_your_base.time;
 152   tmp = scm_long2num (time_buffer.millitm - scm_your_base.millitm);
 153   tmp = scm_sum (tmp,
 154                  scm_product (SCM_MAKINUM (1000),
 155                               SCM_MAKINUM (time_buffer.time)));
 156   return scm_quotient (scm_product (tmp, SCM_MAKINUM (CLKTCK)),
 157                        SCM_MAKINUM (1000));
 158 #else
 159   return scm_long2num((time((timet*)0) - scm_your_base) * (int)CLKTCK);
 160 #endif /* HAVE_FTIME */
 161 }
 162 #undef FUNC_NAME
 163
 164
 165 #ifdef HAVE_TIMES
 166 SCM_DEFINE (scm_times, "times", 0, 0, 0,
 167             (void),
 168             "Return an object with information about real and processor\n"
 169             "time.  The following procedures accept such an object as an\n"
 170             "argument and return a selected component:\n"
 171             "\n"
 172             "@table @code\n"
 173             "@item tms:clock\n"
 174             "The current real time, expressed as time units relative to an\n"
 175             "arbitrary base.\n"
 176             "@item tms:utime\n"
 177             "The CPU time units used by the calling process.\n"
 178             "@item tms:stime\n"
 179             "The CPU time units used by the system on behalf of the calling\n"
 180             "process.\n"
 181             "@item tms:cutime\n"
 182             "The CPU time units used by terminated child processes of the\n"
 183             "calling process, whose status has been collected (e.g., using\n"
 184             "@code{waitpid}).\n"
 185             "@item tms:cstime\n"
 186             "Similarly, the CPU times units used by the system on behalf of\n"
 187             "terminated child processes.\n"
 188             "@end table")
 189 #define FUNC_NAME s_scm_times
 190 {
 191   struct tms t;
 192   clock_t rv;
 193
 194   SCM result = scm_c_make_vector (5, SCM_UNDEFINED);
 195   rv = times (&t);
 196   if (rv == -1)
 197     SCM_SYSERROR;
 198   SCM_VELTS (result)[0] = scm_long2num (rv);
 199   SCM_VELTS (result)[1] = scm_long2num (t.tms_utime);
 200   SCM_VELTS (result)[2] = scm_long2num (t.tms_stime);
 201   SCM_VELTS (result)[3] = scm_long2num (t.tms_cutime);
 202   SCM_VELTS (result)[4] = scm_long2num (t.tms_cstime);
 203   return result;
 204 }
 205 #undef FUNC_NAME
 206 #endif /* HAVE_TIMES */
 207
 208 static long scm_my_base = 0;
 209
 210 long
 211 scm_c_get_internal_run_time ()
 212 {
 213   return mytime () - scm_my_base;
 214 }
 215
 216 SCM_DEFINE (scm_get_internal_run_time, "get-internal-run-time", 0, 0, 0,
 217            (void),
 218             "Return the number of time units of processor time used by the\n"
 219             "interpreter.  Both @emph{system} and @emph{user} time are\n"
 220             "included but subprocesses are not.")
 221 #define FUNC_NAME s_scm_get_internal_run_time
 222 {
 223   return scm_long2num (scm_c_get_internal_run_time ());
 224 }
 225 #undef FUNC_NAME
 226
 227 SCM_DEFINE (scm_current_time, "current-time", 0, 0, 0,
 228            (void),
 229             "Return the number of seconds since 1970-01-01 00:00:00 UTC,\n"
 230             "excluding leap seconds.")
 231 #define FUNC_NAME s_scm_current_time
 232 {
 233   timet timv;
 234
 235   SCM_DEFER_INTS;
 236   if ((timv = time (0)) == -1)
 237     SCM_SYSERROR;
 238   SCM_ALLOW_INTS;
 239   return scm_long2num((long) timv);
 240 }
 241 #undef FUNC_NAME
 242
 243 SCM_DEFINE (scm_gettimeofday, "gettimeofday", 0, 0, 0,
 244             (void),
 245             "Return a pair containing the number of seconds and microseconds\n"
 246             "since 1970-01-01 00:00:00 UTC, excluding leap seconds.  Note:\n"
 247             "whether true microsecond resolution is available depends on the\n"
 248             "operating system.")
 249 #define FUNC_NAME s_scm_gettimeofday
 250 {
 251 #ifdef HAVE_GETTIMEOFDAY
 252   struct timeval time;
 253
 254   SCM_DEFER_INTS;
 255   if (gettimeofday (&time, NULL) == -1)
 256     SCM_SYSERROR;
 257   SCM_ALLOW_INTS;
 258   return scm_cons (scm_long2num ((long) time.tv_sec),
 259                    scm_long2num ((long) time.tv_usec));
 260 #else
 261 # ifdef HAVE_FTIME
 262   struct timeb time;
 263
 264   ftime(&time);
 265   return scm_cons (scm_long2num ((long) time.time),
 266                    SCM_MAKINUM (time.millitm * 1000));
 267 # else
 268   timet timv;
 269
 270   SCM_DEFER_INTS;
 271   if ((timv = time (0)) == -1)
 272     SCM_SYSERROR;
 273   SCM_ALLOW_INTS;
 274   return scm_cons (scm_long2num (timv), SCM_MAKINUM (0));
 275 # endif
 276 #endif
 277 }
 278 #undef FUNC_NAME
 279
 280 static SCM
 281 filltime (struct tm *bd_time, int zoff, char *zname)
 282 {
 283   SCM result = scm_c_make_vector (11, SCM_UNDEFINED);
 284
 285   SCM_VELTS (result)[0] = SCM_MAKINUM (bd_time->tm_sec);
 286   SCM_VELTS (result)[1] = SCM_MAKINUM (bd_time->tm_min);
 287   SCM_VELTS (result)[2] = SCM_MAKINUM (bd_time->tm_hour);
 288   SCM_VELTS (result)[3] = SCM_MAKINUM (bd_time->tm_mday);
 289   SCM_VELTS (result)[4] = SCM_MAKINUM (bd_time->tm_mon);
 290   SCM_VELTS (result)[5] = SCM_MAKINUM (bd_time->tm_year);
 291   SCM_VELTS (result)[6] = SCM_MAKINUM (bd_time->tm_wday);
 292   SCM_VELTS (result)[7] = SCM_MAKINUM (bd_time->tm_yday);
 293   SCM_VELTS (result)[8] = SCM_MAKINUM (bd_time->tm_isdst);
 294   SCM_VELTS (result)[9] = SCM_MAKINUM (zoff);
 295   SCM_VELTS (result)[10] = zname ? scm_makfrom0str (zname) : SCM_BOOL_F;
 296   return result;
 297 }
 298
 299 static char tzvar[3] = "TZ";
 300 extern char ** environ;
 301
 302 /* if zone is set, create a temporary environment with only a TZ
 303    string.  other threads or interrupt handlers shouldn't be allowed
 304    to run until the corresponding restorezone is called.  hence the use
 305    of a static variable for tmpenv is no big deal.  */
 306 static char **
 307 setzone (SCM zone, int pos, const char *subr)
 308 {
 309   char **oldenv = 0;
 310
 311   if (!SCM_UNBNDP (zone))
 312     {
 313       static char *tmpenv[2];
 314       char *buf;
 315
 316       SCM_ASSERT (SCM_STRINGP (zone), zone, pos, subr);
 317       buf = scm_malloc (SCM_STRING_LENGTH (zone) + sizeof (tzvar) + 1);
 318       sprintf (buf, "%s=%s", tzvar, SCM_STRING_CHARS (zone));
 319       oldenv = environ;
 320       tmpenv[0] = buf;
 321       tmpenv[1] = 0;
 322       environ = tmpenv;
 323     }
 324   return oldenv;
 325 }
 326
 327 static void
 328 restorezone (SCM zone, char **oldenv, const char *subr SCM_UNUSED)
 329 {
 330   if (!SCM_UNBNDP (zone))
 331     {
 332       free (environ[0]);
 333       environ = oldenv;
 334 #ifdef HAVE_TZSET
 335       /* for the possible benefit of user code linked with libguile.  */
 336       tzset();
 337 #endif
 338     }
 339 }
 340
 341 SCM_DEFINE (scm_localtime, "localtime", 1, 1, 0,
 342             (SCM time, SCM zone),
 343             "Return an object representing the broken down components of\n"
 344             "@var{time}, an integer like the one returned by\n"
 345             "@code{current-time}.  The time zone for the calculation is\n"
 346             "optionally specified by @var{zone} (a string), otherwise the\n"
 347             "@code{TZ} environment variable or the system default is used.")
 348 #define FUNC_NAME s_scm_localtime
 349 {
 350   timet itime;
 351   struct tm *ltptr, lt, *utc;
 352   SCM result;
 353   int zoff;
 354   char *zname = 0;
 355   char **oldenv;
 356   int err;
 357
 358   itime = SCM_NUM2LONG (1, time);
 359
 360   /* deferring interupts is essential since a) setzone may install a temporary
 361      environment b) localtime uses a static buffer.  */
 362   SCM_DEFER_INTS;
 363   oldenv = setzone (zone, SCM_ARG2, FUNC_NAME);
 364 #ifdef LOCALTIME_CACHE
 365   tzset ();
 366 #endif
 367   ltptr = localtime (&itime);
 368   err = errno;
 369   if (ltptr)
 370     {
 371       const char *ptr;
 372
 373       /* copy zone name before calling gmtime or restoring zone.  */
 374 #if defined (HAVE_TM_ZONE)
 375       ptr = ltptr->tm_zone;
 376 #elif defined (HAVE_TZNAME)
 377       ptr = tzname[ (ltptr->tm_isdst == 1) ? 1 : 0 ];
 378 #else
 379       ptr = "";
 380 #endif
 381       zname = scm_malloc (strlen (ptr) + 1);
 382       strcpy (zname, ptr);
 383     }
 384   /* the struct is copied in case localtime and gmtime share a buffer.  */
 385   if (ltptr)
 386     lt = *ltptr;
 387   utc = gmtime (&itime);
 388   if (utc == NULL)
 389     err = errno;
 390   restorezone (zone, oldenv, FUNC_NAME);
 391   /* delayed until zone has been restored.  */
 392   errno = err;
 393   if (utc == NULL || ltptr == NULL)
 394     SCM_SYSERROR;
 395
 396   /* calculate timezone offset in seconds west of UTC.  */
 397   zoff = (utc->tm_hour - lt.tm_hour) * 3600 + (utc->tm_min - lt.tm_min) * 60
 398     + utc->tm_sec - lt.tm_sec;
 399   if (utc->tm_year < lt.tm_year)
 400     zoff -= 24 * 60 * 60;
 401   else if (utc->tm_year > lt.tm_year)
 402     zoff += 24 * 60 * 60;
 403   else if (utc->tm_yday < lt.tm_yday)
 404     zoff -= 24 * 60 * 60;
 405   else if (utc->tm_yday > lt.tm_yday)
 406     zoff += 24 * 60 * 60;
 407
 408   result = filltime (&lt, zoff, zname);
 409   SCM_ALLOW_INTS;
 410   if (zname)
 411     free (zname);
 412   return result;
 413 }
 414 #undef FUNC_NAME
 415
 416 SCM_DEFINE (scm_gmtime, "gmtime", 1, 0, 0,
 417             (SCM time),
 418             "Return an object representing the broken down components of\n"
 419             "@var{time}, an integer like the one returned by\n"
 420             "@code{current-time}.  The values are calculated for UTC.")
 421 #define FUNC_NAME s_scm_gmtime
 422 {
 423   timet itime;
 424   struct tm *bd_time;
 425   SCM result;
 426
 427   itime = SCM_NUM2LONG (1, time);
 428   SCM_DEFER_INTS;
 429   bd_time = gmtime (&itime);
 430   if (bd_time == NULL)
 431     SCM_SYSERROR;
 432   result = filltime (bd_time, 0, "GMT");
 433   SCM_ALLOW_INTS;
 434   return result;
 435 }
 436 #undef FUNC_NAME
 437
 438 /* copy time components from a Scheme object to a struct tm.  */
 439 static void
 440 bdtime2c (SCM sbd_time, struct tm *lt, int pos, const char *subr)
 441 {
 442   SCM *velts;
 443   int i;
 444
 445   SCM_ASSERT (SCM_VECTORP (sbd_time)
 446               && SCM_VECTOR_LENGTH (sbd_time) == 11,
 447               sbd_time, pos, subr);
 448   velts = SCM_VELTS (sbd_time);
 449   for (i = 0; i < 10; i++)
 450     {
 451       SCM_ASSERT (SCM_INUMP (velts[i]), sbd_time, pos, subr);
 452     }
 453   SCM_ASSERT (SCM_FALSEP (velts[10]) || SCM_STRINGP (velts[10]),
 454               sbd_time, pos, subr);
 455
 456   lt->tm_sec = SCM_INUM (velts[0]);
 457   lt->tm_min = SCM_INUM (velts[1]);
 458   lt->tm_hour = SCM_INUM (velts[2]);
 459   lt->tm_mday = SCM_INUM (velts[3]);
 460   lt->tm_mon = SCM_INUM (velts[4]);
 461   lt->tm_year = SCM_INUM (velts[5]);
 462   lt->tm_wday = SCM_INUM (velts[6]);
 463   lt->tm_yday = SCM_INUM (velts[7]);
 464   lt->tm_isdst = SCM_INUM (velts[8]);
 465 #ifdef HAVE_TM_ZONE
 466   lt->tm_gmtoff = SCM_INUM (velts[9]);
 467   if (SCM_FALSEP (velts[10]))
 468     lt->tm_zone = NULL;
 469   else
 470     lt->tm_zone  = SCM_STRING_CHARS (velts[10]);
 471 #endif
 472 }
 473
 474 SCM_DEFINE (scm_mktime, "mktime", 1, 1, 0,
 475             (SCM sbd_time, SCM zone),
 476             "@var{bd-time} is an object representing broken down time and @code{zone}\n"
 477             "is an optional time zone specifier (otherwise the TZ environment variable\n"
 478             "or the system default is used).\n\n"
 479             "Returns a pair: the car is a corresponding\n"
 480             "integer time value like that returned\n"
 481             "by @code{current-time}; the cdr is a broken down time object, similar to\n"
 482             "as @var{bd-time} but with normalized values.")
 483 #define FUNC_NAME s_scm_mktime
 484 {
 485   timet itime;
 486   struct tm lt, *utc;
 487   SCM result;
 488   int zoff;
 489   char *zname = 0;
 490   char **oldenv;
 491   int err;
 492
 493   bdtime2c (sbd_time, &lt, SCM_ARG1, FUNC_NAME);
 494
 495   SCM_DEFER_INTS;
 496   oldenv = setzone (zone, SCM_ARG2, FUNC_NAME);
 497 #ifdef LOCALTIME_CACHE
 498   tzset ();
 499 #endif
 500   itime = mktime (&lt);
 501   err = errno;
 502
 503   if (itime != -1)
 504     {
 505       const char *ptr;
 506
 507       /* copy zone name before calling gmtime or restoring the zone.  */
 508 #if defined (HAVE_TM_ZONE)
 509       ptr = lt.tm_zone;
 510 #elif defined (HAVE_TZNAME)
 511       ptr = tzname[ (lt.tm_isdst == 1) ? 1 : 0 ];
 512 #else
 513       ptr = "";
 514 #endif
 515       zname = scm_malloc (strlen (ptr) + 1);
 516       strcpy (zname, ptr);
 517     }
 518
 519   /* get timezone offset in seconds west of UTC.  */
 520   utc = gmtime (&itime);
 521   if (utc == NULL)
 522     err = errno;
 523
 524   restorezone (zone, oldenv, FUNC_NAME);
 525   /* delayed until zone has been restored.  */
 526   errno = err;
 527   if (utc == NULL || itime == -1)
 528     SCM_SYSERROR;
 529
 530   zoff = (utc->tm_hour - lt.tm_hour) * 3600 + (utc->tm_min - lt.tm_min) * 60
 531     + utc->tm_sec - lt.tm_sec;
 532   if (utc->tm_year < lt.tm_year)
 533     zoff -= 24 * 60 * 60;
 534   else if (utc->tm_year > lt.tm_year)
 535     zoff += 24 * 60 * 60;
 536   else if (utc->tm_yday < lt.tm_yday)
 537     zoff -= 24 * 60 * 60;
 538   else if (utc->tm_yday > lt.tm_yday)
 539     zoff += 24 * 60 * 60;
 540
 541   result = scm_cons (scm_long2num ((long) itime),
 542                      filltime (&lt, zoff, zname));
 543   SCM_ALLOW_INTS;
 544   if (zname)
 545     free (zname);
 546   return result;
 547 }
 548 #undef FUNC_NAME
 549
 550 #ifdef HAVE_TZSET
 551 SCM_DEFINE (scm_tzset, "tzset", 0, 0, 0,
 552             (void),
 553             "Initialize the timezone from the TZ environment variable\n"
 554             "or the system default.  It's not usually necessary to call this procedure\n"
 555             "since it's done automatically by other procedures that depend on the\n"
 556             "timezone.")
 557 #define FUNC_NAME s_scm_tzset
 558 {
 559   tzset();
 560   return SCM_UNSPECIFIED;
 561 }
 562 #undef FUNC_NAME
 563 #endif /* HAVE_TZSET */
 564
 565 SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0,
 566             (SCM format, SCM stime),
 567             "Formats a time specification @var{time} using @var{template}.  @var{time}\n"
 568             "is an object with time components in the form returned by @code{localtime}\n"
 569             "or @code{gmtime}.  @var{template} is a string which can include formatting\n"
 570             "specifications introduced by a @code{%} character.  The formatting of\n"
 571             "month and day names is dependent on the current locale.  The value returned\n"
 572             "is the formatted string.\n"
 573             "@xref{Formatting Date and Time, , , libc, The GNU C Library Reference Manual}.)")
 574 #define FUNC_NAME s_scm_strftime
 575 {
 576   struct tm t;
 577
 578   char *tbuf;
 579   int size = 50;
 580   char *fmt, *myfmt;
 581   int len;
 582   SCM result;
 583
 584   SCM_VALIDATE_STRING (1, format);
 585   bdtime2c (stime, &t, SCM_ARG2, FUNC_NAME);
 586
 587   fmt = SCM_STRING_CHARS (format);
 588   len = SCM_STRING_LENGTH (format);
 589
 590   /* Ugly hack: strftime can return 0 if its buffer is too small,
 591      but some valid time strings (e.g. "%p") can sometimes produce
 592      a zero-byte output string!  Workaround is to prepend a junk
 593      character to the format string, so that valid returns are always
 594      nonzero. */
 595   myfmt = scm_malloc (len+2);
 596   *myfmt = 'x';
 597   strncpy(myfmt+1, fmt, len);
 598   myfmt[len+1] = 0;
 599
 600   tbuf = scm_malloc (size);
 601   {
 602 #if !defined (HAVE_TM_ZONE)
 603     /* it seems the only way to tell non-GNU versions of strftime what
 604        zone to use (for the %Z format) is to set TZ in the
 605        environment.  interrupts and thread switching must be deferred
 606        until TZ is restored.  */
 607     char **oldenv = NULL;
 608     SCM *velts = SCM_VELTS (stime);
 609     int have_zone = 0;
 610
 611     if (!SCM_FALSEP (velts[10]) && *SCM_STRING_CHARS (velts[10]) != 0)
 612       {
 613         /* it's not required that the TZ setting be correct, just that
 614            it has the right name.  so try something like TZ=EST0.
 615            using only TZ=EST would be simpler but it doesn't work on
 616            some OSs, e.g., Solaris.  */
 617         SCM zone =
 618           scm_string_append (scm_cons (velts[10],
 619                                        scm_cons (scm_makfrom0str ("0"),
 620                                                  SCM_EOL)));
 621
 622         have_zone = 1;
 623         SCM_DEFER_INTS;
 624         oldenv = setzone (zone, SCM_ARG2, FUNC_NAME);
 625       }
 626 #endif
 627
 628 #ifdef LOCALTIME_CACHE
 629     tzset ();
 630 #endif
 631
 632     /* POSIX says strftime returns 0 on buffer overrun, but old
 633        systems (i.e. libc 4 on GNU/Linux) might return `size' in that
 634        case. */
 635     while ((len = strftime (tbuf, size, myfmt, &t)) == 0 || len == size)
 636       {
 637         free (tbuf);
 638         size *= 2;
 639         tbuf = scm_malloc (size);
 640       }
 641
 642 #if !defined (HAVE_TM_ZONE)
 643     if (have_zone)
 644       {
 645         restorezone (velts[10], oldenv, FUNC_NAME);
 646         SCM_ALLOW_INTS;
 647       }
 648 #endif
 649     }
 650
 651   result = scm_mem2string (tbuf + 1, len - 1);
 652   free (tbuf);
 653   free (myfmt);
 654   return result;
 655 }
 656 #undef FUNC_NAME
 657
 658 #ifdef HAVE_STRPTIME
 659 SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0,
 660             (SCM format, SCM string),
 661             "Performs the reverse action to @code{strftime}, parsing\n"
 662             "@var{string} according to the specification supplied in\n"
 663             "@var{template}.  The interpretation of month and day names is\n"
 664             "dependent on the current locale.  The value returned is a pair.\n"
 665             "The car has an object with time components\n"
 666             "in the form returned by @code{localtime} or @code{gmtime},\n"
 667             "but the time zone components\n"
 668             "are not usefully set.\n"
 669             "The cdr reports the number of characters from @var{string}\n"
 670             "which were used for the conversion.")
 671 #define FUNC_NAME s_scm_strptime
 672 {
 673   struct tm t;
 674   char *fmt, *str, *rest;
 675
 676   SCM_VALIDATE_STRING (1, format);
 677   SCM_VALIDATE_STRING (2, string);
 678
 679   fmt = SCM_STRING_CHARS (format);
 680   str = SCM_STRING_CHARS (string);
 681
 682   /* initialize the struct tm */
 683 #define tm_init(field) t.field = 0
 684   tm_init (tm_sec);
 685   tm_init (tm_min);
 686   tm_init (tm_hour);
 687   tm_init (tm_mday);
 688   tm_init (tm_mon);
 689   tm_init (tm_year);
 690   tm_init (tm_wday);
 691   tm_init (tm_yday);
 692 #undef tm_init
 693
 694   t.tm_isdst = -1;
 695   SCM_DEFER_INTS;
 696   if ((rest = strptime (str, fmt, &t)) == NULL)
 697     SCM_SYSERROR;
 698
 699   SCM_ALLOW_INTS;
 700   return scm_cons (filltime (&t, 0, NULL),  SCM_MAKINUM (rest - str));
 701 }
 702 #undef FUNC_NAME
 703 #endif /* HAVE_STRPTIME */
 704
 705 void
 706 scm_init_stime()
 707 {
 708   scm_c_define ("internal-time-units-per-second",
 709                 scm_long2num((long)CLKTCK));
 710
 711 #ifdef HAVE_FTIME
 712   if (!scm_your_base.time) ftime(&scm_your_base);
 713 #else
 714   if (!scm_your_base) time(&scm_your_base);
 715 #endif
 716
 717   if (!scm_my_base) scm_my_base = mytime();
 718
 719   scm_add_feature ("current-time");
 720 #include "libguile/stime.x"
 721 }
 722
 723
 724 /*
 725   Local Variables:
 726   c-file-style: "gnu"
 727   End:
 728 */