* Makefile.am (EXTRA_libguile_la_SOURCES): add putenv.c.
* configure.in: move putenv from AC_CHECK_FUNCS to AC_REPLACE_FUNCS.
* putenv.c: new file, from sh-utils 1.12.
* posix.c (scm_environ): use malloc in place of scm_must_malloc
since allocation isn't for Scheme objects.
(scm_putenv): copy strings before placing in the environment.
* stime.c (scm_current_time): throw an error if time returns -1,
instead of returning #f.
(scm_get_internal_real_time, scm_get_internal_real_time): use
scm_long2num for return value instead of SCM_MAKINUM.
* stime.h: prototypes updated.
* stime.c (scm_time_in_msec): apparently unused, deleted.
* configure.in: check for gettimeofday.
* stime.c (scm_time_plus_ticks): new procedure, an scsh interface
which may be more usefully portable than a gettimeofday interface.
* stime.c (filltime): recovered static procedure.
(scm_localtime, scm_gmtime, scm_mktime, scm_tzset): recovered from
an earlier Guile.
* posix.h: add prototype for scm_close_pipe, remove prototypes for
scm_open_input_pipe, scm_open_output_pipe, change scm_mknod prototype.
* * posix.c (scm_mknod): split the mode argument into type and perms
arguments, like the extra fields returned by stat.
* fports.c (scm_pipob): set the close, free and print procedures.
(scm_close_pipe): new procedure.
* posix.c (scm_open_input_pipe, scm_open_output_pipe): deleted,
define them in boot-9.scm
+Sat Apr 5 02:39:02 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * posix.c (scm_putenv): don't check HAVE_PUTENV.
+ * Makefile.am (EXTRA_libguile_la_SOURCES): add putenv.c.
+ * configure.in: move putenv from AC_CHECK_FUNCS to AC_REPLACE_FUNCS.
+ * putenv.c: new file, from sh-utils 1.12.
+
+ * posix.c (scm_environ): use malloc in place of scm_must_malloc
+ since allocation isn't for Scheme objects.
+ (scm_putenv): copy strings before placing in the environment.
+
+ * stime.c (scm_current_time): throw an error if time returns -1,
+ instead of returning #f.
+ (scm_get_internal_real_time, scm_get_internal_real_time): use
+ scm_long2num for return value instead of SCM_MAKINUM.
+
+ * stime.h: prototypes updated.
+
+ * stime.c (scm_time_in_msec): apparently unused, deleted.
+
+Fri Apr 4 08:53:41 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * configure.in: check for gettimeofday.
+
+ * stime.c (scm_time_plus_ticks): new procedure, an scsh interface
+ which may be more usefully portable than a gettimeofday interface.
+
+Mon Mar 31 03:22:37 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * stime.c (filltime): recovered static procedure.
+ (scm_localtime, scm_gmtime, scm_mktime, scm_tzset): recovered from
+ an earlier Guile.
+
+ * posix.h: add prototype for scm_close_pipe, remove prototypes for
+ scm_open_input_pipe, scm_open_output_pipe, change scm_mknod prototype.
+
+* * posix.c (scm_mknod): split the mode argument into type and perms
+ arguments, like the extra fields returned by stat.
+
+ * fports.c (scm_pipob): set the close, free and print procedures.
+ (scm_close_pipe): new procedure.
+
+ * posix.c (scm_open_input_pipe, scm_open_output_pipe): deleted,
+ define them in boot-9.scm
+
Wed Mar 26 04:10:32 1997 Gary Houston <ghouston@actrix.gen.nz>
* ioext.c (scm_setfileno): throw a runtime error if SET_FILE_FD_FIELD
strports.c struct.c symbols.c tag.c throw.c unif.c variable.c \
vectors.c version.c vports.c weaks.c _scm.h
EXTRA_libguile_la_SOURCES = backtrace.c stacks.c debug.c srcprop.c \
-strerror.c inet_aton.c
+strerror.c inet_aton.c putenv.c
libguile_la_DEPENDENCIES = @LIBLOBJS@
libguile_la_LDADD = @LIBLOBJS@
libguile_la_LDFLAGS = -version-info 0:0 -rpath $(libdir)
strports.c struct.c symbols.c tag.c throw.c unif.c variable.c \
vectors.c version.c vports.c weaks.c _scm.h
EXTRA_libguile_la_SOURCES = backtrace.c stacks.c debug.c srcprop.c \
-strerror.c inet_aton.c
+strerror.c inet_aton.c putenv.c
libguile_la_DEPENDENCIES = @LIBLOBJS@
libguile_la_LDADD = @LIBLOBJS@
libguile_la_LDFLAGS = -version-info 0:0 -rpath $(libdir)
.deps/load.P .deps/mallocs.P .deps/markers.P .deps/mbstrings.P \
.deps/net_db.P .deps/numbers.P .deps/objprop.P .deps/options.P \
.deps/pairs.P .deps/ports.P .deps/posix.P .deps/print.P \
-.deps/procprop.P .deps/procs.P .deps/ramap.P .deps/read.P .deps/root.P \
-.deps/scmsigs.P .deps/sequences.P .deps/simpos.P .deps/smob.P \
-.deps/socket.P .deps/srcprop.P .deps/stackchk.P .deps/stacks.P \
-.deps/stime.P .deps/strerror.P .deps/strings.P .deps/strop.P \
-.deps/strorder.P .deps/strports.P .deps/struct.P .deps/symbols.P \
-.deps/tag.P .deps/throw.P .deps/unif.P .deps/variable.P .deps/vectors.P \
-.deps/version.P .deps/vports.P .deps/weaks.P
+.deps/procprop.P .deps/procs.P .deps/putenv.P .deps/ramap.P \
+.deps/read.P .deps/root.P .deps/scmsigs.P .deps/sequences.P \
+.deps/simpos.P .deps/smob.P .deps/socket.P .deps/srcprop.P \
+.deps/stackchk.P .deps/stacks.P .deps/stime.P .deps/strerror.P \
+.deps/strings.P .deps/strop.P .deps/strorder.P .deps/strports.P \
+.deps/struct.P .deps/symbols.P .deps/tag.P .deps/throw.P .deps/unif.P \
+.deps/variable.P .deps/vectors.P .deps/version.P .deps/vports.P \
+.deps/weaks.P
SOURCES = $(libguile_la_SOURCES) $(EXTRA_libguile_la_SOURCES)
OBJECTS = $(libguile_la_OBJECTS)
fi
-for ac_func in ctermid ftime getcwd geteuid lstat mkdir mknod nice putenv readlink rename rmdir select setegid seteuid setlocale setpgid setsid strftime strptime symlink sync tcgetpgrp tcsetpgrp times uname waitpid
+for ac_func in ctermid ftime getcwd geteuid gettimeofday lstat mkdir mknod nice readlink rename rmdir select setegid seteuid setlocale setpgid setsid strftime strptime symlink sync tcgetpgrp tcsetpgrp times uname waitpid
do
echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
echo "configure:2024: checking for $ac_func" >&5
done
-for ac_func in inet_aton strerror
+for ac_func in inet_aton putenv strerror
do
echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
echo "configure:2080: checking for $ac_func" >&5
AC_TYPE_SIGNAL
AC_TYPE_MODE_T
-AC_CHECK_FUNCS(ctermid ftime getcwd geteuid lstat mkdir mknod nice putenv readlink rename rmdir select setegid seteuid setlocale setpgid setsid strftime strptime symlink sync tcgetpgrp tcsetpgrp times uname waitpid)
+AC_CHECK_FUNCS(ctermid ftime getcwd geteuid gettimeofday lstat mkdir mknod nice readlink rename rmdir select setegid seteuid setlocale setpgid setsid strftime strptime symlink sync tcgetpgrp tcsetpgrp times uname waitpid)
-AC_REPLACE_FUNCS(inet_aton strerror)
+AC_REPLACE_FUNCS(inet_aton putenv strerror)
AC_FUNC_ALLOCA
scm_ptobfuns scm_pipob =
{
scm_mark0,
- 0, /* replaced by pclose in scm_init_ioext() */
- 0, /* replaced by prinpipe in scm_init_ioext() */
+ (int (*) SCM_P ((SCM))) pclose,
+ scm_prinport,
0,
(int (*) SCM_P ((int, SCM))) local_fputc,
(int (*) SCM_P ((char *, SCM))) local_fputs,
(scm_sizet (*) SCM_P ((char *, scm_sizet, scm_sizet, SCM))) local_ffwrite,
(int (*) SCM_P ((SCM))) local_fflush,
(int (*) SCM_P ((SCM))) scm_fgetc,
- 0
-}; /* replaced by pclose in scm_init_ioext() */
+ (int (*) SCM_P ((SCM))) pclose
+};
void
scm_init_fports ()
SCM_ASSERT (SCM_NULLP (env) || (SCM_NIMP (env) && SCM_CONSP (env)),
env, SCM_ARG1, s_environ);
num_strings = scm_ilength (env);
- new_environ = (char **) scm_must_malloc ((num_strings + 1)
- * sizeof (char *),
- s_environ);
+ new_environ = (char **) malloc ((num_strings + 1) * sizeof (char *));
+ if (new_environ == NULL)
+ scm_memory_error (s_environ);
while (SCM_NNULLP (env))
{
int len;
&& SCM_ROSTRINGP (SCM_CAR (env)),
env, SCM_ARG1, s_environ);
len = 1 + SCM_ROLENGTH (SCM_CAR (env));
- new_environ[i] = scm_must_malloc ((long) len, s_environ);
+ new_environ[i] = malloc ((long) len);
+ if (new_environ[i] == NULL)
+ scm_memory_error (s_environ);
src = SCM_ROCHARS (SCM_CAR (env));
while (len--)
new_environ[i][len] = src[len];
if (!first)
{
for (ep = environ; *ep != NULL; ep++)
- scm_must_free (*ep);
- scm_must_free ((char *) environ);
+ free (*ep);
+ free ((char *) environ);
}
first = 0;
}
return z;
}
+SCM_PROC (s_close_pipe, "close-pipe", 1, 0, 0, scm_close_pipe);
-SCM_PROC (s_open_input_pipe, "open-input-pipe", 1, 0, 0, scm_open_input_pipe);
-
-SCM
-scm_open_input_pipe(pipestr)
- SCM pipestr;
+SCM
+scm_close_pipe (port)
+ SCM port;
{
- return scm_open_pipe(pipestr, scm_makfromstr("r", (sizeof "r")-1, 0));
-}
-
-SCM_PROC (s_open_output_pipe, "open-output-pipe", 1, 0, 0, scm_open_output_pipe);
+ int rv;
-SCM
-scm_open_output_pipe(pipestr)
- SCM pipestr;
-{
- return scm_open_pipe(pipestr, scm_makfromstr("w", (sizeof "w")-1, 0));
+ SCM_ASSERT (SCM_NIMP (port) && SCM_TYP16(port) == scm_tc16_pipe
+ && SCM_OPENP (port), port, SCM_ARG1, s_close_pipe);
+ SCM_DEFER_INTS;
+ rv = pclose ((FILE *) SCM_STREAM (port));
+ if (rv == -1)
+ scm_syserror (s_close_pipe);
+ SCM_ALLOW_INTS;
+ return SCM_MAKINUM (rv);
}
-
SCM_PROC (s_utime, "utime", 1, 2, 0, scm_utime);
SCM
scm_putenv (str)
SCM str;
{
-#ifdef HAVE_PUTENV
int rv;
+ char *ptr;
SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_putenv);
- rv = putenv (SCM_CHARS (str));
+ /* must make a new copy to be left in the environment, safe from gc. */
+ ptr = malloc (SCM_LENGTH (str) + 1);
+ if (ptr == NULL)
+ scm_memory_error (s_putenv);
+ strcpy (ptr, SCM_CHARS (str));
+ rv = putenv (ptr);
if (rv < 0)
scm_syserror (s_putenv);
return SCM_UNSPECIFIED;
-#else
- scm_sysmissing (s_putenv);
- /* not reached. */
- return SCM_BOOL_F;
-#endif
}
SCM_PROC (s_setlocale, "setlocale", 1, 1, 0, scm_setlocale);
#endif
}
-SCM_PROC (s_mknod, "mknod", 3, 0, 0, scm_mknod);
+SCM_PROC (s_mknod, "mknod", 4, 0, 0, scm_mknod);
SCM
-scm_mknod(path, mode, dev)
+scm_mknod(path, type, perms, dev)
SCM path;
- SCM mode;
+ SCM type;
+ SCM perms;
SCM dev;
{
#ifdef HAVE_MKNOD
int val;
- SCM_ASSERT(SCM_NIMP(path) && SCM_ROSTRINGP(path), path, SCM_ARG1, s_mknod);
- SCM_ASSERT(SCM_INUMP(mode), mode, SCM_ARG2, s_mknod);
- SCM_ASSERT(SCM_INUMP(dev), dev, SCM_ARG3, s_mknod);
- SCM_SYSCALL(val = mknod(SCM_ROCHARS(path), SCM_INUM(mode), SCM_INUM(dev)));
+ char *p;
+ int ctype;
+
+ SCM_ASSERT (SCM_NIMP(path) && SCM_ROSTRINGP(path), path, SCM_ARG1, s_mknod);
+ SCM_ASSERT (SCM_NIMP(type) && SCM_SYMBOLP (type), type, SCM_ARG2, s_mknod);
+ SCM_ASSERT (SCM_INUMP (perms), perms, SCM_ARG3, s_mknod);
+ SCM_ASSERT (SCM_INUMP(dev), dev, SCM_ARG4, s_mknod);
+
+ p = SCM_CHARS (type);
+ if (strcmp (p, "regular") == 0)
+ ctype = S_IFREG;
+ else if (strcmp (p, "directory") == 0)
+ ctype = S_IFDIR;
+ else if (strcmp (p, "symlink") == 0)
+ ctype = S_IFLNK;
+ else if (strcmp (p, "block-special") == 0)
+ ctype = S_IFBLK;
+ else if (strcmp (p, "char-special") == 0)
+ ctype = S_IFCHR;
+ else if (strcmp (p, "fifo") == 0)
+ ctype = S_IFIFO;
+ else if (strcmp (p, "socket") == 0)
+ ctype = S_IFSOCK;
+ else
+ scm_out_of_range (s_mknod, type);
+
+ SCM_DEFER_INTS;
+ SCM_SYSCALL (val = mknod(SCM_ROCHARS(path), ctype | SCM_INUM (perms),
+ SCM_INUM (dev)));
if (val != 0)
scm_syserror (s_mknod);
+ SCM_ALLOW_INTS;
return SCM_UNSPECIFIED;
#else
scm_sysmissing (s_mknod);
extern SCM scm_uname SCM_P ((void));
extern SCM scm_environ SCM_P ((SCM env));
extern SCM scm_open_pipe SCM_P ((SCM pipestr, SCM modes));
-extern SCM scm_open_input_pipe SCM_P ((SCM pipestr));
-extern SCM scm_open_output_pipe SCM_P ((SCM pipestr));
+extern SCM scm_close_pipe SCM_P ((SCM port));
extern SCM scm_utime SCM_P ((SCM pathname, SCM actime, SCM modtime));
extern SCM scm_access SCM_P ((SCM path, SCM how));
extern SCM scm_getpid SCM_P ((void));
extern SCM scm_setlocale SCM_P ((SCM category, SCM locale));
extern SCM scm_strftime SCM_P ((SCM format, SCM stime));
extern SCM scm_strptime SCM_P ((SCM format, SCM string));
-extern SCM scm_mknod SCM_P ((SCM path, SCM mode, SCM dev));
+extern SCM scm_mknod SCM_P ((SCM path, SCM type, SCM perms, SCM dev));
extern SCM scm_nice SCM_P ((SCM incr));
extern SCM scm_sync SCM_P ((void));
extern void scm_init_posix SCM_P ((void));
--- /dev/null
+/* Copyright (C) 1991 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 program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+#ifdef HAVE_CONFIG_H
+#include <config.h>
+#endif
+
+#include <sys/types.h>
+#include <errno.h>
+#ifndef errno
+extern int errno;
+#endif
+
+/* Don't include stdlib.h for non-GNU C libraries because some of them
+ contain conflicting prototypes for getopt.
+ This needs to come after some library #include
+ to get __GNU_LIBRARY__ defined. */
+#ifdef __GNU_LIBRARY__
+#include <stdlib.h>
+#else
+char *malloc ();
+#endif /* GNU C library. */
+
+#if defined(STDC_HEADERS) || defined(HAVE_STRING_H)
+#include <string.h>
+#else
+#include <strings.h>
+#ifndef strchr
+#define strchr index
+#endif
+#ifndef memcpy
+#define memcpy(d, s, n) bcopy((s), (d), (n))
+#endif
+#endif
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+#ifndef NULL
+#define NULL 0
+#endif
+
+extern char **environ;
+
+/* Put STRING, which is of the form "NAME=VALUE", in the environment. */
+int
+putenv (string)
+ const char *string;
+{
+ char *name_end = strchr (string, '=');
+ register size_t size;
+ register char **ep;
+
+ if (name_end == NULL)
+ {
+ /* Remove the variable from the environment. */
+ size = strlen (string);
+ for (ep = environ; *ep != NULL; ++ep)
+ if (!strncmp (*ep, string, size) && (*ep)[size] == '=')
+ {
+ while (ep[1] != NULL)
+ {
+ ep[0] = ep[1];
+ ++ep;
+ }
+ *ep = NULL;
+ return 0;
+ }
+ }
+
+ size = 0;
+ for (ep = environ; *ep != NULL; ++ep)
+ if (!strncmp (*ep, string, name_end - string) &&
+ (*ep)[name_end - string] == '=')
+ break;
+ else
+ ++size;
+
+ if (*ep == NULL)
+ {
+ static char **last_environ = NULL;
+ char **new_environ = (char **) malloc ((size + 2) * sizeof (char *));
+ if (new_environ == NULL)
+ return -1;
+ memcpy ((char *) new_environ, (char *) environ, size * sizeof (char *));
+ new_environ[size] = (char *) string;
+ new_environ[size + 1] = NULL;
+ if (last_environ != NULL)
+ free ((char *) last_environ);
+ last_environ = new_environ;
+ environ = new_environ;
+ }
+ else
+ *ep = (char *) string;
+
+ return 0;
+}
/* Define if you have the geteuid function. */
#undef HAVE_GETEUID
+/* Define if you have the gettimeofday function. */
+#undef HAVE_GETTIMEOFDAY
+
/* Define if you have the inet_aton function. */
#undef HAVE_INET_ATON
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997 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
# endif
#endif
-
+extern int errno;
#ifdef HAVE_FTIME
tmp = time_buffer.time*1000L + tmp;
tmp *= CLKTCK;
tmp /= 1000;
- return SCM_MAKINUM(tmp);
+ return scm_long2num (tmp);
}
#else
SCM
scm_get_internal_real_time()
{
- return SCM_MAKINUM((time((timet*)0) - scm_your_base) * (int)CLKTCK);
+ return scm_long2num((time((timet*)0) - scm_your_base) * (int)CLKTCK);
}
#endif
SCM
scm_get_internal_run_time()
{
- return SCM_MAKINUM(mytime()-scm_my_base);
+ 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 = time((timet*)0);
- SCM ans;
- ans = scm_ulong2num(timv);
- return SCM_BOOL_F==ans ? SCM_MAKINUM(timv) : ans;
+ 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_time_plus_ticks, "time+ticks", 0, 0, 0, scm_time_plus_ticks);
+SCM
+scm_time_plus_ticks (void)
+{
+#ifdef HAVE_GETTIMEOFDAY
+ struct timeval time;
+
+ SCM_DEFER_INTS;
+ if (gettimeofday (&time, NULL) == -1)
+ scm_syserror (s_time_plus_ticks);
+ 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));
+# else
+ timet timv;
+
+ SCM_DEFER_INTS;
+ if ((timv = time (0)) == -1)
+ scm_syserror (s_time_plus_ticks);
+ 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_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] = scm_makfrom0str (zname);
+ return result;
+}
+
+#if 0
+SCM_PROC (s_localtime, "localtime", 1, 1, 0, scm_localtime);
+SCM
+scm_localtime (SCM time, SCM zone)
+{
+ timet itime;
+ struct tm *lt, *utc;
+ SCM result;
+ int zoff;
+ char *zname = 0;
+ char *tzvar = "TZ";
+ char *oldtz = 0;
+ int err;
+
+ itime = scm_num2long (time, (char *) SCM_ARG1, s_localtime);
+ SCM_DEFER_INTS;
+ if (!SCM_UNBNDP (zone))
+ {
+ char *buf;
+
+ /* if zone was supplied, set the environment variable TZ temporarily. */
+ SCM_ASSERT (SCM_NIMP (zone) && SCM_STRINGP (zone), zone, SCM_ARG2,
+ s_localtime);
+ buf = malloc (SCM_LENGTH (zone) + 4);
+ if (buf == 0)
+ scm_memory_error (s_localtime);
+ oldtz = getenv (tzvar);
+ sprintf (buf, "%s=%s", tzvar, SCM_CHARS (zone));
+ putenv (buf);
+ tzset();
+ }
+ lt = localtime (&itime);
+ err = errno;
+ utc = gmtime (&itime);
+ if (utc == NULL)
+ err = errno;
+ if (lt)
+ {
+ /* must be copied before calling tzset again. */
+ char *ptr = tzname[ (lt->tm_isdst == 1) ? 1 : 0 ];
+
+ zname = scm_must_malloc (strlen (ptr) + 1, s_localtime);
+ strcpy (zname, ptr);
+ }
+ if (!SCM_UNBNDP (zone))
+ {
+ /* restore the old environment value of TZ. */
+ if (oldtz)
+ putenv (oldtz - 3);
+ else
+ putenv (tzvar);
+ tzset();
+ }
+ errno = err;
+ if (utc == NULL)
+ scm_syserror (s_localtime);
+ if (lt == 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;
+ return result;
+}
+#endif
+
+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;
+}
+
+#if 0
+SCM_PROC (s_mktime, "mktime", 1, 0, 0, scm_mktime);
+SCM
+scm_mktime (SCM sbd_time)
+{
+ timet itime;
+ struct tm lt, *utc;
+ SCM result;
+ int zoff;
+ char *zname;
+
+ SCM_ASSERT (SCM_VECTORP (sbd_time), sbd_time, SCM_ARG1, s_mktime);
+ SCM_ASSERT (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)[8]),
+ sbd_time, SCM_ARG1, s_mktime);
+ 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_isdst = SCM_INUM (SCM_VELTS (sbd_time)[8]);
+
+ SCM_DEFER_INTS;
+ itime = mktime (<);
+ if (itime == -1)
+ scm_syserror (s_mktime);
+
+ /* timezone offset in seconds west of UTC. */
+ utc = gmtime (&itime);
+ 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;
+
+ /* timezone name. */
+ zname = tzname[ (lt.tm_isdst == 1) ? 1 : 0 ];
+
+ result = scm_cons (scm_long2num ((long) itime),
+ filltime (<, zoff, zname));
+ SCM_ALLOW_INTS;
+ return result;
}
+#endif
-long
-scm_time_in_msec(x)
- long x;
+SCM_PROC (s_tzset, "tzset", 0, 0, 0, scm_tzset);
+SCM
+scm_tzset (void)
{
- if (CLKTCK==60) return (x*50)/3;
- else
- return (CLKTCK < 1000 ? x*(1000L/(long)CLKTCK) : (x*1000L)/(long)CLKTCK);
+ tzset();
+ return SCM_UNSPECIFIED;
}
void
scm_init_stime()
{
scm_sysintern("internal-time-units-per-second",
- SCM_MAKINUM((long)CLKTCK));
+ scm_long2num((long)CLKTCK));
#ifdef HAVE_FTIME
if (!scm_your_base.time) ftime(&scm_your_base);
if (!scm_your_base) time(&scm_your_base);
#endif
+ scm_sysintern("ticks/sec",
+#ifdef HAVE_GETTIMEOFDAY
+ scm_long2num ((long) 1000000)
+#else
+# ifdef HAVE_FTIME
+ SCM_MAKINUM (1000)
+# else
+ SCM_MAKINUM (1)
+# endif
+#endif
+ );
+
if (!scm_my_base) scm_my_base = mytime();
scm_add_feature ("current-time");
#ifndef TIMEH
#define TIMEH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997 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
extern SCM scm_get_internal_real_time SCM_P ((void));
extern SCM scm_get_internal_run_time SCM_P ((void));
extern SCM scm_current_time SCM_P ((void));
-extern long scm_time_in_msec SCM_P ((long x));
+extern SCM scm_time_plus_ticks (void);
+extern SCM scm_localtime (SCM time, SCM zone);
+extern SCM scm_gmtime (SCM time);
+extern SCM scm_mktime (SCM sbd_time);
+extern SCM scm_tzset (void);
extern void scm_init_stime SCM_P ((void));
#endif /* TIMEH */
HCoop / bpt / guile.git / commitdiff