diff options
Diffstat (limited to 'libguile')
-rw-r--r-- | libguile/ChangeLog | 45 | ||||
-rw-r--r-- | libguile/Makefile.am | 2 | ||||
-rw-r--r-- | libguile/Makefile.in | 17 | ||||
-rwxr-xr-x | libguile/configure | 4 | ||||
-rw-r--r-- | libguile/configure.in | 4 | ||||
-rw-r--r-- | libguile/fports.c | 8 | ||||
-rw-r--r-- | libguile/posix.c | 97 | ||||
-rw-r--r-- | libguile/posix.h | 5 | ||||
-rw-r--r-- | libguile/putenv.c | 111 | ||||
-rw-r--r-- | libguile/scmconfig.h.in | 3 | ||||
-rw-r--r-- | libguile/stime.c | 248 | ||||
-rw-r--r-- | libguile/stime.h | 8 |
12 files changed, 479 insertions, 73 deletions
diff --git a/libguile/ChangeLog b/libguile/ChangeLog index dea3ccab5..0853c3bd7 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -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 diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 6599da4aa..c1aa109eb 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -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) diff --git a/libguile/Makefile.in b/libguile/Makefile.in index b61b6c07b..6b9f17d4c 100644 --- a/libguile/Makefile.in +++ b/libguile/Makefile.in @@ -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) diff --git a/libguile/configure b/libguile/configure index f5c435c33..c96095779 100755 --- a/libguile/configure +++ b/libguile/configure @@ -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 diff --git a/libguile/configure.in b/libguile/configure.in index 5e66808df..3bdab6f3c 100644 --- a/libguile/configure.in +++ b/libguile/configure.in @@ -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 diff --git a/libguile/fports.c b/libguile/fports.c index 57e9ab835..005d5b94e 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -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 () diff --git a/libguile/posix.c b/libguile/posix.c index 425777be5..6fa2d4b82 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -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)); -} - -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 @@ -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); diff --git a/libguile/posix.h b/libguile/posix.h index 04ebec778..c39cc99ba 100644 --- a/libguile/posix.h +++ b/libguile/posix.h @@ -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)); diff --git a/libguile/putenv.c b/libguile/putenv.c new file mode 100644 index 000000000..06e3254b6 --- /dev/null +++ b/libguile/putenv.c @@ -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; +} diff --git a/libguile/scmconfig.h.in b/libguile/scmconfig.h.in index bf79dfecb..cce6d67b3 100644 --- a/libguile/scmconfig.h.in +++ b/libguile/scmconfig.h.in @@ -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 diff --git a/libguile/stime.c b/libguile/stime.c index c5d5fe797..be2adbf4b 100644 --- a/libguile/stime.c +++ b/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); +} + +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); @@ -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"); diff --git a/libguile/stime.h b/libguile/stime.h index 54a093bc3..2e0e38371 100644 --- a/libguile/stime.h +++ b/libguile/stime.h @@ -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 */ |