-/* Copyright (C) 1995,1996,1997,1998, 1999, 2000 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004 Free Software Foundation, Inc.
*
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
*
- * This program is distributed in the hope that it will be useful,
+ * This library is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ */
-/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
- gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
\f
+#if HAVE_CONFIG_H
+# include <config.h>
+#endif
+
#include <stdio.h>
+#include <errno.h>
+
#include "libguile/_scm.h"
#include "libguile/feature.h"
#include "libguile/strings.h"
#include <string.h>
#endif
-# ifdef TIME_WITH_SYS_TIME
-# include <sys/time.h>
-# include <time.h>
-# else
-# ifdef HAVE_SYS_TIME_H
-# include <sys/time.h>
-# else
-# ifdef HAVE_TIME_H
-# include <time.h>
-# endif
-# endif
-# endif
-
#ifdef HAVE_SYS_TIMES_H
# include <sys/times.h>
#endif
# include <sys/timeb.h>
#endif
+#if HAVE_CRT_EXTERNS_H
+#include <crt_externs.h> /* for Darwin _NSGetEnviron */
+#endif
+
#ifndef tzname /* For SGI. */
extern char *tzname[]; /* RS6000 and others reject char **tzname. */
#endif
+#if defined (__MINGW32__)
+# define tzname _tzname
+#endif
#ifdef MISSING_STRPTIME_DECL
extern char *strptime ();
#endif
-/* This should be figured out by autoconf. */
-#if ! defined(CLKTCK) && defined(CLK_TCK)
-# define CLKTCK CLK_TCK
-#endif
-#if ! defined(CLKTCK) && defined(CLOCKS_PER_SEC)
-# define CLKTCK CLOCKS_PER_SEC
-#endif
-#if ! defined(CLKTCK)
-# define CLKTCK 60
-#endif
-
#ifdef __STDC__
# define timet time_t
#else
# define timet long
#endif
+extern char ** environ;
+
+/* On Apple Darwin in a shared library there's no "environ" to access
+ directly, instead the address of that variable must be obtained with
+ _NSGetEnviron(). */
+#if HAVE__NSGETENVIRON && defined (PIC)
+#define environ (*_NSGetEnviron())
+#endif
+
+
#ifdef HAVE_TIMES
static
timet mytime()
}
#else
# ifdef LACK_CLOCK
-# define mytime() ((time((timet*)0) - scm_your_base) * CLKTCK)
+# define mytime() ((time((timet*)0) - scm_your_base) * SCM_TIME_UNITS_PER_SECOND)
# else
# define mytime clock
# endif
#endif
-extern int errno;
-
#ifdef HAVE_FTIME
struct timeb scm_your_base = {0};
#else
SCM_DEFINE (scm_get_internal_real_time, "get-internal-real-time", 0, 0, 0,
(),
- "Returns the number of time units since the interpreter was started.")
+ "Return the number of time units since the interpreter was\n"
+ "started.")
#define FUNC_NAME s_scm_get_internal_real_time
{
#ifdef HAVE_FTIME
tmp = scm_sum (tmp,
scm_product (SCM_MAKINUM (1000),
SCM_MAKINUM (time_buffer.time)));
- return scm_quotient (scm_product (tmp, SCM_MAKINUM (CLKTCK)),
+ return scm_quotient (scm_product (tmp, SCM_MAKINUM (SCM_TIME_UNITS_PER_SECOND)),
SCM_MAKINUM (1000));
#else
- return scm_long2num((time((timet*)0) - scm_your_base) * (int)CLKTCK);
+ return scm_long2num((time((timet*)0) - scm_your_base) * (int)SCM_TIME_UNITS_PER_SECOND);
#endif /* HAVE_FTIME */
}
#undef FUNC_NAME
#ifdef HAVE_TIMES
SCM_DEFINE (scm_times, "times", 0, 0, 0,
(void),
- "Returns an object with information about real and processor time.\n"
- "The following procedures accept such an object as an argument and\n"
- "return a selected component:\n\n"
+ "Return an object with information about real and processor\n"
+ "time. The following procedures accept such an object as an\n"
+ "argument and return a selected component:\n"
+ "\n"
"@table @code\n"
"@item tms:clock\n"
"The current real time, expressed as time units relative to an\n"
"@item tms:utime\n"
"The CPU time units used by the calling process.\n"
"@item tms:stime\n"
- "The CPU time units used by the system on behalf of the calling process.\n"
+ "The CPU time units used by the system on behalf of the calling\n"
+ "process.\n"
"@item tms:cutime\n"
- "The CPU time units used by terminated child processes of the calling\n"
- "process, whose status has been collected (e.g., using @code{waitpid}).\n"
+ "The CPU time units used by terminated child processes of the\n"
+ "calling process, whose status has been collected (e.g., using\n"
+ "@code{waitpid}).\n"
"@item tms:cstime\n"
- "Similarly, the CPU times units used by the system on behalf of \n"
+ "Similarly, the CPU times units used by the system on behalf of\n"
"terminated child processes.\n"
"@end table")
#define FUNC_NAME s_scm_times
struct tms t;
clock_t rv;
- SCM result = scm_make_vector (SCM_MAKINUM(5), SCM_UNDEFINED);
+ SCM result = scm_c_make_vector (5, SCM_UNDEFINED);
rv = times (&t);
if (rv == -1)
SCM_SYSERROR;
- SCM_VELTS (result)[0] = scm_long2num (rv);
- SCM_VELTS (result)[1] = scm_long2num (t.tms_utime);
- SCM_VELTS (result)[2] = scm_long2num (t.tms_stime);
- SCM_VELTS (result)[3] = scm_long2num (t.tms_cutime);
- SCM_VELTS (result)[4] = scm_long2num (t.tms_cstime);
+ SCM_VECTOR_SET (result, 0, scm_long2num (rv));
+ SCM_VECTOR_SET (result, 1, scm_long2num (t.tms_utime));
+ SCM_VECTOR_SET (result, 2, scm_long2num (t.tms_stime));
+ SCM_VECTOR_SET (result ,3, scm_long2num (t.tms_cutime));
+ SCM_VECTOR_SET (result, 4, scm_long2num (t.tms_cstime));
return result;
}
#undef FUNC_NAME
SCM_DEFINE (scm_get_internal_run_time, "get-internal-run-time", 0, 0, 0,
(void),
- "Returns the number of time units of processor time used by the interpreter.\n"
- "Both \"system\" and \"user\" time are included but subprocesses are not.")
+ "Return the number of time units of processor time used by the\n"
+ "interpreter. Both @emph{system} and @emph{user} time are\n"
+ "included but subprocesses are not.")
#define FUNC_NAME s_scm_get_internal_run_time
{
return scm_long2num (scm_c_get_internal_run_time ());
}
#undef FUNC_NAME
+/* For reference, note that current-time and gettimeofday both should be
+ protected against setzone/restorezone changes in another thread, since on
+ DOS the system time is normally kept as local time, which means TZ
+ affects the return from current-time and gettimeofday. Not sure if DJGPP
+ etc actually has concurrent multi-threading, but it seems prudent not to
+ make assumptions about this. */
+
SCM_DEFINE (scm_current_time, "current-time", 0, 0, 0,
(void),
- "Returns the number of seconds since 1970-01-01 00:00:00 UTC, excluding\n"
- "leap seconds.")
+ "Return the number of seconds since 1970-01-01 00:00:00 UTC,\n"
+ "excluding leap seconds.")
#define FUNC_NAME s_scm_current_time
{
timet timv;
SCM_DEFER_INTS;
if ((timv = time (0)) == -1)
- SCM_SYSERROR;
+ SCM_MISC_ERROR ("current time not available", SCM_EOL);
SCM_ALLOW_INTS;
return scm_long2num((long) timv);
}
SCM_DEFINE (scm_gettimeofday, "gettimeofday", 0, 0, 0,
(void),
- "Returns a pair containing the number of seconds and microseconds since\n"
- "1970-01-01 00:00:00 UTC, excluding leap seconds. Note: whether true\n"
- "microsecond resolution is available depends on the operating system.")
+ "Return a pair containing the number of seconds and microseconds\n"
+ "since 1970-01-01 00:00:00 UTC, excluding leap seconds. Note:\n"
+ "whether true microsecond resolution is available depends on the\n"
+ "operating system.")
#define FUNC_NAME s_scm_gettimeofday
{
#ifdef HAVE_GETTIMEOFDAY
#undef FUNC_NAME
static SCM
-filltime (struct tm *bd_time, int zoff, char *zname)
+filltime (struct tm *bd_time, int zoff, const char *zname)
{
- SCM result = scm_make_vector (SCM_MAKINUM(11), SCM_UNDEFINED);
-
- SCM_VELTS (result)[0] = SCM_MAKINUM (bd_time->tm_sec);
- SCM_VELTS (result)[1] = SCM_MAKINUM (bd_time->tm_min);
- SCM_VELTS (result)[2] = SCM_MAKINUM (bd_time->tm_hour);
- SCM_VELTS (result)[3] = SCM_MAKINUM (bd_time->tm_mday);
- SCM_VELTS (result)[4] = SCM_MAKINUM (bd_time->tm_mon);
- SCM_VELTS (result)[5] = SCM_MAKINUM (bd_time->tm_year);
- SCM_VELTS (result)[6] = SCM_MAKINUM (bd_time->tm_wday);
- SCM_VELTS (result)[7] = SCM_MAKINUM (bd_time->tm_yday);
- SCM_VELTS (result)[8] = SCM_MAKINUM (bd_time->tm_isdst);
- SCM_VELTS (result)[9] = SCM_MAKINUM (zoff);
- SCM_VELTS (result)[10] = zname ? scm_makfrom0str (zname) : SCM_BOOL_F;
+ SCM result = scm_c_make_vector (11, SCM_UNDEFINED);
+
+ SCM_VECTOR_SET (result,0, SCM_MAKINUM (bd_time->tm_sec));
+ SCM_VECTOR_SET (result,1, SCM_MAKINUM (bd_time->tm_min));
+ SCM_VECTOR_SET (result,2, SCM_MAKINUM (bd_time->tm_hour));
+ SCM_VECTOR_SET (result,3, SCM_MAKINUM (bd_time->tm_mday));
+ SCM_VECTOR_SET (result,4, SCM_MAKINUM (bd_time->tm_mon));
+ SCM_VECTOR_SET (result,5, SCM_MAKINUM (bd_time->tm_year));
+ SCM_VECTOR_SET (result,6, SCM_MAKINUM (bd_time->tm_wday));
+ SCM_VECTOR_SET (result,7, SCM_MAKINUM (bd_time->tm_yday));
+ SCM_VECTOR_SET (result,8, SCM_MAKINUM (bd_time->tm_isdst));
+ SCM_VECTOR_SET (result,9, SCM_MAKINUM (zoff));
+ SCM_VECTOR_SET (result,10, zname ? scm_makfrom0str (zname) : SCM_BOOL_F);
return result;
}
static char tzvar[3] = "TZ";
-extern char ** environ;
/* if zone is set, create a temporary environment with only a TZ
string. other threads or interrupt handlers shouldn't be allowed
static char *tmpenv[2];
char *buf;
- SCM_ASSERT (SCM_ROSTRINGP (zone), zone, pos, subr);
- SCM_COERCE_SUBSTR (zone);
- buf = scm_must_malloc (SCM_LENGTH (zone) + sizeof (tzvar) + 1,
- subr);
- sprintf (buf, "%s=%s", tzvar, SCM_ROCHARS (zone));
+ SCM_ASSERT (SCM_STRINGP (zone), zone, pos, subr);
+ buf = scm_malloc (SCM_STRING_LENGTH (zone) + sizeof (tzvar) + 1);
+ sprintf (buf, "%s=%s", tzvar, SCM_STRING_CHARS (zone));
oldenv = environ;
tmpenv[0] = buf;
tmpenv[1] = 0;
}
static void
-restorezone (SCM zone, char **oldenv, const char *subr)
+restorezone (SCM zone, char **oldenv, const char *subr SCM_UNUSED)
{
if (!SCM_UNBNDP (zone))
{
- scm_must_free (environ[0]);
+ free (environ[0]);
environ = oldenv;
#ifdef HAVE_TZSET
/* for the possible benefit of user code linked with libguile. */
SCM_DEFINE (scm_localtime, "localtime", 1, 1, 0,
(SCM time, SCM zone),
- "Returns an object representing the broken down components of @var{time},\n"
- "an integer like the one returned by @code{current-time}. The time zone\n"
- "for the calculation is optionally specified by @var{zone} (a string),\n"
- "otherwise the @code{TZ} environment variable or the system default is\n"
- "used.")
+ "Return an object representing the broken down components of\n"
+ "@var{time}, an integer like the one returned by\n"
+ "@code{current-time}. The time zone for the calculation is\n"
+ "optionally specified by @var{zone} (a string), otherwise the\n"
+ "@code{TZ} environment variable or the system default is used.")
#define FUNC_NAME s_scm_localtime
{
timet itime;
char **oldenv;
int err;
- itime = SCM_NUM2LONG (1,time);
+ itime = SCM_NUM2LONG (1, time);
/* deferring interupts is essential since a) setzone may install a temporary
environment b) localtime uses a static buffer. */
#ifdef LOCALTIME_CACHE
tzset ();
#endif
+ /* POSIX says localtime sets errno, but C99 doesn't say that.
+ Give a sensible default value in case localtime doesn't set it. */
+ errno = EINVAL;
ltptr = localtime (&itime);
err = errno;
if (ltptr)
#else
ptr = "";
#endif
- zname = SCM_MUST_MALLOC (strlen (ptr) + 1);
+ zname = scm_malloc (strlen (ptr) + 1);
strcpy (zname, ptr);
}
/* the struct is copied in case localtime and gmtime share a buffer. */
if (ltptr)
lt = *ltptr;
+ /* POSIX says gmtime sets errno, but C99 doesn't say that.
+ Give a sensible default value in case gmtime doesn't set it. */
+ errno = EINVAL;
utc = gmtime (&itime);
if (utc == NULL)
err = errno;
result = filltime (<, zoff, zname);
SCM_ALLOW_INTS;
- scm_must_free (zname);
+ if (zname)
+ free (zname);
return result;
}
#undef FUNC_NAME
SCM_DEFINE (scm_gmtime, "gmtime", 1, 0, 0,
(SCM time),
- "Returns an object representing the broken down components of @var{time},\n"
- "an integer like the one returned by @code{current-time}. The values\n"
- "are calculated for UTC.")
+ "Return an object representing the broken down components of\n"
+ "@var{time}, an integer like the one returned by\n"
+ "@code{current-time}. The values are calculated for UTC.")
#define FUNC_NAME s_scm_gmtime
{
timet itime;
struct tm *bd_time;
SCM result;
+ const char *zname;
- itime = SCM_NUM2LONG (1,time);
+ itime = SCM_NUM2LONG (1, time);
SCM_DEFER_INTS;
+ /* POSIX says gmtime sets errno, but C99 doesn't say that.
+ Give a sensible default value in case gmtime doesn't set it. */
+ errno = EINVAL;
bd_time = gmtime (&itime);
if (bd_time == NULL)
SCM_SYSERROR;
- result = filltime (bd_time, 0, "GMT");
+#if HAVE_STRUCT_TM_TM_ZONE
+ zname = bd_time->tm_zone;
+#else
+ zname = "GMT";
+#endif
+ result = filltime (bd_time, 0, zname);
SCM_ALLOW_INTS;
return result;
}
static void
bdtime2c (SCM sbd_time, struct tm *lt, int pos, const char *subr)
{
- SCM *velts;
+ SCM const *velts;
int i;
SCM_ASSERT (SCM_VECTORP (sbd_time)
- && SCM_LENGTH (sbd_time) == 11,
+ && SCM_VECTOR_LENGTH (sbd_time) == 11,
sbd_time, pos, subr);
velts = SCM_VELTS (sbd_time);
for (i = 0; i < 10; i++)
"@var{bd-time} is an object representing broken down time and @code{zone}\n"
"is an optional time zone specifier (otherwise the TZ environment variable\n"
"or the system default is used).\n\n"
- "Returns a pair: the CAR is a corresponding\n"
+ "Returns a pair: the car is a corresponding\n"
"integer time value like that returned\n"
- "by @code{current-time}; the CDR is a broken down time object, similar to\n"
+ "by @code{current-time}; the cdr is a broken down time object, similar to\n"
"as @var{bd-time} but with normalized values.")
#define FUNC_NAME s_scm_mktime
{
tzset ();
#endif
itime = mktime (<);
- err = errno;
+ /* POSIX doesn't say mktime sets errno, and on glibc 2.3.2 for instance it
+ doesn't. Force a sensible value for our error message. */
+ err = EINVAL;
if (itime != -1)
{
#else
ptr = "";
#endif
- zname = SCM_MUST_MALLOC (strlen (ptr) + 1);
+ zname = scm_malloc (strlen (ptr) + 1);
strcpy (zname, ptr);
}
/* get timezone offset in seconds west of UTC. */
+ /* POSIX says gmtime sets errno, but C99 doesn't say that.
+ Give a sensible default value in case gmtime doesn't set it. */
utc = gmtime (&itime);
if (utc == NULL)
err = errno;
result = scm_cons (scm_long2num ((long) itime),
filltime (<, zoff, zname));
SCM_ALLOW_INTS;
- scm_must_free (zname);
+ if (zname)
+ free (zname);
return result;
}
#undef FUNC_NAME
int len;
SCM result;
- SCM_VALIDATE_ROSTRING (1,format);
+ SCM_VALIDATE_STRING (1, format);
bdtime2c (stime, &t, SCM_ARG2, FUNC_NAME);
- SCM_COERCE_SUBSTR (format);
- fmt = SCM_ROCHARS (format);
- len = SCM_ROLENGTH (format);
+ fmt = SCM_STRING_CHARS (format);
+ len = SCM_STRING_LENGTH (format);
/* Ugly hack: strftime can return 0 if its buffer is too small,
but some valid time strings (e.g. "%p") can sometimes produce
a zero-byte output string! Workaround is to prepend a junk
character to the format string, so that valid returns are always
nonzero. */
- myfmt = SCM_MUST_MALLOC (len+2);
+ myfmt = scm_malloc (len+2);
*myfmt = 'x';
strncpy(myfmt+1, fmt, len);
myfmt[len+1] = 0;
- tbuf = SCM_MUST_MALLOC (size);
+ tbuf = scm_malloc (size);
{
#if !defined (HAVE_TM_ZONE)
/* it seems the only way to tell non-GNU versions of strftime what
environment. interrupts and thread switching must be deferred
until TZ is restored. */
char **oldenv = NULL;
- SCM *velts = SCM_VELTS (stime);
+ SCM *velts = (SCM *) SCM_VELTS (stime);
int have_zone = 0;
- if (SCM_NFALSEP (velts[10]) && *SCM_STRING_CHARS (velts[10]) != 0)
+ if (!SCM_FALSEP (velts[10]) && *SCM_STRING_CHARS (velts[10]) != 0)
{
/* it's not required that the TZ setting be correct, just that
it has the right name. so try something like TZ=EST0.
case. */
while ((len = strftime (tbuf, size, myfmt, &t)) == 0 || len == size)
{
- scm_must_free (tbuf);
+ free (tbuf);
size *= 2;
- tbuf = SCM_MUST_MALLOC (size);
+ tbuf = scm_malloc (size);
}
#if !defined (HAVE_TM_ZONE)
#endif
}
- result = scm_makfromstr (tbuf+1, len-1, 0);
- scm_must_free (tbuf);
- scm_must_free(myfmt);
+ result = scm_mem2string (tbuf + 1, len - 1);
+ free (tbuf);
+ free (myfmt);
return result;
}
#undef FUNC_NAME
#ifdef HAVE_STRPTIME
SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0,
(SCM format, SCM string),
- "Performs the reverse action to @code{strftime}, parsing @var{string}\n"
- "according to the specification supplied in @var{template}. The\n"
- "interpretation of month and day names is dependent on the current\n"
- "locale. The\n"
- "value returned is a pair. The CAR has an object with time components \n"
+ "Performs the reverse action to @code{strftime}, parsing\n"
+ "@var{string} according to the specification supplied in\n"
+ "@var{template}. The interpretation of month and day names is\n"
+ "dependent on the current locale. The value returned is a pair.\n"
+ "The car has an object with time components\n"
"in the form returned by @code{localtime} or @code{gmtime},\n"
"but the time zone components\n"
"are not usefully set.\n"
- "The CDR reports the number of characters from @var{string} which\n"
- "were used for the conversion.")
+ "The cdr reports the number of characters from @var{string}\n"
+ "which were used for the conversion.")
#define FUNC_NAME s_scm_strptime
{
struct tm t;
char *fmt, *str, *rest;
- SCM_VALIDATE_ROSTRING (1,format);
- SCM_VALIDATE_ROSTRING (2,string);
+ SCM_VALIDATE_STRING (1, format);
+ SCM_VALIDATE_STRING (2, string);
- SCM_COERCE_SUBSTR (format);
- SCM_COERCE_SUBSTR (string);
- fmt = SCM_ROCHARS (format);
- str = SCM_ROCHARS (string);
+ fmt = SCM_STRING_CHARS (format);
+ str = SCM_STRING_CHARS (string);
/* initialize the struct tm */
#define tm_init(field) t.field = 0
tm_init (tm_yday);
#undef tm_init
+ /* GNU glibc strptime() "%s" is affected by the current timezone, since it
+ reads a UTC time_t value and converts with localtime_r() to set the tm
+ fields, hence the use of SCM_DEFER_INTS. */
t.tm_isdst = -1;
SCM_DEFER_INTS;
if ((rest = strptime (str, fmt, &t)) == NULL)
- SCM_SYSERROR;
+ {
+ /* POSIX doesn't say strptime sets errno, and on glibc 2.3.2 for
+ instance it doesn't. Force a sensible value for our error
+ message. */
+ errno = EINVAL;
+ SCM_SYSERROR;
+ }
SCM_ALLOW_INTS;
return scm_cons (filltime (&t, 0, NULL), SCM_MAKINUM (rest - str));
void
scm_init_stime()
{
- scm_sysintern("internal-time-units-per-second",
- scm_long2num((long)CLKTCK));
+ scm_c_define ("internal-time-units-per-second",
+ scm_long2num((long) SCM_TIME_UNITS_PER_SECOND));
#ifdef HAVE_FTIME
if (!scm_your_base.time) ftime(&scm_your_base);