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