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