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