[bpt/guile.git] / libguile / stime.c

/* Copyright (C) 1995,1996,1997,1998, 1999 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
 *
 * 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.  */
\f

#include <stdio.h>
#include "_scm.h"
#include "feature.h"

#include "stime.h"

#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif

\f
# ifdef HAVE_SYS_TYPES_H
#  include <sys/types.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

#ifdef HAVE_SYS_TIMEB_H
# include <sys/timeb.h>
#endif

#ifndef tzname /* For SGI.  */
extern char *tzname[]; /* RS6000 and others reject char **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

#ifdef HAVE_TIMES
static
long mytime()
{
  struct tms time_buffer;
  times(&time_buffer);
  return time_buffer.tms_utime + time_buffer.tms_stime;
}
#else
# ifdef LACK_CLOCK
#    define mytime() ((time((timet*)0) - scm_your_base) * CLKTCK)
# else
#  define mytime clock
# endif
#endif

extern int errno;

#ifdef HAVE_FTIME

struct timeb scm_your_base = {0};
SCM_PROC(s_get_internal_real_time, "get-internal-real-time", 0, 0, 0, scm_get_internal_real_time);
SCM
scm_get_internal_real_time()
{
  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

timet scm_your_base = 0;
SCM_PROC(s_get_internal_real_time, "get-internal-real-time", 0, 0, 0, scm_get_internal_real_time);
SCM
scm_get_internal_real_time()
{
  return scm_long2num((time((timet*)0) - scm_your_base) * (int)CLKTCK);
}
#endif

SCM_PROC (s_times, "times", 0, 0, 0, scm_times);
SCM
scm_times (void)
{
#ifdef HAVE_TIMES
  struct tms t;
  clock_t rv;

  SCM result = scm_make_vector (SCM_MAKINUM(5), SCM_UNDEFINED);
  rv = times (&t);
  if (rv == -1)
    scm_syserror (s_times);
  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);
  return result;
#else
  scm_sysmissing (s_times);
#endif
}

#ifndef HAVE_TZSET
/* GNU-WIN32's cygwin.dll doesn't have this. */
#define tzset()
#endif


static long scm_my_base = 0;

SCM_PROC(s_get_internal_run_time, "get-internal-run-time", 0, 0, 0, scm_get_internal_run_time);
SCM
scm_get_internal_run_time()
{
  return scm_long2num(mytime()-scm_my_base);
}

SCM_PROC(s_current_time, "current-time", 0, 0, 0, scm_current_time);
SCM
scm_current_time()
{
  timet timv;

  SCM_DEFER_INTS;
  if ((timv = time (0)) == -1)
    scm_syserror (s_current_time);
  SCM_ALLOW_INTS;
  return scm_long2num((long) timv);
}

SCM_PROC (s_gettimeofday, "gettimeofday", 0, 0, 0, scm_gettimeofday);
SCM
scm_gettimeofday (void)
{
#ifdef HAVE_GETTIMEOFDAY
  struct timeval time;

  SCM_DEFER_INTS;
  if (gettimeofday (&time, NULL) == -1)
    scm_syserror (s_gettimeofday);
  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)
    scm_syserror (s_gettimeofday);
  SCM_ALLOW_INTS;
  return scm_cons (scm_long2num (timv), SCM_MAKINUM (0));
# endif
#endif
}

static SCM
filltime (struct tm *bd_time, int zoff, 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;
  return result;
}

static char tzvar[3] = "TZ";
extern char ** environ;

static char **
setzone (SCM zone, int pos, const char *subr)
{
  char **oldenv = 0;

  if (!SCM_UNBNDP (zone))
    {
      static char *tmpenv[2];
      char *buf;

      /* if zone was supplied, set the environment temporarily.  */
      SCM_ASSERT (SCM_NIMP (zone) && 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));
      oldenv = environ;
      tmpenv[0] = buf;
      tmpenv[1] = 0;
      environ = tmpenv;
      tzset();
    }
  return oldenv;
}

static void
restorezone (SCM zone, char **oldenv, const char *subr)
{
  if (!SCM_UNBNDP (zone))
    {
      scm_must_free (environ[0]);
      environ = oldenv;
      tzset();
    }
}


