mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
* 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. * 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
This commit is contained in:
Gary Houston
parent
ec8c8a5433
commit
19468effd0
12 changed files with 480 additions and 74 deletions
|
|
@ -1,3 +1,48 @@
|
|||
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
|
||||
|
|
|
|||
|
|
@ -20,7 +20,7 @@ stackchk.c stime.c strings.c strop.c strorder.c \
|
|||
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)
|
||||
|
|
|
|||
|
|
@ -68,7 +68,7 @@ stackchk.c stime.c strings.c strop.c strorder.c \
|
|||
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)
|
||||
|
|
@ -154,13 +154,14 @@ DEP_FILES = .deps/alist.P .deps/append.P .deps/appinit.P \
|
|||
.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)
|
||||
|
||||
|
|
|
|||
4
libguile/configure
vendored
4
libguile/configure
vendored
|
|
@ -2017,7 +2017,7 @@ EOF
|
|||
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
|
||||
|
|
@ -2073,7 +2073,7 @@ fi
|
|||
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
|
||||
|
|
|
|||
|
|
@ -51,9 +51,9 @@ AC_TYPE_GETGROUPS
|
|||
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
|
||||
|
||||
|
|
|
|||
|
|
@ -383,16 +383,16 @@ scm_ptobfuns scm_fptob =
|
|||
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 ()
|
||||
|
|
|
|||
|
|
@ -843,9 +843,9 @@ scm_environ (env)
|
|||
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;
|
||||
|
|
@ -854,7 +854,9 @@ scm_environ (env)
|
|||
&& 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];
|
||||
|
|
@ -871,8 +873,8 @@ scm_environ (env)
|
|||
if (!first)
|
||||
{
|
||||
for (ep = environ; *ep != NULL; ep++)
|
||||
scm_must_free (*ep);
|
||||
scm_must_free ((char *) environ);
|
||||
free (*ep);
|
||||
free ((char *) environ);
|
||||
}
|
||||
first = 0;
|
||||
}
|
||||
|
|
@ -929,26 +931,24 @@ scm_open_pipe (pipestr, modes)
|
|||
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));
|
||||
int rv;
|
||||
|
||||
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_open_output_pipe, "open-output-pipe", 1, 0, 0, scm_open_output_pipe);
|
||||
|
||||
SCM
|
||||
scm_open_output_pipe(pipestr)
|
||||
SCM pipestr;
|
||||
{
|
||||
return scm_open_pipe(pipestr, scm_makfromstr("w", (sizeof "w")-1, 0));
|
||||
}
|
||||
|
||||
|
||||
SCM_PROC (s_utime, "utime", 1, 2, 0, scm_utime);
|
||||
|
||||
SCM
|
||||
|
|
@ -1011,19 +1011,19 @@ 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);
|
||||
|
|
@ -1180,22 +1180,49 @@ scm_strptime (format, string)
|
|||
#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);
|
||||
|
|
|
|||
|
|
@ -84,8 +84,7 @@ extern SCM scm_fork SCM_P ((void));
|
|||
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));
|
||||
|
|
@ -93,7 +92,7 @@ extern SCM scm_putenv SCM_P ((SCM str));
|
|||
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));
|
||||
|
|
|
|||
111
libguile/putenv.c
Normal file
111
libguile/putenv.c
Normal file
|
|
@ -0,0 +1,111 @@
|
|||
/* 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;
|
||||
}
|
||||
|
|
@ -160,6 +160,9 @@
|
|||
/* 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
|
||||
|
||||
|
|
|
|||
248
libguile/stime.c
248
libguile/stime.c
|
|
@ -1,4 +1,4 @@
|
|||
/* 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
|
||||
|
|
@ -126,7 +126,7 @@ long mytime()
|
|||
# endif
|
||||
#endif
|
||||
|
||||
|
||||
extern int errno;
|
||||
|
||||
#ifdef HAVE_FTIME
|
||||
|
||||
|
|
@ -145,7 +145,7 @@ scm_get_internal_real_time()
|
|||
tmp = time_buffer.time*1000L + tmp;
|
||||
tmp *= CLKTCK;
|
||||
tmp /= 1000;
|
||||
return SCM_MAKINUM(tmp);
|
||||
return scm_long2num (tmp);
|
||||
}
|
||||
|
||||
#else
|
||||
|
|
@ -155,7 +155,7 @@ SCM_PROC(s_get_internal_real_time, "get-internal-real-time", 0, 0, 0, scm_get_in
|
|||
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
|
||||
|
||||
|
|
@ -167,33 +167,237 @@ SCM_PROC(s_get_internal_run_time, "get-internal-run-time", 0, 0, 0, scm_get_inte
|
|||
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);
|
||||
}
|
||||
|
||||
long
|
||||
scm_time_in_msec(x)
|
||||
long x;
|
||||
SCM_PROC (s_time_plus_ticks, "time+ticks", 0, 0, 0, scm_time_plus_ticks);
|
||||
SCM
|
||||
scm_time_plus_ticks (void)
|
||||
{
|
||||
if (CLKTCK==60) return (x*50)/3;
|
||||
else
|
||||
return (CLKTCK < 1000 ? x*(1000L/(long)CLKTCK) : (x*1000L)/(long)CLKTCK);
|
||||
#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
|
||||
|
||||
SCM_PROC (s_tzset, "tzset", 0, 0, 0, scm_tzset);
|
||||
SCM
|
||||
scm_tzset (void)
|
||||
{
|
||||
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);
|
||||
|
|
@ -201,6 +405,18 @@ scm_init_stime()
|
|||
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");
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
#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
|
||||
|
|
@ -50,7 +50,11 @@
|
|||
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 */
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue