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