SCM_PROC (s_localtime, "localtime", 1, 1, 0, scm_localtime);
SCM
scm_localtime (SCM time, SCM zone)
{
  timet itime;
  struct tm *ltptr, lt, *utc;
  SCM result;
  int zoff;
  char *zname = 0;
  char **oldenv;
  int err;

  itime = scm_num2long (time, (char *) SCM_ARG1, s_localtime);
  SCM_DEFER_INTS;
  oldenv = setzone (zone, SCM_ARG2, s_localtime);
  ltptr = localtime (&itime);
  err = errno;
  if (ltptr)
    {
      const char *ptr;

      /* copy zone name before calling gmtime or tzset.  */
#ifdef HAVE_TM_ZONE
      ptr = ltptr->tm_zone;
#else
# ifdef HAVE_TZNAME
      ptr = tzname[ (ltptr->tm_isdst == 1) ? 1 : 0 ];
# else
      scm_misc_error (s_localtime, "Not fully implemented on this platform",
		      SCM_EOL);
# endif
#endif
      zname = scm_must_malloc (strlen (ptr) + 1, s_localtime);
      strcpy (zname, ptr);
    }
  /* the struct is copied in case localtime and gmtime share a buffer.  */
  if (ltptr)
    lt = *ltptr;
  utc = gmtime (&itime);
  if (utc == NULL)
    err = errno;
  restorezone (zone, oldenv, s_localtime);
  /* delayed until zone has been restored.  */
  errno = err;
  if (utc == NULL || ltptr == NULL)
    scm_syserror (s_localtime);

  /* calculate timezone offset in seconds west of UTC.  */
  zoff = (utc->tm_hour - lt.tm_hour) * 3600 + (utc->tm_min - lt.tm_min) * 60
    + utc->tm_sec - lt.tm_sec;
  if (utc->tm_year < lt.tm_year)
    zoff -= 24 * 60 * 60;
  else if (utc->tm_year > lt.tm_year)
    zoff += 24 * 60 * 60;
  else if (utc->tm_yday < lt.tm_yday)
    zoff -= 24 * 60 * 60;
  else if (utc->tm_yday > lt.tm_yday)
    zoff += 24 * 60 * 60;
  
  result = filltime (&lt, zoff, zname);
  SCM_ALLOW_INTS;
  scm_must_free (zname);
  return result;
}

SCM_PROC (s_gmtime, "gmtime", 1, 0, 0, scm_gmtime);
SCM
scm_gmtime (SCM time)
{
  timet itime;
  struct tm *bd_time;
  SCM result;

  itime = scm_num2long (time, (char *) SCM_ARG1, s_gmtime);
  SCM_DEFER_INTS;
  bd_time = gmtime (&itime);
  if (bd_time == NULL)
    scm_syserror (s_gmtime);
  result = filltime (bd_time, 0, "GMT");
  SCM_ALLOW_INTS;
  return result;
}

/* copy time components from a Scheme object to a struct tm.  */
static void
bdtime2c (SCM sbd_time, struct tm *lt, int pos, const char *subr)
{
  SCM_ASSERT (SCM_NIMP (sbd_time) && SCM_VECTORP (sbd_time)
	      && SCM_LENGTH (sbd_time) == 11
	      && SCM_INUMP (SCM_VELTS (sbd_time)[0]) 
	      && SCM_INUMP (SCM_VELTS (sbd_time)[1])
	      && SCM_INUMP (SCM_VELTS (sbd_time)[2])
	      && SCM_INUMP (SCM_VELTS (sbd_time)[3])
	      && SCM_INUMP (SCM_VELTS (sbd_time)[4])
	      && SCM_INUMP (SCM_VELTS (sbd_time)[5])
	      && SCM_INUMP (SCM_VELTS (sbd_time)[6])
	      && SCM_INUMP (SCM_VELTS (sbd_time)[7])
	      && SCM_INUMP (SCM_VELTS (sbd_time)[8])
	      && SCM_STRINGP (SCM_VELTS (sbd_time)[10]),
	      sbd_time, pos, subr);
  lt->tm_sec = SCM_INUM (SCM_VELTS (sbd_time)[0]);
  lt->tm_min = SCM_INUM (SCM_VELTS (sbd_time)[1]);
  lt->tm_hour = SCM_INUM (SCM_VELTS (sbd_time)[2]);
  lt->tm_mday = SCM_INUM (SCM_VELTS (sbd_time)[3]);
  lt->tm_mon = SCM_INUM (SCM_VELTS (sbd_time)[4]);
  lt->tm_year = SCM_INUM (SCM_VELTS (sbd_time)[5]);
  lt->tm_wday = SCM_INUM (SCM_VELTS (sbd_time)[6]);
  lt->tm_yday = SCM_INUM (SCM_VELTS (sbd_time)[7]);
  lt->tm_isdst = SCM_INUM (SCM_VELTS (sbd_time)[8]);
#ifdef HAVE_TM_ZONE
  lt->tm_gmtoff = SCM_INUM (SCM_VELTS (sbd_time)[9]);
  lt->tm_zone  = SCM_CHARS (SCM_VELTS (sbd_time)[10]);
#endif
}

