X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/f2c9fcb07ed55b916c3ba5f2357686fda3ad011e..479fc9a5caca8592da5cc84570fbf2335c632d6c:/libguile/stime.c diff --git a/libguile/stime.c b/libguile/stime.c index d5dbeecf3..78539d9cd 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -1,54 +1,60 @@ -/* Copyright (C) 1995,1996,1997,1998, 1999, 2000 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 program 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. - * - * 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 +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2011, 2013 Free Software Foundation, Inc. * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * 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 3 of + * the License, or (at your option) any later version. * - * 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 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. * - * 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., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA + */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ +/* _POSIX_C_SOURCE is not defined always, because it causes problems on some + systems, notably + + - FreeBSD loses all BSD and XOPEN defines. + - glibc loses some things like CLK_TCK. + - On MINGW it conflicts with the pthread headers. + + But on HP-UX _POSIX_C_SOURCE is needed, as noted, for gmtime_r. + + Perhaps a configure test could figure out what _POSIX_C_SOURCE gives and + what it takes away, and decide from that whether to use it, instead of + hard coding __hpux. */ + +#ifndef _REENTRANT +# define _REENTRANT /* ask solaris for gmtime_r prototype */ +#endif +#ifdef __hpux +#define _POSIX_C_SOURCE 199506L /* for gmtime_r prototype */ +#endif + +#ifdef HAVE_CONFIG_H +# include +#endif + #include +#include +#include +#include + #include "libguile/_scm.h" +#include "libguile/async.h" #include "libguile/feature.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" @@ -58,111 +64,141 @@ #endif -# ifdef HAVE_SYS_TYPES_H -# include -# endif - -# ifdef TIME_WITH_SYS_TIME -# include -# include -# else -# ifdef HAVE_SYS_TIME_H -# include -# else -# ifdef HAVE_TIME_H -# include -# endif -# endif -# endif - -#ifdef HAVE_SYS_TIMES_H -# include +#ifdef HAVE_CLOCK_GETTIME +# include #endif +#include +#include +#include + #ifdef HAVE_SYS_TIMEB_H # include #endif -#ifndef tzname /* For SGI. */ -extern char *tzname[]; /* RS6000 and others reject char **tzname. */ -#endif - -#ifdef MISSING_STRPTIME_DECL +#if ! HAVE_DECL_STRPTIME 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 -#ifdef HAVE_TIMES -static -long 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; } -#else -# ifdef LACK_CLOCK -# define mytime() ((time((timet*)0) - scm_your_base) * CLKTCK) -# else -# define mytime clock -# endif -#endif -extern int errno; +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); +} -#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, +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 - struct timeb time_buffer; - - SCM tmp; - ftime (&time_buffer); - time_buffer.time -= scm_your_base.time; - tmp = scm_long2num (time_buffer.millitm - scm_your_base.millitm); - tmp = scm_sum (tmp, - scm_product (SCM_MAKINUM (1000), - SCM_MAKINUM (time_buffer.time))); - return scm_quotient (scm_product (tmp, SCM_MAKINUM (CLKTCK)), - SCM_MAKINUM (1000)); -#else - return scm_long2num((time((timet*)0) - scm_your_base) * (int)CLKTCK); -#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, +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" @@ -170,117 +206,133 @@ SCM_DEFINE (scm_times, "times", 0, 0, 0, "@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 factor; - 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); + + 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 (void) +{ + return get_internal_run_time (); +} -SCM_DEFINE (scm_get_internal_run_time, "get-internal-run-time", 0, 0, 0, +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(mytime()-scm_my_base); + return scm_from_long (scm_c_get_internal_run_time ()); } #undef FUNC_NAME -SCM_DEFINE (scm_current_time, "current-time", 0, 0, 0, +/* 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, excludingleap 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_ALLOW_INTS; - return scm_long2num((long) timv); + SCM_CRITICAL_SECTION_START; + timv = time (NULL); + SCM_CRITICAL_SECTION_END; + if (timv == -1) + SCM_MISC_ERROR ("current time not available", SCM_EOL); + return scm_from_long (timv); } #undef FUNC_NAME -SCM_DEFINE (scm_gettimeofday, "gettimeofday", 0, 0, 0, +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 struct timeval time; - SCM_DEFER_INTS; - if (gettimeofday (&time, NULL) == -1) + if (gettimeofday (&time, NULL)) SCM_SYSERROR; - SCM_ALLOW_INTS; - return scm_cons (scm_long2num ((long) time.tv_sec), - scm_long2num ((long) time.tv_usec)); -#else -# ifdef HAVE_FTIME - struct timeb time; - - ftime(&time); - return scm_cons (scm_long2num ((long) time.time), - SCM_MAKINUM (time.millitm * 1000)); -# else - timet timv; - SCM_DEFER_INTS; - if ((timv = time (0)) == -1) + return scm_cons (scm_from_long (time.tv_sec), + scm_from_long (time.tv_usec)); +#else + timet t = time (NULL); + if (errno) SCM_SYSERROR; - SCM_ALLOW_INTS; - return scm_cons (scm_long2num (timv), SCM_MAKINUM (0)); -# endif + else + return scm_cons (scm_from_long ((long)t), SCM_INUM0); #endif } #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_SIMPLE_VECTOR_SET (result,0, scm_from_int (bd_time->tm_sec)); + SCM_SIMPLE_VECTOR_SET (result,1, scm_from_int (bd_time->tm_min)); + SCM_SIMPLE_VECTOR_SET (result,2, scm_from_int (bd_time->tm_hour)); + SCM_SIMPLE_VECTOR_SET (result,3, scm_from_int (bd_time->tm_mday)); + SCM_SIMPLE_VECTOR_SET (result,4, scm_from_int (bd_time->tm_mon)); + SCM_SIMPLE_VECTOR_SET (result,5, scm_from_int (bd_time->tm_year)); + SCM_SIMPLE_VECTOR_SET (result,6, scm_from_int (bd_time->tm_wday)); + SCM_SIMPLE_VECTOR_SET (result,7, scm_from_int (bd_time->tm_yday)); + SCM_SIMPLE_VECTOR_SET (result,8, scm_from_int (bd_time->tm_isdst)); + SCM_SIMPLE_VECTOR_SET (result,9, scm_from_int (zoff)); + SCM_SIMPLE_VECTOR_SET (result,10, (zname + ? scm_from_locale_string (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 @@ -295,12 +347,14 @@ setzone (SCM zone, int pos, const char *subr) { 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)); + size_t zone_len; + + zone_len = scm_to_locale_stringbuf (zone, NULL, 0); + buf = scm_malloc (zone_len + sizeof (tzvar) + 1); + strcpy (buf, tzvar); + buf[sizeof(tzvar)-1] = '='; + scm_to_locale_stringbuf (zone, buf+sizeof(tzvar), zone_len); + buf[sizeof(tzvar)+zone_len] = '\0'; oldenv = environ; tmpenv[0] = buf; tmpenv[1] = 0; @@ -310,11 +364,11 @@ setzone (SCM zone, int pos, const char *subr) } 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. */ @@ -323,13 +377,13 @@ restorezone (SCM zone, char **oldenv, const char *subr) } } -SCM_DEFINE (scm_localtime, "localtime", 1, 1, 0, +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; @@ -340,15 +394,18 @@ SCM_DEFINE (scm_localtime, "localtime", 1, 1, 0, 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. */ - SCM_DEFER_INTS; + SCM_CRITICAL_SECTION_START; oldenv = setzone (zone, SCM_ARG2, FUNC_NAME); #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) @@ -363,12 +420,15 @@ SCM_DEFINE (scm_localtime, "localtime", 1, 1, 0, #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; @@ -389,33 +449,56 @@ SCM_DEFINE (scm_localtime, "localtime", 1, 1, 0, zoff -= 24 * 60 * 60; else if (utc->tm_yday > lt.tm_yday) zoff += 24 * 60 * 60; - + result = filltime (<, zoff, zname); - SCM_ALLOW_INTS; - scm_must_free (zname); + SCM_CRITICAL_SECTION_END; + + free (zname); return result; } #undef FUNC_NAME -SCM_DEFINE (scm_gmtime, "gmtime", 1, 0, 0, +/* tm_zone is normally a pointer, not an array within struct tm, so we might + have to worry about the lifespan of what it points to. The posix specs + don't seem to say anything about this, let's assume here that tm_zone + will be a constant and therefore no protection or anything is needed + until we copy it in filltime(). */ + +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; + struct tm bd_buf, *bd_time; + const char *zname; - itime = SCM_NUM2LONG (1,time); - SCM_DEFER_INTS; + itime = SCM_NUM2LONG (1, time); + + /* 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; + +#if HAVE_GMTIME_R + bd_time = gmtime_r (&itime, &bd_buf); +#else + SCM_CRITICAL_SECTION_START; bd_time = gmtime (&itime); + if (bd_time != NULL) + bd_buf = *bd_time; + SCM_CRITICAL_SECTION_END; +#endif if (bd_time == NULL) SCM_SYSERROR; - result = filltime (bd_time, 0, "GMT"); - SCM_ALLOW_INTS; - return result; + +#if HAVE_STRUCT_TM_TM_ZONE + zname = bd_buf.tm_zone; +#else + zname = "GMT"; +#endif + return filltime (&bd_buf, 0, zname); } #undef FUNC_NAME @@ -423,47 +506,40 @@ SCM_DEFINE (scm_gmtime, "gmtime", 1, 0, 0, static void bdtime2c (SCM sbd_time, struct tm *lt, int pos, const char *subr) { - SCM *velts; - int i; - - SCM_ASSERT (SCM_VECTORP (sbd_time) - && SCM_LENGTH (sbd_time) == 11, - sbd_time, pos, subr); - velts = SCM_VELTS (sbd_time); - for (i = 0; i < 10; i++) - { - SCM_ASSERT (SCM_INUMP (velts[i]), sbd_time, pos, subr); - } - SCM_ASSERT (SCM_FALSEP (velts[10]) || SCM_STRINGP (velts[10]), + SCM_ASSERT (scm_is_simple_vector (sbd_time) + && SCM_SIMPLE_VECTOR_LENGTH (sbd_time) == 11, sbd_time, pos, subr); - lt->tm_sec = SCM_INUM (velts[0]); - lt->tm_min = SCM_INUM (velts[1]); - lt->tm_hour = SCM_INUM (velts[2]); - lt->tm_mday = SCM_INUM (velts[3]); - lt->tm_mon = SCM_INUM (velts[4]); - lt->tm_year = SCM_INUM (velts[5]); - lt->tm_wday = SCM_INUM (velts[6]); - lt->tm_yday = SCM_INUM (velts[7]); - lt->tm_isdst = SCM_INUM (velts[8]); + lt->tm_sec = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 0)); + lt->tm_min = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 1)); + lt->tm_hour = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 2)); + lt->tm_mday = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 3)); + lt->tm_mon = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 4)); + lt->tm_year = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 5)); + lt->tm_wday = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 6)); + lt->tm_yday = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 7)); + lt->tm_isdst = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 8)); +#if HAVE_STRUCT_TM_TM_GMTOFF + lt->tm_gmtoff = - scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 9)); +#endif #ifdef HAVE_TM_ZONE - lt->tm_gmtoff = SCM_INUM (velts[9]); - if (SCM_FALSEP (velts[10])) + if (scm_is_false (SCM_SIMPLE_VECTOR_REF (sbd_time, 10))) lt->tm_zone = NULL; else - lt->tm_zone = SCM_CHARS (velts[10]); + lt->tm_zone = scm_to_locale_string (SCM_SIMPLE_VECTOR_REF (sbd_time, 10)); #endif } -SCM_DEFINE (scm_mktime, "mktime", 1, 1, 0, +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; @@ -474,15 +550,23 @@ SCM_DEFINE (scm_mktime, "mktime", 1, 1, 0, char **oldenv; int err; + scm_dynwind_begin (0); + bdtime2c (sbd_time, <, SCM_ARG1, FUNC_NAME); +#if HAVE_STRUCT_TM_TM_ZONE + scm_dynwind_free ((char *)lt.tm_zone); +#endif + + scm_dynwind_critical_section (SCM_BOOL_F); - SCM_DEFER_INTS; oldenv = setzone (zone, SCM_ARG2, FUNC_NAME); #ifdef LOCALTIME_CACHE 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) { @@ -496,11 +580,14 @@ SCM_DEFINE (scm_mktime, "mktime", 1, 1, 0, #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. */ + errno = EINVAL; utc = gmtime (&itime); if (utc == NULL) err = errno; @@ -522,16 +609,17 @@ SCM_DEFINE (scm_mktime, "mktime", 1, 1, 0, else if (utc->tm_yday > lt.tm_yday) zoff += 24 * 60 * 60; - result = scm_cons (scm_long2num ((long) itime), + result = scm_cons (scm_from_long (itime), filltime (<, zoff, zname)); - SCM_ALLOW_INTS; - scm_must_free (zname); + free (zname); + + scm_dynwind_end (); return result; } #undef FUNC_NAME #ifdef HAVE_TZSET -SCM_DEFINE (scm_tzset, "tzset", 0, 0, 0, +SCM_DEFINE (scm_tzset, "tzset", 0, 0, 0, (void), "Initialize the timezone from the TZ environment variable\n" "or the system default. It's not usually necessary to call this procedure\n" @@ -547,13 +635,22 @@ SCM_DEFINE (scm_tzset, "tzset", 0, 0, 0, SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0, (SCM format, SCM stime), - "Formats a time specification @var{time} using @var{template}. @var{time}\n" - "is an object with time components in the form returned by @code{localtime}\n" - "or @code{gmtime}. @var{template} is a string which can include formatting\n" - "specifications introduced by a @code{%} character. The formatting of\n" - "month and day names is dependent on the current locale. The value returned\n" - "is the formatted string.\n" - "@xref{Formatting Date and Time, , , libc, The GNU C Library Reference Manual}.)") + "Return a string which is broken-down time structure @var{stime}\n" + "formatted according to the given @var{format} string.\n" + "\n" + "@var{format} contains field specifications introduced by a\n" + "@samp{%} character. See @ref{Formatting Calendar Time,,, libc,\n" + "The GNU C Library Reference Manual}, or @samp{man 3 strftime},\n" + "for the available formatting.\n" + "\n" + "@lisp\n" + "(strftime \"%c\" (localtime (current-time)))\n" + "@result{} \"Mon Mar 11 20:17:43 2002\"\n" + "@end lisp\n" + "\n" + "If @code{setlocale} has been called (@pxref{Locales}), month\n" + "and day names are from the current locale and in the locale\n" + "character set.") #define FUNC_NAME s_scm_strftime { struct tm t; @@ -561,17 +658,30 @@ SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0, char *tbuf; int size = 50; char *fmt; - int len; + char *myfmt; + size_t 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); - - tbuf = SCM_MUST_MALLOC (size); + /* 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 + 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_malloc (len+2); + *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); { #if !defined (HAVE_TM_ZONE) /* it seems the only way to tell non-GNU versions of strftime what @@ -579,22 +689,21 @@ SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0, environment. interrupts and thread switching must be deferred until TZ is restored. */ char **oldenv = NULL; - SCM *velts = SCM_VELTS (stime); + SCM zone_spec = SCM_SIMPLE_VECTOR_REF (stime, 10); int have_zone = 0; - if (SCM_NFALSEP (velts[10]) && *SCM_CHARS (velts[10]) != 0) + if (scm_is_true (zone_spec) && scm_c_string_length (zone_spec) > 0) { /* it's not required that the TZ setting be correct, just that it has the right name. so try something like TZ=EST0. using only TZ=EST would be simpler but it doesn't work on some OSs, e.g., Solaris. */ SCM zone = - scm_string_append (scm_cons (velts[10], - scm_cons (scm_makfrom0str ("0"), - SCM_EOL))); - + scm_string_append (scm_list_2 (zone_spec, + scm_from_locale_string ("0"))); + have_zone = 1; - SCM_DEFER_INTS; + SCM_CRITICAL_SECTION_START; oldenv = setzone (zone, SCM_ARG2, FUNC_NAME); } #endif @@ -603,24 +712,30 @@ SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0, tzset (); #endif - while ((len = strftime (tbuf, size, fmt, &t)) == size) + /* Use `nstrftime ()' from Gnulib, which supports all GNU extensions + supported by glibc. */ + while ((len = nstrftime (tbuf, size, myfmt, &t, 0, 0)) == 0) { - scm_must_free (tbuf); + free (tbuf); size *= 2; - tbuf = SCM_MUST_MALLOC (size); + tbuf = scm_malloc (size); } #if !defined (HAVE_TM_ZONE) if (have_zone) { - restorezone (velts[10], oldenv, FUNC_NAME); - SCM_ALLOW_INTS; + restorezone (zone_spec, oldenv, FUNC_NAME); + SCM_CRITICAL_SECTION_END; } #endif } - result = scm_makfromstr (tbuf, len, 0); - scm_must_free (tbuf); + result = scm_from_utf8_string (tbuf + 1); + free (tbuf); + free (myfmt); +#if HAVE_STRUCT_TM_TM_ZONE + free ((char *) t.tm_zone); +#endif return result; } #undef FUNC_NAME @@ -628,28 +743,30 @@ SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0, #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{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" "but the time zone components\n" "are not usefully set.\n" - "The CDR reports the number of characters from @var{string} which\n" - "vwere 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; + size_t used_len; + long zoff; - 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); + /* 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 @@ -661,15 +778,46 @@ SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0, tm_init (tm_year); tm_init (tm_wday); tm_init (tm_yday); +#if HAVE_STRUCT_TM_TM_GMTOFF + tm_init (tm_gmtoff); +#endif #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_CRITICAL_SECTION_START. */ t.tm_isdst = -1; - SCM_DEFER_INTS; - if ((rest = strptime (str, fmt, &t)) == NULL) - SCM_SYSERROR; + SCM_CRITICAL_SECTION_START; + rest = strptime (str, fmt, &t); + SCM_CRITICAL_SECTION_END; + if (rest == NULL) + { + /* 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_remember_upto_here_2 (format, string); + free (str); + free (fmt); + SCM_SYSERROR; + } - SCM_ALLOW_INTS; - return scm_cons (filltime (&t, 0, NULL), SCM_MAKINUM (rest - str)); + /* tm_gmtoff is set by GNU glibc strptime "%s", so capture it when + available */ +#if HAVE_STRUCT_TM_TM_GMTOFF + zoff = - t.tm_gmtoff; /* seconds west, not east */ +#else + 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 (used_len)); } #undef FUNC_NAME #endif /* HAVE_STRPTIME */ @@ -677,16 +825,52 @@ SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0, void scm_init_stime() { - scm_sysintern("internal-time-units-per-second", - scm_long2num((long)CLKTCK)); + scm_c_define ("internal-time-units-per-second", + scm_from_long (SCM_TIME_UNITS_PER_SECOND)); + + /* 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_FTIME - if (!scm_your_base.time) ftime(&scm_your_base); +#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"