-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2005, 2006,
+ * 2007, 2008, 2009, 2011, 2013, 2014 Free Software Foundation, Inc.
*
* 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.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * 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
* Lesser General Public License for more details.
*
* 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
#include <stdio.h>
#include <errno.h>
#include <strftime.h>
+#include <unistr.h>
#include "libguile/_scm.h"
#include "libguile/async.h"
#include "libguile/strings.h"
#include "libguile/vectors.h"
#include "libguile/dynwind.h"
+#include "libguile/strings.h"
#include "libguile/validate.h"
#include "libguile/stime.h"
-#ifdef HAVE_UNISTD_H
#include <unistd.h>
-#endif
\f
-# ifdef HAVE_SYS_TYPES_H
-# include <sys/types.h>
-# endif
-
-#ifdef HAVE_STRING_H
-#include <string.h>
+#ifdef HAVE_CLOCK_GETTIME
+# include <time.h>
#endif
-#ifdef HAVE_SYS_TIMES_H
-# include <sys/times.h>
-#endif
+#include <sys/types.h>
+#include <string.h>
+#include <sys/times.h>
#ifdef HAVE_SYS_TIMEB_H
# include <sys/timeb.h>
#endif
-#ifndef tzname /* For SGI. */
-extern char *tzname[]; /* RS6000 and others reject char **tzname. */
-#endif
-#if defined (__MINGW32__)
-# define tzname _tzname
-#endif
-
#if ! HAVE_DECL_STRPTIME
extern char *strptime ();
#endif
#endif
-#ifdef HAVE_TIMES
-static
-timet mytime()
+#if SCM_SIZEOF_LONG >= 8 && defined HAVE_CLOCK_GETTIME
+/* Nanoseconds on 64-bit systems with POSIX timers. */
+#define TIME_UNITS_PER_SECOND 1000000000
+#else
+/* Milliseconds for everyone else. */
+#define TIME_UNITS_PER_SECOND 1000
+#endif
+
+long scm_c_time_units_per_second = TIME_UNITS_PER_SECOND;
+
+static long
+time_from_seconds_and_nanoseconds (long s, long ns)
+{
+ return s * TIME_UNITS_PER_SECOND
+ + ns / (1000000000 / TIME_UNITS_PER_SECOND);
+}
+
+
+/* A runtime-selectable mechanism to choose a timing mechanism. Really
+ we want to use POSIX timers, but that's not always possible. Notably,
+ the user may have everything she needs at compile-time, but if she's
+ running on an SMP machine without a common clock source, she can't
+ use POSIX CPUTIME clocks. */
+static long (*get_internal_real_time) (void);
+static long (*get_internal_run_time) (void);
+
+
+#ifdef HAVE_CLOCK_GETTIME
+struct timespec posix_real_time_base;
+
+static long
+get_internal_real_time_posix_timer (void)
+{
+ struct timespec ts;
+ clock_gettime (CLOCK_REALTIME, &ts);
+ return time_from_seconds_and_nanoseconds
+ (ts.tv_sec - posix_real_time_base.tv_sec,
+ ts.tv_nsec - posix_real_time_base.tv_nsec);
+}
+
+#if defined _POSIX_CPUTIME && defined CLOCK_PROCESS_CPUTIME_ID
+/* You see, FreeBSD defines _POSIX_CPUTIME but not
+ CLOCK_PROCESS_CPUTIME_ID. */
+#define HAVE_POSIX_CPUTIME 1
+
+struct timespec posix_run_time_base;
+
+static long
+get_internal_run_time_posix_timer (void)
+{
+ struct timespec ts;
+ clock_gettime (CLOCK_PROCESS_CPUTIME_ID, &ts);
+ return time_from_seconds_and_nanoseconds
+ (ts.tv_sec - posix_run_time_base.tv_sec,
+ ts.tv_nsec - posix_run_time_base.tv_nsec);
+}
+#endif /* _POSIX_CPUTIME */
+#endif /* HAVE_CLOCKTIME */
+
+
+#ifdef HAVE_GETTIMEOFDAY
+struct timeval gettimeofday_real_time_base;
+
+static long
+get_internal_real_time_gettimeofday (void)
+{
+ struct timeval tv;
+ gettimeofday (&tv, NULL);
+ return time_from_seconds_and_nanoseconds
+ (tv.tv_sec - gettimeofday_real_time_base.tv_sec,
+ (tv.tv_usec - gettimeofday_real_time_base.tv_usec) * 1000);
+}
+#endif
+
+
+static long ticks_per_second;
+
+static long
+get_internal_run_time_times (void)
{
struct tms time_buffer;
times(&time_buffer);
- return time_buffer.tms_utime + time_buffer.tms_stime;
+ return (time_buffer.tms_utime + time_buffer.tms_stime)
+ * TIME_UNITS_PER_SECOND / ticks_per_second;
+}
+
+static timet fallback_real_time_base;
+static long
+get_internal_real_time_fallback (void)
+{
+ return time_from_seconds_and_nanoseconds
+ ((long) time (NULL) - fallback_real_time_base, 0);
}
-#else
-# ifdef LACK_CLOCK
-# define mytime() ((time((timet*)0) - scm_your_base) * SCM_TIME_UNITS_PER_SECOND)
-# else
-# define mytime clock
-# endif
-#endif
-#ifdef HAVE_FTIME
-struct timeb scm_your_base = {0};
-#else
-timet scm_your_base = 0;
-#endif
SCM_DEFINE (scm_get_internal_real_time, "get-internal-real-time", 0, 0, 0,
(),
"started.")
#define FUNC_NAME s_scm_get_internal_real_time
{
-#ifdef HAVE_FTIME
- struct timeb time_buffer;
-
- SCM tmp;
- ftime (&time_buffer);
- time_buffer.time -= scm_your_base.time;
- tmp = scm_from_long (time_buffer.millitm - scm_your_base.millitm);
- tmp = scm_sum (tmp,
- scm_product (scm_from_int (1000),
- scm_from_int (time_buffer.time)));
- return scm_quotient (scm_product (tmp,
- scm_from_int (SCM_TIME_UNITS_PER_SECOND)),
- scm_from_int (1000));
-#else
- return scm_from_long ((time((timet*)0) - scm_your_base)
- * (int)SCM_TIME_UNITS_PER_SECOND);
-#endif /* HAVE_FTIME */
+ return scm_from_long (get_internal_real_time ());
}
#undef FUNC_NAME
-#ifdef HAVE_TIMES
SCM_DEFINE (scm_times, "times", 0, 0, 0,
(void),
"Return an object with information about real and processor\n"
{
struct tms t;
clock_t rv;
+ SCM factor;
SCM result = scm_c_make_vector (5, SCM_UNDEFINED);
rv = times (&t);
if (rv == -1)
SCM_SYSERROR;
- SCM_SIMPLE_VECTOR_SET (result, 0, scm_from_long (rv));
- SCM_SIMPLE_VECTOR_SET (result, 1, scm_from_long (t.tms_utime));
- SCM_SIMPLE_VECTOR_SET (result, 2, scm_from_long (t.tms_stime));
- SCM_SIMPLE_VECTOR_SET (result ,3, scm_from_long (t.tms_cutime));
- SCM_SIMPLE_VECTOR_SET (result, 4, scm_from_long (t.tms_cstime));
+
+ factor = scm_quotient (scm_from_long (TIME_UNITS_PER_SECOND),
+ scm_from_long (ticks_per_second));
+
+ SCM_SIMPLE_VECTOR_SET (result, 0,
+ scm_product (scm_from_long (rv), factor));
+ SCM_SIMPLE_VECTOR_SET (result, 1,
+ scm_product (scm_from_long (t.tms_utime), factor));
+ SCM_SIMPLE_VECTOR_SET (result, 2,
+ scm_product (scm_from_long (t.tms_stime), factor));
+ SCM_SIMPLE_VECTOR_SET (result ,3,
+ scm_product (scm_from_long (t.tms_cutime), factor));
+ SCM_SIMPLE_VECTOR_SET (result, 4,
+ scm_product (scm_from_long (t.tms_cstime), factor));
return result;
}
#undef FUNC_NAME
-#endif /* HAVE_TIMES */
-
-static long scm_my_base = 0;
long
-scm_c_get_internal_run_time ()
+scm_c_get_internal_run_time (void)
{
- return mytime () - scm_my_base;
+ return get_internal_run_time ();
}
SCM_DEFINE (scm_get_internal_run_time, "get-internal-run-time", 0, 0, 0,
{
#ifdef HAVE_GETTIMEOFDAY
struct timeval time;
- int ret, err;
- SCM_CRITICAL_SECTION_START;
- ret = gettimeofday (&time, NULL);
- err = errno;
- SCM_CRITICAL_SECTION_END;
- if (ret == -1)
- {
- errno = err;
- SCM_SYSERROR;
- }
+ if (gettimeofday (&time, NULL))
+ SCM_SYSERROR;
+
return scm_cons (scm_from_long (time.tv_sec),
scm_from_long (time.tv_usec));
#else
-# ifdef HAVE_FTIME
- struct timeb time;
-
- ftime(&time);
- return scm_cons (scm_from_long (time.time),
- scm_from_int (time.millitm * 1000));
-# else
- timet timv;
- int err;
-
- SCM_CRITICAL_SECTION_START;
- timv = time (NULL);
- err = errno;
- SCM_CRITICAL_SECTION_END;
- if (timv == -1)
- {
- errno = err;
- SCM_SYSERROR;
- }
- return scm_cons (scm_from_long (timv), scm_from_int (0));
-# endif
+ timet t = time (NULL);
+ if (errno)
+ SCM_SYSERROR;
+ else
+ return scm_cons (scm_from_long ((long)t), SCM_INUM0);
#endif
}
#undef FUNC_NAME
result = filltime (<, zoff, zname);
SCM_CRITICAL_SECTION_END;
- if (zname)
- free (zname);
+
+ free (zname);
return result;
}
#undef FUNC_NAME
static void
bdtime2c (SCM sbd_time, struct tm *lt, int pos, const char *subr)
{
- SCM_ASSERT (scm_is_simple_vector (sbd_time)
+ SCM_ASSERT (scm_is_vector (sbd_time)
&& SCM_SIMPLE_VECTOR_LENGTH (sbd_time) == 11,
sbd_time, pos, subr);
SCM_DEFINE (scm_mktime, "mktime", 1, 1, 0,
(SCM sbd_time, SCM zone),
- "@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"
- "integer time value like that returned\n"
- "by @code{current-time}; the cdr is a broken down time object, similar to\n"
- "as @var{bd-time} but with normalized values.")
+ "@var{sbd_time} is an object representing broken down time and\n"
+ "@code{zone} is an optional time zone specifier (otherwise the\n"
+ "TZ environment variable or the system default is used).\n"
+ "\n"
+ "Returns a pair: the car is a corresponding integer time value\n"
+ "like that returned by @code{current-time}; the cdr is a broken\n"
+ "down time object, similar to as @var{sbd_time} but with\n"
+ "normalized values.")
#define FUNC_NAME s_scm_mktime
{
timet itime;
result = scm_cons (scm_from_long (itime),
filltime (<, zoff, zname));
- if (zname)
- free (zname);
+ free (zname);
scm_dynwind_end ();
return result;
char *tbuf;
int size = 50;
- const char *fmt;
+ char *fmt;
char *myfmt;
- int len;
+ size_t len;
SCM result;
SCM_VALIDATE_STRING (1, format);
bdtime2c (stime, &t, SCM_ARG2, FUNC_NAME);
- fmt = scm_i_string_chars (format);
- len = scm_i_string_length (format);
+ /* Convert string to UTF-8 so that non-ASCII characters in the
+ format are passed through unchanged. */
+ fmt = scm_to_utf8_stringn (format, &len);
/* Ugly hack: strftime can return 0 if its buffer is too small,
but some valid time strings (e.g. "%p") can sometimes produce
character to the format string, so that valid returns are always
nonzero. */
myfmt = scm_malloc (len+2);
- *myfmt = 'x';
- strncpy(myfmt+1, fmt, len);
- myfmt[len+1] = 0;
+ *myfmt = (scm_t_uint8) 'x';
+ strncpy (myfmt + 1, fmt, len);
+ myfmt[len + 1] = 0;
+ scm_remember_upto_here_1 (format);
+ free (fmt);
tbuf = scm_malloc (size);
{
#endif
}
- result = scm_from_locale_stringn (tbuf + 1, len - 1);
+ result = scm_from_utf8_string (tbuf + 1);
free (tbuf);
free (myfmt);
#if HAVE_STRUCT_TM_TM_ZONE
(SCM format, SCM string),
"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"
+ "@var{format}. 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"
#define FUNC_NAME s_scm_strptime
{
struct tm t;
- const char *fmt, *str, *rest;
+ char *fmt, *str, *rest;
+ size_t used_len;
long zoff;
SCM_VALIDATE_STRING (1, format);
SCM_VALIDATE_STRING (2, string);
- fmt = scm_i_string_chars (format);
- str = scm_i_string_chars (string);
+ /* Convert strings to UTF-8 so that non-ASCII characters are passed
+ through unchanged. */
+ fmt = scm_to_utf8_string (format);
+ str = scm_to_utf8_string (string);
/* initialize the struct tm */
#define tm_init(field) t.field = 0
instance it doesn't. Force a sensible value for our error
message. */
errno = EINVAL;
+ scm_remember_upto_here_2 (format, string);
+ free (str);
+ free (fmt);
SCM_SYSERROR;
}
zoff = 0;
#endif
+ /* Compute the number of UTF-8 characters. */
+ used_len = u8_strnlen ((scm_t_uint8*) str, rest-str);
+ scm_remember_upto_here_2 (format, string);
+ free (str);
+ free (fmt);
+
return scm_cons (filltime (&t, zoff, NULL),
- scm_from_signed_integer (rest - str));
+ scm_from_signed_integer (used_len));
}
#undef FUNC_NAME
#endif /* HAVE_STRPTIME */
scm_c_define ("internal-time-units-per-second",
scm_from_long (SCM_TIME_UNITS_PER_SECOND));
-#ifdef HAVE_FTIME
- if (!scm_your_base.time) ftime(&scm_your_base);
+ /* Init POSIX timers, and see if we can use them. */
+#ifdef HAVE_CLOCK_GETTIME
+ if (clock_gettime (CLOCK_REALTIME, &posix_real_time_base) == 0)
+ get_internal_real_time = get_internal_real_time_posix_timer;
+
+#ifdef HAVE_POSIX_CPUTIME
+ {
+ clockid_t dummy;
+
+ /* Only use the _POSIX_CPUTIME clock if it's going to work across
+ CPUs. */
+ if (clock_getcpuclockid (0, &dummy) == 0 &&
+ clock_gettime (CLOCK_PROCESS_CPUTIME_ID, &posix_run_time_base) == 0)
+ get_internal_run_time = get_internal_run_time_posix_timer;
+ else
+ errno = 0;
+ }
+#endif /* HAVE_POSIX_CPUTIME */
+#endif /* HAVE_CLOCKTIME */
+
+ /* If needed, init and use gettimeofday timer. */
+#ifdef HAVE_GETTIMEOFDAY
+ if (!get_internal_real_time
+ && gettimeofday (&gettimeofday_real_time_base, NULL) == 0)
+ get_internal_real_time = get_internal_real_time_gettimeofday;
+#endif
+
+ /* Init ticks_per_second for scm_times, and use times(2)-based
+ run-time timer if needed. */
+#ifdef _SC_CLK_TCK
+ ticks_per_second = sysconf (_SC_CLK_TCK);
#else
- if (!scm_your_base) time(&scm_your_base);
+ ticks_per_second = CLK_TCK;
#endif
+ if (!get_internal_run_time)
+ get_internal_run_time = get_internal_run_time_times;
- if (!scm_my_base) scm_my_base = mytime();
+ if (!get_internal_real_time)
+ /* No POSIX timers, gettimeofday doesn't work... badness! */
+ {
+ fallback_real_time_base = time (NULL);
+ get_internal_real_time = get_internal_real_time_fallback;
+ }
scm_add_feature ("current-time");
#include "libguile/stime.x"
HCoop / bpt / guile.git / blobdiff