SCM_PROC (s_mktime, "mktime", 1, 1, 0, scm_mktime);
SCM
scm_mktime (SCM sbd_time, SCM zone)
{
  timet itime;
  struct tm lt, *utc;
  SCM result;
  int zoff;
  char *zname = 0;
  char **oldenv;
  int err;

  SCM_ASSERT (SCM_NIMP (sbd_time) && SCM_VECTORP (sbd_time), sbd_time,
	      SCM_ARG1, s_mktime);
  bdtime2c (sbd_time, &lt, SCM_ARG1, s_mktime);

  SCM_DEFER_INTS;
  oldenv = setzone (zone, SCM_ARG2, s_mktime);
  itime = mktime (&lt);
  err = errno;

  if (itime != -1)
    {
      const char *ptr;

      /* copy zone name before calling gmtime or tzset.  */
#ifdef HAVE_TM_ZONE
      ptr = lt.tm_zone;
#else
# ifdef HAVE_TZNAME
      ptr = tzname[ (lt.tm_isdst == 1) ? 1 : 0 ];
# else
      scm_misc_error (s_mktime, "Not fully implemented on this platform",
		      SCM_EOL);
# endif
#endif
      zname = scm_must_malloc (strlen (ptr) + 1, s_mktime);
      strcpy (zname, ptr);
    }

  /* get timezone offset in seconds west of UTC.  */
  utc = gmtime (&itime);
  if (utc == NULL)
    err = errno;

  restorezone (zone, oldenv, s_mktime);
  /* delayed until zone has been restored.  */
  errno = err;
  if (utc == NULL || itime == -1)
    scm_syserror (s_mktime);

  zoff = (utc->tm_hour - lt.tm_hour) * 3600 + (utc->tm_min - lt.tm_min) * 60
    + utc->tm_sec - lt.tm_sec;
  if (utc->tm_year < lt.tm_year)
    zoff -= 24 * 60 * 60;
  else if (utc->tm_year > lt.tm_year)
    zoff += 24 * 60 * 60;
  else if (utc->tm_yday < lt.tm_yday)
    zoff -= 24 * 60 * 60;
  else if (utc->tm_yday > lt.tm_yday)
    zoff += 24 * 60 * 60;

  result = scm_cons (scm_long2num ((long) itime),
		     filltime (&lt, zoff, zname));
  SCM_ALLOW_INTS;
  scm_must_free (zname);
  return result;
}

SCM_PROC (s_tzset, "tzset", 0, 0, 0, scm_tzset);
SCM
scm_tzset (void)
{
  tzset();
  return SCM_UNSPECIFIED;
}

SCM_PROC (s_strftime, "strftime", 2, 0, 0, scm_strftime);

SCM
scm_strftime (format, stime)
     SCM format;
     SCM stime;
{
  struct tm t;

  char *tbuf;
  int size = 50;
  char *fmt;
  int len;
  SCM result;

  SCM_ASSERT (SCM_NIMP (format) && SCM_ROSTRINGP (format), format, SCM_ARG1,
	      s_strftime);
  bdtime2c (stime, &t, SCM_ARG2, s_strftime);

  SCM_COERCE_SUBSTR (format);
  fmt = SCM_ROCHARS (format);
  len = SCM_ROLENGTH (format);

  tbuf = scm_must_malloc (size, s_strftime);
  while ((len = strftime (tbuf, size, fmt, &t)) == size)
    {
      scm_must_free (tbuf);
      size *= 2;
      tbuf = scm_must_malloc (size, s_strftime);
    }
  result = scm_makfromstr (tbuf, len, 0);
  scm_must_free (tbuf);
  return result;
}

SCM_PROC (s_strptime, "strptime", 2, 0, 0, scm_strptime);

SCM
scm_strptime (format, string)
     SCM format;
     SCM string;
{
#ifdef HAVE_STRPTIME
  struct tm t;
  char *fmt, *str, *rest;

  SCM_ASSERT (SCM_NIMP (format) && SCM_ROSTRINGP (format), format, SCM_ARG1,
	      s_strptime);
  SCM_ASSERT (SCM_NIMP (string) && SCM_ROSTRINGP (string), string, SCM_ARG2,
	      s_strptime);

  SCM_COERCE_SUBSTR (format);
  SCM_COERCE_SUBSTR (string);
  fmt = SCM_ROCHARS (format);
  str = SCM_ROCHARS (string);

  /* initialize the struct tm */
#define tm_init(field) t.field = 0
  tm_init (tm_sec);
  tm_init (tm_min);
  tm_init (tm_hour);
  tm_init (tm_mday);
  tm_init (tm_mon);
  tm_init (tm_year);
  tm_init (tm_wday);
  tm_init (tm_yday);
#undef tm_init

  t.tm_isdst = -1;
  SCM_DEFER_INTS;
  if ((rest = strptime (str, fmt, &t)) == NULL)
    scm_syserror (s_strptime);

  SCM_ALLOW_INTS;
  return scm_cons (filltime (&t, 0, NULL),  SCM_MAKINUM (rest - str));

#else
  scm_sysmissing (s_strptime);
#endif
}

void
scm_init_stime()
{
  scm_sysintern("internal-time-units-per-second",
		scm_long2num((long)CLKTCK));

#ifdef HAVE_FTIME
  if (!scm_your_base.time) ftime(&scm_your_base);
#else
  if (!scm_your_base) time(&scm_your_base);
#endif

  if (!scm_my_base) scm_my_base = mytime();

  scm_add_feature ("current-time");
#include "stime.x"
}
Commit	Line	Data
c7abe4f3	1	/* Copyright (C) 1995,1996,1997,1998, 1999 Free Software Foundation, Inc.
0f2d19dd JB	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
82892bed JB	15	* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
82892bed JB	16	* Boston, MA 02111-1307 USA
0f2d19dd JB	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.
82892bed	40	* If you do not wish that, delete this exception notice. */
0f2d19dd JB	41	\f
	42
	43	#include <stdio.h>
	44	#include "_scm.h"
876c87ce	45	#include "feature.h"
20e6290e JB	46
	47	#include "stime.h"
	48
0f2d19dd JB	49	#ifdef HAVE_UNISTD_H
	50	#include <unistd.h>
	51	#endif
	52
	53	\f
	54	# ifdef HAVE_SYS_TYPES_H
	55	# include <sys/types.h>
	56	# endif
	57
	58	# ifdef TIME_WITH_SYS_TIME
	59	# include <sys/time.h>
	60	# include <time.h>
	61	# else
	62	# ifdef HAVE_SYS_TIME_H
	63	# include <sys/time.h>
	64	# else
	65	# ifdef HAVE_TIME_H
	66	# include <time.h>
	67	# endif
	68	# endif
	69	# endif
	70
b1978258 GH	71	#ifdef HAVE_SYS_TIMES_H
	72	# include <sys/times.h>
	73	#endif
	74
	75	#ifdef HAVE_SYS_TIMEB_H
	76	# include <sys/timeb.h>
	77	#endif
0f2d19dd	78
b9525b92 GH	79	#ifndef tzname /* For SGI. */
	80	extern char tzname[]; / RS6000 and others reject char *tzname. /
	81	#endif
	82
4d3bacdd JB	83	#ifdef MISSING_STRPTIME_DECL
	84	extern char *strptime ();
	85	#endif
	86
cda55316	87	/* This should be figured out by autoconf. */
a2fc27b5 JB	88	#if ! defined(CLKTCK) && defined(CLK_TCK)
	89	# define CLKTCK CLK_TCK
	90	#endif
	91	#if ! defined(CLKTCK) && defined(CLOCKS_PER_SEC)
0f2d19dd	92	# define CLKTCK CLOCKS_PER_SEC
a2fc27b5 JB	93	#endif
a2fc27b5 JB	94	#if ! defined(CLKTCK)
0f2d19dd	95	# define CLKTCK 60
0f2d19dd JB	96	#endif
0f2d19dd JB	97
a2fc27b5	98
0f2d19dd JB	99	#ifdef __STDC__
	100	# define timet time_t
	101	#else
	102	# define timet long
	103	#endif
	104
	105	#ifdef HAVE_TIMES
0f2d19dd JB	106	static
0f2d19dd JB	107	long mytime()
0f2d19dd JB	108	{
	109	struct tms time_buffer;
	110	times(&time_buffer);
	111	return time_buffer.tms_utime + time_buffer.tms_stime;
	112	}
	113	#else
	114	# ifdef LACK_CLOCK
	115	# define mytime() ((time((timet)0) - scm_your_base) CLKTCK)
	116	# else
	117	# define mytime clock
	118	# endif
	119	#endif
	120
19468eff	121	extern int errno;
0f2d19dd JB	122
	123	#ifdef HAVE_FTIME
	124
	125	struct timeb scm_your_base = {0};
	126	SCM_PROC(s_get_internal_real_time, "get-internal-real-time", 0, 0, 0, scm_get_internal_real_time);
0f2d19dd JB	127	SCM
0f2d19dd JB	128	scm_get_internal_real_time()
0f2d19dd JB	129	{
0f2d19dd JB	130	struct timeb time_buffer;
55c4d089 JB	131
	132	SCM tmp;
	133	ftime (&time_buffer);
0f2d19dd	134	time_buffer.time -= scm_your_base.time;
55c4d089 JB	135	tmp = scm_long2num (time_buffer.millitm - scm_your_base.millitm);
	136	tmp = scm_sum (tmp,
	137	scm_product (SCM_MAKINUM (1000),
	138	SCM_MAKINUM (time_buffer.time)));
	139	return scm_quotient (scm_product (tmp, SCM_MAKINUM (CLKTCK)),
	140	SCM_MAKINUM (1000));
	141	};
0f2d19dd JB	142
	143	#else
	144
	145	timet scm_your_base = 0;
	146	SCM_PROC(s_get_internal_real_time, "get-internal-real-time", 0, 0, 0, scm_get_internal_real_time);
0f2d19dd JB	147	SCM
0f2d19dd JB	148	scm_get_internal_real_time()
0f2d19dd	149	{
19468eff	150	return scm_long2num((time((timet)0) - scm_your_base) (int)CLKTCK);
0f2d19dd JB	151	}
	152	#endif
	153
6afcd3b2 GH	154	SCM_PROC (s_times, "times", 0, 0, 0, scm_times);
	155	SCM
	156	scm_times (void)
	157	{
	158	#ifdef HAVE_TIMES
	159	struct tms t;
	160	clock_t rv;
	161
a8741caa	162	SCM result = scm_make_vector (SCM_MAKINUM(5), SCM_UNDEFINED);
6afcd3b2 GH	163	rv = times (&t);
	164	if (rv == -1)
	165	scm_syserror (s_times);
	166	SCM_VELTS (result)[0] = scm_long2num (rv);
	167	SCM_VELTS (result)[1] = scm_long2num (t.tms_utime);
	168	SCM_VELTS (result)[2] = scm_long2num (t.tms_stime);
	169	SCM_VELTS (result)[3] = scm_long2num (t.tms_cutime);
	170	SCM_VELTS (result)[4] = scm_long2num (t.tms_cstime);
	171	return result;
	172	#else
	173	scm_sysmissing (s_times);
	174	#endif
	175	}
	176
