libguile/stime.c

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