libguile/stime.c

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