0e958795 JB	177	#ifndef HAVE_TZSET
	178	/* GNU-WIN32's cygwin.dll doesn't have this. */
	179	#define tzset()
	180	#endif
0f2d19dd JB	181
	182
	183	static long scm_my_base = 0;
	184
	185	SCM_PROC(s_get_internal_run_time, "get-internal-run-time", 0, 0, 0, scm_get_internal_run_time);
0f2d19dd JB	186	SCM
0f2d19dd JB	187	scm_get_internal_run_time()
0f2d19dd	188	{
19468eff	189	return scm_long2num(mytime()-scm_my_base);
0f2d19dd JB	190	}
	191
	192	SCM_PROC(s_current_time, "current-time", 0, 0, 0, scm_current_time);
0f2d19dd JB	193	SCM
0f2d19dd JB	194	scm_current_time()
0f2d19dd	195	{
19468eff GH	196	timet timv;
	197
	198	SCM_DEFER_INTS;
	199	if ((timv = time (0)) == -1)
	200	scm_syserror (s_current_time);
	201	SCM_ALLOW_INTS;
	202	return scm_long2num((long) timv);
	203	}
	204
1bf9865d	205	SCM_PROC (s_gettimeofday, "gettimeofday", 0, 0, 0, scm_gettimeofday);
19468eff	206	SCM
1bf9865d	207	scm_gettimeofday (void)
19468eff GH	208	{
	209	#ifdef HAVE_GETTIMEOFDAY
	210	struct timeval time;
	211
	212	SCM_DEFER_INTS;
	213	if (gettimeofday (&time, NULL) == -1)
1bf9865d	214	scm_syserror (s_gettimeofday);
19468eff GH	215	SCM_ALLOW_INTS;
	216	return scm_cons (scm_long2num ((long) time.tv_sec),
	217	scm_long2num ((long) time.tv_usec));
	218	#else
	219	# ifdef HAVE_FTIME
	220	struct timeb time;
	221
	222	ftime(&time);
	223	return scm_cons (scm_long2num ((long) time.time),
9a81afca	224	SCM_MAKINUM (time.millitm * 1000));
19468eff GH	225	# else
	226	timet timv;
	227
	228	SCM_DEFER_INTS;
	229	if ((timv = time (0)) == -1)
1bf9865d	230	scm_syserror (s_gettimeofday);
19468eff GH	231	SCM_ALLOW_INTS;
	232	return scm_cons (scm_long2num (timv), SCM_MAKINUM (0));
	233	# endif
	234	#endif
	235	}
	236
	237	static SCM
	238	filltime (struct tm bd_time, int zoff, char zname)
	239	{
a8741caa	240	SCM result = scm_make_vector (SCM_MAKINUM(11), SCM_UNDEFINED);
19468eff GH	241
	242	SCM_VELTS (result)[0] = SCM_MAKINUM (bd_time->tm_sec);
	243	SCM_VELTS (result)[1] = SCM_MAKINUM (bd_time->tm_min);
	244	SCM_VELTS (result)[2] = SCM_MAKINUM (bd_time->tm_hour);
	245	SCM_VELTS (result)[3] = SCM_MAKINUM (bd_time->tm_mday);
	246	SCM_VELTS (result)[4] = SCM_MAKINUM (bd_time->tm_mon);
	247	SCM_VELTS (result)[5] = SCM_MAKINUM (bd_time->tm_year);
	248	SCM_VELTS (result)[6] = SCM_MAKINUM (bd_time->tm_wday);
	249	SCM_VELTS (result)[7] = SCM_MAKINUM (bd_time->tm_yday);
	250	SCM_VELTS (result)[8] = SCM_MAKINUM (bd_time->tm_isdst);
	251	SCM_VELTS (result)[9] = SCM_MAKINUM (zoff);
b9525b92	252	SCM_VELTS (result)[10] = zname ? scm_makfrom0str (zname) : SCM_BOOL_F;
19468eff GH	253	return result;
	254	}
	255
ef9ff3fd GH	256	static char tzvar[3] = "TZ";
	257	extern char ** environ;
	258
	259	static char **
3eeba8d4	260	setzone (SCM zone, int pos, const char *subr)
b9525b92	261	{
ef9ff3fd	262	char **oldenv = 0;
b9525b92 GH	263
	264	if (!SCM_UNBNDP (zone))
	265	{
ef9ff3fd	266	static char *tmpenv[2];
b9525b92 GH	267	char *buf;
b9525b92 GH	268
ef9ff3fd	269	/* if zone was supplied, set the environment temporarily. */
89958ad0 JB	270	SCM_ASSERT (SCM_NIMP (zone) && SCM_ROSTRINGP (zone), zone, pos, subr);
89958ad0 JB	271	SCM_COERCE_SUBSTR (zone);
ef9ff3fd GH	272	buf = scm_must_malloc (SCM_LENGTH (zone) + sizeof (tzvar) + 1,
	273	subr);
	274	sprintf (buf, "%s=%s", tzvar, SCM_ROCHARS (zone));
	275	oldenv = environ;
	276	tmpenv[0] = buf;
	277	tmpenv[1] = 0;
	278	environ = tmpenv;
b9525b92 GH	279	tzset();
b9525b92 GH	280	}
ef9ff3fd	281	return oldenv;
b9525b92 GH	282	}
	283
	284	static void
3eeba8d4	285	restorezone (SCM zone, char *oldenv, const char subr)
b9525b92 GH	286	{
	287	if (!SCM_UNBNDP (zone))
	288	{
ef9ff3fd GH	289	scm_must_free (environ[0]);
ef9ff3fd GH	290	environ = oldenv;
b9525b92 GH	291	tzset();
	292	}
	293	}
	294
	295
19468eff GH	296	SCM_PROC (s_localtime, "localtime", 1, 1, 0, scm_localtime);
	297	SCM
	298	scm_localtime (SCM time, SCM zone)
	299	{
	300	timet itime;
4edc089c	301	struct tm ltptr, lt, utc;
19468eff GH	302	SCM result;
	303	int zoff;
	304	char *zname = 0;
ef9ff3fd	305	char **oldenv;
19468eff GH	306	int err;
	307
	308	itime = scm_num2long (time, (char *) SCM_ARG1, s_localtime);
	309	SCM_DEFER_INTS;
ef9ff3fd	310	oldenv = setzone (zone, SCM_ARG2, s_localtime);
4edc089c	311	ltptr = localtime (&itime);
19468eff	312	err = errno;
4edc089c	313	if (ltptr)
19468eff	314	{
4d3bacdd	315	const char *ptr;
ef9ff3fd GH	316
ef9ff3fd GH	317	/* copy zone name before calling gmtime or tzset. */
b9525b92	318	#ifdef HAVE_TM_ZONE
ef9ff3fd	319	ptr = ltptr->tm_zone;
b9525b92 GH	320	#else
b9525b92 GH	321	# ifdef HAVE_TZNAME
ef9ff3fd	322	ptr = tzname[ (ltptr->tm_isdst == 1) ? 1 : 0 ];
4edc089c GH	323	# else
4edc089c GH	324	scm_misc_error (s_localtime, "Not fully implemented on this platform",
da5b3eb1	325	SCM_EOL);
4edc089c	326	# endif
b9525b92	327	#endif
ef9ff3fd GH	328	zname = scm_must_malloc (strlen (ptr) + 1, s_localtime);
ef9ff3fd GH	329	strcpy (zname, ptr);
19468eff	330	}
ef9ff3fd GH	331	/* the struct is copied in case localtime and gmtime share a buffer. */
	332	if (ltptr)
	333	lt = *ltptr;
	334	utc = gmtime (&itime);
	335	if (utc == NULL)
	336	err = errno;
	337	restorezone (zone, oldenv, s_localtime);
b9525b92	338	/* delayed until zone has been restored. */
19468eff	339	errno = err;
4edc089c	340	if (utc == NULL \|\| ltptr == NULL)
19468eff GH	341	scm_syserror (s_localtime);
	342
	343	/* calculate timezone offset in seconds west of UTC. */
4edc089c GH	344	zoff = (utc->tm_hour - lt.tm_hour) * 3600 + (utc->tm_min - lt.tm_min) * 60
	345	+ utc->tm_sec - lt.tm_sec;
	346	if (utc->tm_year < lt.tm_year)
19468eff	347	zoff -= 24 * 60 * 60;
4edc089c	348	else if (utc->tm_year > lt.tm_year)
19468eff	349	zoff += 24 * 60 * 60;
4edc089c	350	else if (utc->tm_yday < lt.tm_yday)
19468eff	351	zoff -= 24 * 60 * 60;
4edc089c	352	else if (utc->tm_yday > lt.tm_yday)
19468eff GH	353	zoff += 24 * 60 * 60;
19468eff GH	354
4edc089c	355	result = filltime (&lt, zoff, zname);
19468eff	356	SCM_ALLOW_INTS;
ef9ff3fd	357	scm_must_free (zname);
19468eff GH	358	return result;
19468eff GH	359	}
19468eff GH	360
	361	SCM_PROC (s_gmtime, "gmtime", 1, 0, 0, scm_gmtime);
	362	SCM
	363	scm_gmtime (SCM time)
	364	{
	365	timet itime;
	366	struct tm *bd_time;
	367	SCM result;
	368
	369	itime = scm_num2long (time, (char *) SCM_ARG1, s_gmtime);
	370	SCM_DEFER_INTS;
	371	bd_time = gmtime (&itime);
	372	if (bd_time == NULL)
	373	scm_syserror (s_gmtime);
	374	result = filltime (bd_time, 0, "GMT");
	375	SCM_ALLOW_INTS;
	376	return result;
	377	}
	378
b9525b92 GH	379	/* copy time components from a Scheme object to a struct tm. */
b9525b92 GH	380	static void
3eeba8d4	381	bdtime2c (SCM sbd_time, struct tm lt, int pos, const char subr)
19468eff	382	{
b9525b92	383	SCM_ASSERT (SCM_NIMP (sbd_time) && SCM_VECTORP (sbd_time)
3cef7514	384	&& SCM_LENGTH (sbd_time) == 11
b9525b92	385	&& SCM_INUMP (SCM_VELTS (sbd_time)[0])
19468eff GH	386	&& SCM_INUMP (SCM_VELTS (sbd_time)[1])
	387	&& SCM_INUMP (SCM_VELTS (sbd_time)[2])
	388	&& SCM_INUMP (SCM_VELTS (sbd_time)[3])
	389	&& SCM_INUMP (SCM_VELTS (sbd_time)[4])
	390	&& SCM_INUMP (SCM_VELTS (sbd_time)[5])
b9525b92 GH	391	&& SCM_INUMP (SCM_VELTS (sbd_time)[6])
b9525b92 GH	392	&& SCM_INUMP (SCM_VELTS (sbd_time)[7])
c7abe4f3 JB	393	&& SCM_INUMP (SCM_VELTS (sbd_time)[8])
c7abe4f3 JB	394	&& SCM_STRINGP (SCM_VELTS (sbd_time)[10]),
b9525b92 GH	395	sbd_time, pos, subr);
	396	lt->tm_sec = SCM_INUM (SCM_VELTS (sbd_time)[0]);
	397	lt->tm_min = SCM_INUM (SCM_VELTS (sbd_time)[1]);
	398	lt->tm_hour = SCM_INUM (SCM_VELTS (sbd_time)[2]);
	399	lt->tm_mday = SCM_INUM (SCM_VELTS (sbd_time)[3]);
	400	lt->tm_mon = SCM_INUM (SCM_VELTS (sbd_time)[4]);
	401	lt->tm_year = SCM_INUM (SCM_VELTS (sbd_time)[5]);
	402	lt->tm_wday = SCM_INUM (SCM_VELTS (sbd_time)[6]);
	403	lt->tm_yday = SCM_INUM (SCM_VELTS (sbd_time)[7]);
	404	lt->tm_isdst = SCM_INUM (SCM_VELTS (sbd_time)[8]);
c7abe4f3 JB	405	#ifdef HAVE_TM_ZONE
	406	lt->tm_gmtoff = SCM_INUM (SCM_VELTS (sbd_time)[9]);
	407	lt->tm_zone = SCM_CHARS (SCM_VELTS (sbd_time)[10]);
	408	#endif
b9525b92 GH	409	}
	410
	411	SCM_PROC (s_mktime, "mktime", 1, 1, 0, scm_mktime);
	412	SCM
	413	scm_mktime (SCM sbd_time, SCM zone)
	414	{
	415	timet itime;
	416	struct tm lt, *utc;
	417	SCM result;
	418	int zoff;
	419	char *zname = 0;
ef9ff3fd	420	char **oldenv;
b9525b92 GH	421	int err;
	422
	423	SCM_ASSERT (SCM_NIMP (sbd_time) && SCM_VECTORP (sbd_time), sbd_time,
	424	SCM_ARG1, s_mktime);
	425	bdtime2c (sbd_time, &lt, SCM_ARG1, s_mktime);
19468eff GH	426
19468eff GH	427	SCM_DEFER_INTS;
ef9ff3fd	428	oldenv = setzone (zone, SCM_ARG2, s_mktime);
19468eff	429	itime = mktime (&lt);
b9525b92	430	err = errno;
19468eff	431
b9525b92 GH	432	if (itime != -1)
b9525b92 GH	433	{
4d3bacdd	434	const char *ptr;
ef9ff3fd GH	435
ef9ff3fd GH	436	/* copy zone name before calling gmtime or tzset. */
b9525b92	437	#ifdef HAVE_TM_ZONE
ef9ff3fd	438	ptr = lt.tm_zone;
b9525b92 GH	439	#else
b9525b92 GH	440	# ifdef HAVE_TZNAME
ef9ff3fd	441	ptr = tzname[ (lt.tm_isdst == 1) ? 1 : 0 ];
4edc089c	442	# else
ef9ff3fd	443	scm_misc_error (s_mktime, "Not fully implemented on this platform",
da5b3eb1	444	SCM_EOL);
4edc089c	445	# endif
b9525b92	446	#endif
ef9ff3fd GH	447	zname = scm_must_malloc (strlen (ptr) + 1, s_mktime);
ef9ff3fd GH	448	strcpy (zname, ptr);
b9525b92	449	}
ef9ff3fd GH	450
	451	/* get timezone offset in seconds west of UTC. */
	452	utc = gmtime (&itime);
	453	if (utc == NULL)
	454	err = errno;
	455
	456	restorezone (zone, oldenv, s_mktime);
b9525b92 GH	457	/* delayed until zone has been restored. */
	458	errno = err;
	459	if (utc == NULL \|\| itime == -1)
	460	scm_syserror (s_mktime);
	461
19468eff GH	462	zoff = (utc->tm_hour - lt.tm_hour) * 3600 + (utc->tm_min - lt.tm_min) * 60
	463	+ utc->tm_sec - lt.tm_sec;
	464	if (utc->tm_year < lt.tm_year)
	465	zoff -= 24 * 60 * 60;
	466	else if (utc->tm_year > lt.tm_year)
	467	zoff += 24 * 60 * 60;
	468	else if (utc->tm_yday < lt.tm_yday)
	469	zoff -= 24 * 60 * 60;
	470	else if (utc->tm_yday > lt.tm_yday)
	471	zoff += 24 * 60 * 60;
	472
19468eff GH	473	result = scm_cons (scm_long2num ((long) itime),
	474	filltime (&lt, zoff, zname));
	475	SCM_ALLOW_INTS;
ef9ff3fd	476	scm_must_free (zname);
19468eff	477	return result;
0f2d19dd JB	478	}
0f2d19dd JB	479
19468eff GH	480	SCM_PROC (s_tzset, "tzset", 0, 0, 0, scm_tzset);
	481	SCM
	482	scm_tzset (void)
0f2d19dd	483	{
19468eff GH	484	tzset();
19468eff GH	485	return SCM_UNSPECIFIED;
0f2d19dd JB	486	}
0f2d19dd JB	487
b9525b92 GH	488	SCM_PROC (s_strftime, "strftime", 2, 0, 0, scm_strftime);
	489
	490	SCM
	491	scm_strftime (format, stime)
	492	SCM format;
	493	SCM stime;
	494	{
	495	struct tm t;
	496
	497	char *tbuf;
	498	int size = 50;
	499	char *fmt;
	500	int len;
ef9ff3fd	501	SCM result;
b9525b92	502
89958ad0	503	SCM_ASSERT (SCM_NIMP (format) && SCM_ROSTRINGP (format), format, SCM_ARG1,
b9525b92 GH	504	s_strftime);
	505	bdtime2c (stime, &t, SCM_ARG2, s_strftime);
	506
89958ad0	507	SCM_COERCE_SUBSTR (format);
b9525b92 GH	508	fmt = SCM_ROCHARS (format);
	509	len = SCM_ROLENGTH (format);
	510
	511	tbuf = scm_must_malloc (size, s_strftime);
	512	while ((len = strftime (tbuf, size, fmt, &t)) == size)
	513	{
	514	scm_must_free (tbuf);
	515	size *= 2;
	516	tbuf = scm_must_malloc (size, s_strftime);
	517	}
ef9ff3fd GH	518	result = scm_makfromstr (tbuf, len, 0);
	519	scm_must_free (tbuf);
	520	return result;
b9525b92 GH	521	}
	522
	523	SCM_PROC (s_strptime, "strptime", 2, 0, 0, scm_strptime);
	524
	525	SCM
	526	scm_strptime (format, string)
	527	SCM format;
	528	SCM string;
	529	{
	530	#ifdef HAVE_STRPTIME
	531	struct tm t;
	532	char fmt, str, *rest;
	533
	534	SCM_ASSERT (SCM_NIMP (format) && SCM_ROSTRINGP (format), format, SCM_ARG1,
	535	s_strptime);
	536	SCM_ASSERT (SCM_NIMP (string) && SCM_ROSTRINGP (string), string, SCM_ARG2,
	537	s_strptime);
	538
89958ad0 JB	539	SCM_COERCE_SUBSTR (format);
89958ad0 JB	540	SCM_COERCE_SUBSTR (string);
b9525b92 GH	541	fmt = SCM_ROCHARS (format);
	542	str = SCM_ROCHARS (string);
	543
	544	/* initialize the struct tm */
	545	#define tm_init(field) t.field = 0
	546	tm_init (tm_sec);
	547	tm_init (tm_min);
	548	tm_init (tm_hour);
	549	tm_init (tm_mday);
	550	tm_init (tm_mon);
	551	tm_init (tm_year);
	552	tm_init (tm_wday);
	553	tm_init (tm_yday);
	554	#undef tm_init
	555
	556	t.tm_isdst = -1;
	557	SCM_DEFER_INTS;
	558	if ((rest = strptime (str, fmt, &t)) == NULL)
	559	scm_syserror (s_strptime);
	560
	561	SCM_ALLOW_INTS;
	562	return scm_cons (filltime (&t, 0, NULL), SCM_MAKINUM (rest - str));
	563
	564	#else
	565	scm_sysmissing (s_strptime);
	566	#endif
	567	}
	568
0f2d19dd JB	569	void
0f2d19dd JB	570	scm_init_stime()
0f2d19dd JB	571	{
0f2d19dd JB	572	scm_sysintern("internal-time-units-per-second",
19468eff	573	scm_long2num((long)CLKTCK));
0f2d19dd JB	574
	575	#ifdef HAVE_FTIME
	576	if (!scm_your_base.time) ftime(&scm_your_base);
	577	#else
	578	if (!scm_your_base) time(&scm_your_base);
	579	#endif
	580
	581	if (!scm_my_base) scm_my_base = mytime();
	582
876c87ce	583	scm_add_feature ("current-time");
0f2d19dd JB	584	#include "stime.x"
	585	}
	586