-/* Copyright (C) 1995, 1996 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, 675 Mass Ave, Cambridge, MA 02139, 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"
-
-\f
-
-#ifdef HAVE_STRING_H
-#include <string.h>
-#endif
-#ifdef TIME_WITH_SYS_TIME
-# include <sys/time.h>
-# include <time.h>
-#else
-# if HAVE_SYS_TIME_H
-# include <sys/time.h>
-# else
-# include <time.h>
-# endif
-#endif
-
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#else
-#ifndef ttyname
-extern char *ttyname();
-#endif
-#endif
-
-#ifdef HAVE_LIBC_H
-#include <libc.h>
-#endif
-
-#ifdef HAVE_SYS_SELECT_H
-#include <sys/select.h>
-#endif
-
-#include <sys/types.h>
-#include <sys/stat.h>
-#include <fcntl.h>
-
-#include <pwd.h>
-
-#if HAVE_SYS_WAIT_H
-# include <sys/wait.h>
-#endif
-#ifndef WEXITSTATUS
-# define WEXITSTATUS(stat_val) ((unsigned)(stat_val) >> 8)
-#endif
-#ifndef WIFEXITED
-# define WIFEXITED(stat_val) (((stat_val) & 255) == 0)
-#endif
-
-#include <signal.h>
-
-#ifdef FD_SET
-
-#define SELECT_TYPE fd_set
-#define SELECT_SET_SIZE FD_SETSIZE
-
-#else /* no FD_SET */
-
-/* Define the macros to access a single-int bitmap of descriptors. */
-#define SELECT_SET_SIZE 32
-#define SELECT_TYPE int
-#define FD_SET(n, p) (*(p) |= (1 << (n)))
-#define FD_CLR(n, p) (*(p) &= ~(1 << (n)))
-#define FD_ISSET(n, p) (*(p) & (1 << (n)))
-#define FD_ZERO(p) (*(p) = 0)
-
-#endif /* no FD_SET */
-
-extern FILE *popen ();
-extern char ** environ;
-
-#include <grp.h>
-#include <sys/utsname.h>
-
-#if HAVE_DIRENT_H
-# include <dirent.h>
-# define NAMLEN(dirent) strlen((dirent)->d_name)
-#else
-# define dirent direct
-# define NAMLEN(dirent) (dirent)->d_namlen
-# if HAVE_SYS_NDIR_H
-# include <sys/ndir.h>
-# endif
-# if HAVE_SYS_DIR_H
-# include <sys/dir.h>
-# endif
-# if HAVE_NDIR_H
-# include <ndir.h>
-# endif
-#endif
-
-char *strptime ();
-
-#ifdef HAVE_SETLOCALE
-#include <locale.h>
-#endif
-
-/* Some Unix systems don't define these. CPP hair is dangerous, but
- this seems safe enough... */
-#ifndef R_OK
-#define R_OK 4
-#endif
-
-#ifndef W_OK
-#define W_OK 2
-#endif
-
-#ifndef X_OK
-#define X_OK 1
-#endif
-
-#ifndef F_OK
-#define F_OK 0
-#endif
-
-/* On NextStep, <utime.h> doesn't define struct utime, unless we
- #define _POSIX_SOURCE before #including it. I think this is less
- of a kludge than defining struct utimbuf ourselves. */
-#ifdef UTIMBUF_NEEDS_POSIX
-#define _POSIX_SOURCE
-#endif
-
-#ifdef HAVE_SYS_UTIME_H
-#include <sys/utime.h>
-#endif
-
-#ifdef HAVE_UTIME_H
-#include <utime.h>
-#endif
-
-/* Please don't add any more #includes or #defines here. The hack
- above means that _POSIX_SOURCE may be #defined, which will
- encourage header files to do strange things. */
-
-\f
-
-
-SCM_PROC (s_sys_pipe, "pipe", 0, 0, 0, scm_sys_pipe);
-#ifdef __STDC__
-SCM
-scm_sys_pipe (void)
-#else
-SCM
-scm_sys_pipe ()
-#endif
-{
- int fd[2], rv;
- FILE *f_rd, *f_wt;
- SCM p_rd, p_wt;
- struct scm_port_table * ptr;
- struct scm_port_table * ptw;
-
- SCM_NEWCELL (p_rd);
- SCM_NEWCELL (p_wt);
- rv = pipe (fd);
- if (rv)
- SCM_SYSERROR (s_sys_pipe);
- f_rd = fdopen (fd[0], "r");
- if (!f_rd)
- {
- SCM_SYSCALL (close (fd[0]));
- SCM_SYSCALL (close (fd[1]));
- SCM_SYSERROR (s_sys_pipe);
- }
- f_wt = fdopen (fd[1], "w");
- if (!f_wt)
- {
- int en;
- en = errno;
- fclose (f_rd);
- SCM_SYSCALL (close (fd[1]));
- errno = en;
- SCM_SYSERROR (s_sys_pipe);
- }
- ptr = scm_add_to_port_table (p_rd);
- ptw = scm_add_to_port_table (p_wt);
- SCM_SETPTAB_ENTRY (p_rd, ptr);
- SCM_SETPTAB_ENTRY (p_wt, ptw);
- SCM_CAR (p_rd) = scm_tc16_fport | scm_mode_bits ("r");
- SCM_CAR (p_wt) = scm_tc16_fport | scm_mode_bits ("w");
- SCM_SETSTREAM (p_rd, (SCM)f_rd);
- SCM_SETSTREAM (p_wt, (SCM)f_wt);
-
- SCM_ALLOW_INTS;
- return scm_cons (p_rd, p_wt);
-}
-
-
-
-SCM_PROC (s_sys_getgroups, "getgroups", 0, 0, 0, scm_sys_getgroups);
-#ifdef __STDC__
-SCM
-scm_sys_getgroups(void)
-#else
-SCM
-scm_sys_getgroups()
-#endif
-{
- SCM grps, ans;
- int ngroups = getgroups (0, NULL);
- if (!ngroups)
- SCM_SYSERROR (s_sys_getgroups);
- SCM_NEWCELL(grps);
- SCM_DEFER_INTS;
- {
- GETGROUPS_T *groups;
- int val;
-
- groups = (GETGROUPS_T *) scm_must_malloc(ngroups * sizeof(GETGROUPS_T),
- s_sys_getgroups);
- val = getgroups(ngroups, groups);
- if (val < 0)
- {
- scm_must_free((char *)groups);
- SCM_SYSERROR (s_sys_getgroups);
- }
- SCM_SETCHARS(grps, groups); /* set up grps as a GC protect */
- SCM_SETLENGTH(grps, 0L + ngroups * sizeof(GETGROUPS_T), scm_tc7_string);
- SCM_ALLOW_INTS;
- ans = scm_make_vector(SCM_MAKINUM(ngroups), SCM_UNDEFINED, SCM_BOOL_F);
- while (--ngroups >= 0) SCM_VELTS(ans)[ngroups] = SCM_MAKINUM(groups[ngroups]);
- SCM_SETCHARS(grps, groups); /* to make sure grps stays around. */
- return ans;
- }
-}
-
-
-
-SCM_PROC (s_sys_getpwuid, "getpw", 0, 1, 0, scm_sys_getpwuid);
-#ifdef __STDC__
-SCM
-scm_sys_getpwuid (SCM user)
-#else
-SCM
-scm_sys_getpwuid (user)
- SCM user;
-#endif
-{
- SCM result;
- struct passwd *entry;
- SCM *ve;
-
- result = scm_make_vector (SCM_MAKINUM (7), SCM_UNSPECIFIED, SCM_BOOL_F);
- ve = SCM_VELTS (result);
- if (SCM_UNBNDP (user) || SCM_FALSEP (user))
- {
- SCM_DEFER_INTS;
- SCM_SYSCALL (entry = getpwent ());
- }
- else if (SCM_INUMP (user))
- {
- SCM_DEFER_INTS;
- entry = getpwuid (SCM_INUM (user));
- }
- else
- {
- SCM_ASSERT (SCM_NIMP (user) && SCM_ROSTRINGP (user), user, SCM_ARG1, s_sys_getpwuid);
- if (SCM_SUBSTRP (user))
- user = scm_makfromstr (SCM_ROCHARS (user), SCM_ROLENGTH (user), 0);
- SCM_DEFER_INTS;
- entry = getpwnam (SCM_ROCHARS (user));
- }
- if (!entry)
- SCM_SYSERROR (s_sys_getpwuid);
-
- ve[0] = scm_makfrom0str (entry->pw_name);
- ve[1] = scm_makfrom0str (entry->pw_passwd);
- ve[2] = scm_ulong2num ((unsigned long) entry->pw_uid);
- ve[3] = scm_ulong2num ((unsigned long) entry->pw_gid);
- ve[4] = scm_makfrom0str (entry->pw_gecos);
- if (!entry->pw_dir)
- ve[5] = scm_makfrom0str ("");
- else
- ve[5] = scm_makfrom0str (entry->pw_dir);
- if (!entry->pw_shell)
- ve[6] = scm_makfrom0str ("");
- else
- ve[6] = scm_makfrom0str (entry->pw_shell);
- SCM_ALLOW_INTS;
- return result;
-}
-
-
-
-SCM_PROC (s_setpwent, "setpw", 0, 1, 0, scm_setpwent);
-#ifdef __STDC__
-SCM
-scm_setpwent (SCM arg)
-#else
-SCM
-scm_setpwent (arg)
- SCM arg;
-#endif
-{
- if (SCM_UNBNDP (arg) || SCM_FALSEP (arg))
- endpwent ();
- else
- setpwent ();
- return SCM_UNSPECIFIED;
-}
-
-
-
-/* Combines getgrgid and getgrnam. */
-SCM_PROC (s_sys_getgrgid, "getgr", 0, 1, 0, scm_sys_getgrgid);
-#ifdef __STDC__
-SCM
-scm_sys_getgrgid (SCM name)
-#else
-SCM
-scm_sys_getgrgid (name)
- SCM name;
-#endif
-{
- SCM result;
- struct group *entry;
- SCM *ve;
- result = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED, SCM_BOOL_F);
- ve = SCM_VELTS (result);
- SCM_DEFER_INTS;
- if (SCM_UNBNDP (name) || (name == SCM_BOOL_F))
- SCM_SYSCALL (entry = getgrent ());
- else if (SCM_INUMP (name))
- SCM_SYSCALL (entry = getgrgid (SCM_INUM (name)));
- else
- {
- SCM_ASSERT (SCM_NIMP (name) && SCM_STRINGP (name), name, SCM_ARG1, s_sys_getgrgid);
- if (SCM_SUBSTRP (name))
- name = scm_makfromstr (SCM_ROCHARS (name), SCM_ROLENGTH (name), 0);
- SCM_SYSCALL (entry = getgrnam (SCM_CHARS (name)));
- }
- if (!entry)
- SCM_SYSERROR (s_sys_getgrgid);
-
- ve[0] = scm_makfrom0str (entry->gr_name);
- ve[1] = scm_makfrom0str (entry->gr_passwd);
- ve[2] = scm_ulong2num ((unsigned long) entry->gr_gid);
- ve[3] = scm_makfromstrs (-1, entry->gr_mem);
- SCM_ALLOW_INTS;
- return result;
-}
-
-
-
-SCM_PROC (s_setgrent, "setgr", 0, 1, 0, scm_setgrent);
-#ifdef __STDC__
-SCM
-scm_setgrent (SCM arg)
-#else
-SCM
-scm_setgrent (arg)
- SCM arg;
-#endif
-{
- if (SCM_UNBNDP (arg) || SCM_FALSEP (arg))
- endgrent ();
- else
- setgrent ();
- return SCM_UNSPECIFIED;
-}
-
-
-
-SCM_PROC (s_sys_kill, "kill", 2, 0, 0, scm_sys_kill);
-#ifdef __STDC__
-SCM
-scm_sys_kill (SCM pid, SCM sig)
-#else
-SCM
-scm_sys_kill (pid, sig)
- SCM pid;
- SCM sig;
-#endif
-{
- SCM_ASSERT (SCM_INUMP (pid), pid, SCM_ARG1, s_sys_kill);
- SCM_ASSERT (SCM_INUMP (sig), sig, SCM_ARG2, s_sys_kill);
- /* Signal values are interned in scm_init_posix(). */
- if (kill ((int) SCM_INUM (pid), (int) SCM_INUM (sig)) != 0)
- SCM_SYSERROR (s_sys_kill);
- return SCM_UNSPECIFIED;
-}
-
-
-
-SCM_PROC (s_sys_waitpid, "waitpid", 1, 1, 0, scm_sys_waitpid);
-#ifdef __STDC__
-SCM
-scm_sys_waitpid (SCM pid, SCM options)
-#else
-SCM
-scm_sys_waitpid (pid, options)
- SCM pid;
- SCM options;
-#endif
-{
-#ifdef HAVE_WAITPID
- int i;
- int status;
- int ioptions;
- SCM_ASSERT (SCM_INUMP (pid), pid, SCM_ARG1, s_sys_waitpid);
- if (SCM_UNBNDP (options))
- ioptions = 0;
- else
- {
- SCM_ASSERT (SCM_INUMP (options), options, SCM_ARG2, s_sys_waitpid);
- /* Flags are interned in scm_init_posix. */
- ioptions = SCM_INUM (options);
- }
- SCM_SYSCALL (i = waitpid (SCM_INUM (pid), &status, ioptions));
- if (i == -1)
- SCM_SYSERROR (s_sys_waitpid);
- return scm_cons (SCM_MAKINUM (0L + i), SCM_MAKINUM (0L + status));
-#else
- SCM_SYSMISSING (s_sys_waitpid);
- /* not reached. */
- return SCM_BOOL_F;
-#endif
-}
-
-
-
-SCM_PROC (s_getppid, "getppid", 0, 0, 0, scm_getppid);
-#ifdef __STDC__
-SCM
-scm_getppid (void)
-#else
-SCM
-scm_getppid ()
-#endif
-{
- return SCM_MAKINUM (0L + getppid ());
-}
-
-
-
-SCM_PROC (s_getuid, "getuid", 0, 0, 0, scm_getuid);
-#ifdef __STDC__
-SCM
-scm_getuid (void)
-#else
-SCM
-scm_getuid ()
-#endif
-{
- return SCM_MAKINUM (0L + getuid ());
-}
-
-
-
-SCM_PROC (s_getgid, "getgid", 0, 0, 0, scm_getgid);
-#ifdef __STDC__
-SCM
-scm_getgid (void)
-#else
-SCM
-scm_getgid ()
-#endif
-{
- return SCM_MAKINUM (0L + getgid ());
-}
-
-
-
-SCM_PROC (s_geteuid, "geteuid", 0, 0, 0, scm_geteuid);
-#ifdef __STDC__
-SCM
-scm_geteuid (void)
-#else
-SCM
-scm_geteuid ()
-#endif
-{
-#ifdef HAVE_GETEUID
- return SCM_MAKINUM (0L + geteuid ());
-#else
- return SCM_MAKINUM (0L + getuid ());
-#endif
-}
-
-
-
-SCM_PROC (s_getegid, "getegid", 0, 0, 0, scm_getegid);
-#ifdef __STDC__
-SCM
-scm_getegid (void)
-#else
-SCM
-scm_getegid ()
-#endif
-{
-#ifdef HAVE_GETEUID
- return SCM_MAKINUM (0L + getegid ());
-#else
- return SCM_MAKINUM (0L + getgid ());
-#endif
-}
-
-
-SCM_PROC (s_sys_setuid, "setuid", 1, 0, 0, scm_sys_setuid);
-#ifdef __STDC__
-SCM
-scm_sys_setuid (SCM id)
-#else
-SCM
-scm_sys_setuid (id)
- SCM id;
-#endif
-{
- SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_sys_setuid);
- if (setuid (SCM_INUM (id)) != 0)
- SCM_SYSERROR (s_sys_setuid);
- return SCM_UNSPECIFIED;
-}
-
-SCM_PROC (s_sys_setgid, "setgid", 1, 0, 0, scm_sys_setgid);
-#ifdef __STDC__
-SCM
-scm_sys_setgid (SCM id)
-#else
-SCM
-scm_sys_setgid (id)
- SCM id;
-#endif
-{
- SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_sys_setgid);
- if (setgid (SCM_INUM (id)) != 0)
- SCM_SYSERROR (s_sys_setgid);
- return SCM_UNSPECIFIED;
-}
-
-SCM_PROC (s_sys_seteuid, "seteuid", 1, 0, 0, scm_sys_seteuid);
-#ifdef __STDC__
-SCM
-scm_sys_seteuid (SCM id)
-#else
-SCM
-scm_sys_seteuid (id)
- SCM id;
-#endif
-{
- int rv;
-
- SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_sys_seteuid);
-#ifdef HAVE_SETEUID
- rv = seteuid (SCM_INUM (id));
-#else
- rv = setuid (SCM_INUM (id));
-#endif
- if (rv != 0)
- SCM_SYSERROR (s_sys_seteuid);
- return SCM_UNSPECIFIED;
-}
-
-SCM_PROC (s_sys_setegid, "setegid", 1, 0, 0, scm_sys_setegid);
-#ifdef __STDC__
-SCM
-scm_sys_setegid (SCM id)
-#else
-SCM
-scm_sys_setegid (id)
- SCM id;
-#endif
-{
- int rv;
-
- SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_sys_setegid);
-#ifdef HAVE_SETEUID
- rv = setegid (SCM_INUM (id));
-#else
- rv = setgid (SCM_INUM (id));
-#endif
- if (rv != 0)
- SCM_SYSERROR (s_sys_setegid);
- return SCM_UNSPECIFIED;
-
-}
-
-SCM_PROC (s_getpgrp, "getpgrp", 0, 0, 0, scm_getpgrp);
-SCM
-scm_getpgrp ()
-{
- int (*fn)();
- fn = (int (*) ()) getpgrp;
- return SCM_MAKINUM (fn (0));
-}
-
-SCM_PROC (s_sys_setpgid, "setpgid", 2, 0, 0, scm_setpgid);
-SCM
-scm_setpgid (pid, pgid)
- SCM pid, pgid;
-{
-#ifdef HAVE_SETPGID
- SCM_ASSERT (SCM_INUMP (pid), pid, SCM_ARG1, s_sys_setpgid);
- SCM_ASSERT (SCM_INUMP (pgid), pgid, SCM_ARG2, s_sys_setpgid);
- /* FIXME(?): may be known as setpgrp. */
- if (setpgid (SCM_INUM (pid), SCM_INUM (pgid)) != 0)
- SCM_SYSERROR (s_sys_setpgid);
- return SCM_UNSPECIFIED;
-#else
- SCM_SYSMISSING (s_sys_setpgid);
- /* not reached. */
- return SCM_BOOL_F;
-#endif
-}
-
-SCM_PROC (s_sys_setsid, "setsid", 0, 0, 0, scm_setsid);
-SCM
-scm_setsid ()
-{
-#ifdef HAVE_SETSID
- pid_t sid = setsid ();
- if (sid == -1)
- SCM_SYSERROR (s_sys_setsid);
- return SCM_UNSPECIFIED;
-#else
- SCM_SYSMISSING (s_sys_setsid);
- /* not reached. */
- return SCM_BOOL_F;
-#endif
-}
-
-SCM_PROC (s_ttyname, "ttyname", 1, 0, 0, scm_ttyname);
-#ifdef __STDC__
-SCM
-scm_ttyname (SCM port)
-#else
-SCM
-scm_ttyname (port)
- SCM port;
-#endif
-{
- char *ans;
- int fd;
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPPORTP (port), port, SCM_ARG1, s_ttyname);
- if (scm_tc16_fport != SCM_TYP16 (port))
- return SCM_BOOL_F;
- fd = fileno ((FILE *)SCM_STREAM (port));
- if (fd == -1)
- SCM_SYSERROR (s_ttyname);
- SCM_SYSCALL (ans = ttyname (fd));
- if (!ans)
- SCM_SYSERROR (s_ttyname);
- /* ans could be overwritten by another call to ttyname */
- return (scm_makfrom0str (ans));
-}
-
-
-SCM_PROC (s_sys_ctermid, "ctermid", 0, 0, 0, scm_ctermid);
-SCM
-scm_ctermid ()
-{
-#ifdef HAVE_CTERMID
- char *result = ctermid (NULL);
- if (*result == '\0')
- SCM_SYSERROR (s_sys_ctermid);
- return scm_makfrom0str (result);
-#else
- SCM_SYSMISSING (s_sys_ctermid);
- /* not reached. */
- return SCM_BOOL_F;
-#endif
-}
-
-SCM_PROC (s_sys_tcgetpgrp, "tcgetpgrp", 1, 0, 0, scm_tcgetpgrp);
-SCM
-scm_tcgetpgrp (port)
- SCM port;
-{
-#ifdef HAVE_TCGETPGRP
- int fd;
- pid_t pgid;
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_sys_tcgetpgrp);
- fd = fileno ((FILE *)SCM_STREAM (port));
- if (fd == -1 || (pgid = tcgetpgrp (fd)) == -1)
- SCM_SYSERROR (s_sys_tcgetpgrp);
- return SCM_MAKINUM (pgid);
-#else
- SCM_SYSMISSING (s_sys_tcgetpgrp);
- /* not reached. */
- return SCM_BOOL_F;
-#endif
-}
-
-SCM_PROC (s_sys_tcsetpgrp, "tcsetpgrp", 2, 0, 0, scm_tcsetpgrp);
-SCM
-scm_tcsetpgrp (port, pgid)
- SCM port, pgid;
-{
-#ifdef HAVE_TCSETPGRP
- int fd;
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_sys_tcsetpgrp);
- SCM_ASSERT (SCM_INUMP (pgid), pgid, SCM_ARG2, s_sys_tcsetpgrp);
- fd = fileno ((FILE *)SCM_STREAM (port));
- if (fd == -1 || tcsetpgrp (fd, SCM_INUM (pgid)) == -1)
- SCM_SYSERROR (s_sys_tcsetpgrp);
- return SCM_UNSPECIFIED;
-#else
- SCM_SYSMISSING (s_sys_tcsetpgrp);
- /* not reached. */
- return SCM_BOOL_F;
-#endif
-}
-
-/* Copy exec args from an SCM vector into a new C array. */
-#ifdef __STDC__
-static char **
-scm_convert_exec_args (SCM args)
-#else
-static char **
-scm_convert_exec_args (args)
- SCM args;
-#endif
-{
- char **execargv;
- int num_args;
- int i;
- SCM_DEFER_INTS;
- num_args = scm_ilength (args);
- execargv = (char **)
- scm_must_malloc ((num_args + 1) * sizeof (char *), s_ttyname);
- for (i = 0; SCM_NNULLP (args); args = SCM_CDR (args), ++i)
- {
- scm_sizet len;
- char *dst;
- char *src;
- SCM_ASSERT (SCM_NIMP (SCM_CAR (args)) && SCM_ROSTRINGP (SCM_CAR (args)), SCM_CAR (args),
- "wrong type in SCM_ARG", "exec arg");
- len = 1 + SCM_ROLENGTH (SCM_CAR (args));
- dst = (char *) scm_must_malloc ((long) len, s_ttyname);
- src = SCM_ROCHARS (SCM_CAR (args));
- while (len--)
- dst[len] = src[len];
- execargv[i] = dst;
- }
- execargv[i] = 0;
- SCM_ALLOW_INTS;
- return execargv;
-}
-
-SCM_PROC (s_sys_execl, "execl", 0, 0, 1, scm_sys_execl);
-#ifdef __STDC__
-SCM
-scm_sys_execl (SCM args)
-#else
-SCM
-scm_sys_execl (args)
- SCM args;
-#endif
-{
- char **execargv;
- SCM filename = SCM_CAR (args);
- SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, SCM_ARG1, s_sys_execl);
- if (SCM_SUBSTRP (filename))
- filename = scm_makfromstr (SCM_ROCHARS (filename), SCM_ROLENGTH (filename), 0);
- args = SCM_CDR (args);
- execargv = scm_convert_exec_args (args);
- execv (SCM_ROCHARS (filename), execargv);
- SCM_SYSERROR (s_sys_execl);
- /* not reached. */
- return SCM_BOOL_F;
-}
-
-SCM_PROC (s_sys_execlp, "execlp", 0, 0, 1, scm_sys_execlp);
-#ifdef __STDC__
-SCM
-scm_sys_execlp (SCM args)
-#else
-SCM
-scm_sys_execlp (args)
- SCM args;
-#endif
-{
- char **execargv;
- SCM filename = SCM_CAR (args);
- SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, SCM_ARG1, s_sys_execlp);
- if (SCM_SUBSTRP (filename))
- filename = scm_makfromstr (SCM_ROCHARS (filename), SCM_ROLENGTH (filename), 0);
- args = SCM_CDR (args);
- execargv = scm_convert_exec_args (args);
- execvp (SCM_ROCHARS (filename), execargv);
- SCM_SYSERROR (s_sys_execlp);
- /* not reached. */
- return SCM_BOOL_F;
-}
-
-/* Flushing streams etc., is not done here. */
-SCM_PROC (s_sys_fork, "fork", 0, 0, 0, scm_sys_fork);
-#ifdef __STDC__
-SCM
-scm_sys_fork(void)
-#else
-SCM
-scm_sys_fork()
-#endif
-{
- int pid;
- pid = fork ();
- if (pid == -1)
- SCM_SYSERROR (s_sys_fork);
- return SCM_MAKINUM (0L+pid);
-}
-
-
-SCM_PROC (s_sys_uname, "uname", 0, 0, 0, scm_sys_uname);
-#ifdef __STDC__
-SCM
-scm_sys_uname (void)
-#else
-SCM
-scm_sys_uname ()
-#endif
-{
-#ifdef HAVE_UNAME
- struct utsname buf;
- SCM ans = scm_make_vector(SCM_MAKINUM(5), SCM_UNSPECIFIED, SCM_BOOL_F);
- SCM *ve = SCM_VELTS (ans);
- if (uname (&buf))
- return SCM_MAKINUM (errno);
- ve[0] = scm_makfrom0str (buf.sysname);
- ve[1] = scm_makfrom0str (buf.nodename);
- ve[2] = scm_makfrom0str (buf.release);
- ve[3] = scm_makfrom0str (buf.version);
- ve[4] = scm_makfrom0str (buf.machine);
-/*
- a linux special?
- ve[5] = scm_makfrom0str (buf.domainname);
-*/
- return ans;
-#else
- SCM_SYSMISSING (s_sys_uname);
- /* not reached. */
- return SCM_BOOL_F;
-#endif
-}
-
-SCM_PROC (s_environ, "environ", 0, 1, 0, scm_environ);
-#ifdef __STDC__
-SCM
-scm_environ (SCM env)
-#else
-SCM
-scm_environ (env)
- SCM env;
-#endif
-{
- if (SCM_UNBNDP (env))
- return scm_makfromstrs (-1, environ);
- else
- {
- int num_strings;
- char **new_environ;
- int i = 0;
- 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);
- while (SCM_NNULLP (env))
- {
- int len;
- char *src;
- SCM_ASSERT (SCM_NIMP (SCM_CAR (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);
- src = SCM_ROCHARS (SCM_CAR (env));
- while (len--)
- new_environ[i][len] = src[len];
- env = SCM_CDR (env);
- i++;
- }
- new_environ[i] = 0;
- /* Free the old environment, except when called for the first
- * time.
- */
- {
- char **ep;
- static int first = 1;
- if (!first)
- {
- for (ep = environ; *ep != NULL; ep++)
- scm_must_free (*ep);
- scm_must_free ((char *) environ);
- }
- first = 0;
- }
- environ = new_environ;
- return SCM_UNSPECIFIED;
- }
-}
-
-
-SCM_PROC (s_open_pipe, "open-pipe", 2, 0, 0, scm_open_pipe);
-#ifdef __STDC__
-SCM
-scm_open_pipe (SCM pipestr, SCM modes)
-#else
-SCM
-scm_open_pipe (pipestr, modes)
- SCM pipestr;
- SCM modes;
-#endif
-{
- FILE *f;
- register SCM z;
- struct scm_port_table * pt;
-
- SCM_ASSERT (SCM_NIMP (pipestr) && SCM_ROSTRINGP (pipestr), pipestr, SCM_ARG1, s_open_pipe);
- if (SCM_SUBSTRP (pipestr))
- pipestr = scm_makfromstr (SCM_ROCHARS (pipestr), SCM_ROLENGTH (pipestr), 0);
- SCM_ASSERT (SCM_NIMP (modes) && SCM_ROSTRINGP (modes), modes, SCM_ARG2, s_open_pipe);
- if (SCM_SUBSTRP (modes))
- modes = scm_makfromstr (SCM_ROCHARS (modes), SCM_ROLENGTH (modes), 0);
- SCM_NEWCELL (z);
- SCM_DEFER_INTS;
- scm_ignore_signals ();
- SCM_SYSCALL (f = popen (SCM_ROCHARS (pipestr), SCM_ROCHARS (modes)));
- scm_unignore_signals ();
- if (!f)
- SCM_SYSERROR (s_open_pipe);
- pt = scm_add_to_port_table (z);
- SCM_SETPTAB_ENTRY (z, pt);
- SCM_CAR (z) = scm_tc16_pipe | SCM_OPN
- | (strchr (SCM_ROCHARS (modes), 'r') ? SCM_RDNG : SCM_WRTNG);
- SCM_SETSTREAM (z, (SCM)f);
- SCM_ALLOW_INTS;
- return z;
-}
-
-
-SCM_PROC (s_open_input_pipe, "open-input-pipe", 1, 0, 0, scm_open_input_pipe);
-#ifdef __STDC__
-SCM
-scm_open_input_pipe(SCM pipestr)
-#else
-SCM
-scm_open_input_pipe(pipestr)
- SCM pipestr;
-#endif
-{
- 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);
-#ifdef __STDC__
-SCM
-scm_open_output_pipe(SCM pipestr)
-#else
-SCM
-scm_open_output_pipe(pipestr)
- SCM pipestr;
-#endif
-{
- return scm_open_pipe(pipestr, scm_makfromstr("w", (sizeof "w")-1, 0));
-}
-
-
-SCM_PROC (s_sys_utime, "utime", 1, 2, 0, scm_sys_utime);
-#ifdef __STDC__
-SCM
-scm_sys_utime (SCM pathname, SCM actime, SCM modtime)
-#else
-SCM
-scm_sys_utime (pathname, actime, modtime)
- SCM pathname;
- SCM actime;
- SCM modtime;
-#endif
-{
- int rv;
- struct utimbuf utm_tmp;
-
- SCM_ASSERT (SCM_NIMP (pathname) && SCM_STRINGP (pathname), pathname, SCM_ARG1, s_sys_utime);
-
- if (SCM_UNBNDP (actime))
- SCM_SYSCALL (time (&utm_tmp.actime));
- else
- utm_tmp.actime = scm_num2ulong (actime, (char *) SCM_ARG2, s_sys_utime);
-
- if (SCM_UNBNDP (modtime))
- SCM_SYSCALL (time (&utm_tmp.modtime));
- else
- utm_tmp.modtime = scm_num2ulong (modtime, (char *) SCM_ARG3, s_sys_utime);
-
- SCM_SYSCALL (rv = utime (SCM_CHARS (pathname), &utm_tmp));
- if (rv != 0)
- SCM_SYSERROR (s_sys_utime);
- return SCM_UNSPECIFIED;
-}
-
-SCM_PROC (s_sys_access, "access?", 2, 0, 0, scm_sys_access);
-#ifdef __STDC__
-SCM
-scm_sys_access (SCM path, SCM how)
-#else
-SCM
-scm_sys_access (path, how)
- SCM path;
- SCM how;
-#endif
-{
- int rv;
-
- SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, SCM_ARG1, s_sys_access);
- if (SCM_SUBSTRP (path))
- path = scm_makfromstr (SCM_ROCHARS (path), SCM_ROLENGTH (path), 0);
- SCM_ASSERT (SCM_INUMP (how), how, SCM_ARG2, s_sys_access);
- rv = access (SCM_ROCHARS (path), SCM_INUM (how));
- return rv ? SCM_BOOL_F : SCM_BOOL_T;
-}
-
-SCM_PROC (s_getpid, "getpid", 0, 0, 0, scm_getpid);
-#ifdef __STDC__
-SCM
-scm_getpid (void)
-#else
-SCM
-scm_getpid ()
-#endif
-{
- return SCM_MAKINUM ((unsigned long) getpid ());
-}
-
-SCM_PROC (s_sys_putenv, "putenv", 1, 0, 0, scm_sys_putenv);
-#ifdef __STDC__
-SCM
-scm_sys_putenv (SCM str)
-#else
-SCM
-scm_sys_putenv (str)
- SCM str;
-#endif
-{
-#ifdef HAVE_PUTENV
- SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_sys_putenv);
- return putenv (SCM_CHARS (str)) ? SCM_MAKINUM (errno) : SCM_BOOL_T;
-#else
- SCM_SYSMISSING (s_sys_putenv);
- /* not reached. */
- return SCM_BOOL_F;
-#endif
-}
-
-SCM_PROC (s_read_line, "read-line", 0, 2, 0, scm_read_line);
-#ifdef __STDC__
-SCM
-scm_read_line (SCM port, SCM include_terminator)
-#else
-SCM
-scm_read_line (port, include_terminator)
- SCM port;
- SCM include_terminator;
-#endif
-{
- register int c;
- register int j = 0;
- scm_sizet len = 30;
- SCM tok_buf;
- register char *p;
- int include;
-
- tok_buf = scm_makstr ((long) len, 0);
- p = SCM_CHARS (tok_buf);
- if (SCM_UNBNDP (port))
- port = scm_cur_inp;
- else
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_read_line);
-
- if (SCM_UNBNDP (include_terminator))
- include = 0;
- else
- include = SCM_NFALSEP (include_terminator);
-
- if (EOF == (c = scm_gen_getc (port)))
- return SCM_EOF_VAL;
- while (1)
- {
- switch (c)
- {
- case SCM_LINE_INCREMENTORS:
- if (j >= len)
- {
- p = scm_grow_tok_buf (&tok_buf);
- len = SCM_LENGTH (tok_buf);
- }
- p[j++] = c;
- /* fallthrough */
- case EOF:
- if (len == j)
- return tok_buf;
- return scm_vector_set_length_x (tok_buf, (SCM) SCM_MAKINUM (j));
-
- default:
- if (j >= len)
- {
- p = scm_grow_tok_buf (&tok_buf);
- len = SCM_LENGTH (tok_buf);
- }
- p[j++] = c;
- c = scm_gen_getc (port);
- break;
- }
- }
-}
-
-SCM_PROC (s_read_line_x, "read-line!", 1, 1, 0, scm_read_line_x);
-#ifdef __STDC__
-SCM
-scm_read_line_x (SCM str, SCM port)
-#else
-SCM
-scm_read_line_x (str, port)
- SCM str;
- SCM port;
-#endif
-{
- register int c;
- register int j = 0;
- register char *p;
- scm_sizet len;
- SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_read_line_x);
- p = SCM_CHARS (str);
- len = SCM_LENGTH (str);
- if SCM_UNBNDP
- (port) port = scm_cur_inp;
- else
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG2, s_read_line_x);
- c = scm_gen_getc (port);
- if (EOF == c)
- return SCM_EOF_VAL;
- while (1)
- {
- switch (c)
- {
- case SCM_LINE_INCREMENTORS:
- case EOF:
- return SCM_MAKINUM (j);
- default:
- if (j >= len)
- {
- scm_gen_ungetc (c, port);
- return SCM_BOOL_F;
- }
- p[j++] = c;
- c = scm_gen_getc (port);
- }
- }
-}
-
-SCM_PROC (s_write_line, "write-line", 1, 1, 0, scm_write_line);
-#ifdef __STDC__
-SCM
-scm_write_line (SCM obj, SCM port)
-#else
-SCM
-scm_write_line (obj, port)
- SCM obj;
- SCM port;
-#endif
-{
- scm_display (obj, port);
- return scm_newline (port);
-}
-
-SCM_PROC (s_setlocale, "setlocale", 1, 1, 0, scm_setlocale);
-#ifdef __STDC__
-SCM
-scm_setlocale (SCM category, SCM locale)
-#else
-SCM
-scm_setlocale (category, locale)
- SCM category;
- SCM locale;
-#endif
-{
-#ifdef HAVE_SETLOCALE
- char *clocale;
- char *rv;
-
- SCM_ASSERT (SCM_INUMP (category), category, SCM_ARG1, s_setlocale);
- if (SCM_UNBNDP (locale))
- {
- clocale = NULL;
- }
- else
- {
- SCM_ASSERT (SCM_NIMP (locale) && SCM_STRINGP (locale), locale, SCM_ARG2, s_setlocale);
- clocale = SCM_CHARS (locale);
- }
-
- rv = setlocale (SCM_INUM (category), clocale);
- if (rv == NULL)
- SCM_SYSERROR (s_setlocale);
- return scm_makfrom0str (rv);
-#else
- SCM_SYSMISSING (s_setlocale);
- /* not reached. */
- return SCM_BOOL_F;
-#endif
-}
-
-SCM_PROC (s_strftime, "strftime", 2, 0, 0, scm_strftime);
-#ifdef __STDC__
-SCM
-scm_strftime (SCM format, SCM stime)
-#else
-SCM
-scm_strftime (format, stime)
- SCM format;
- SCM stime;
-#endif
-{
- struct tm t;
-
- char *tbuf;
- int n;
- int size = 50;
- char *fmt;
- int len;
-
- SCM_ASSERT (SCM_NIMP (format) && SCM_STRINGP (format), format, SCM_ARG1, s_strftime);
- SCM_ASSERT (SCM_NIMP (stime) && SCM_VECTORP (stime) && scm_obj_length (stime) == 9,
- stime, SCM_ARG2, s_strftime);
-
- fmt = SCM_ROCHARS (format);
- len = SCM_ROLENGTH (format);
-
-#define tm_deref scm_num2long (SCM_VELTS (stime)[n++], (char *)SCM_ARG2, s_strftime)
- n = 0;
- t.tm_sec = tm_deref;
- t.tm_min = tm_deref;
- t.tm_hour = tm_deref;
- t.tm_mday = tm_deref;
- t.tm_mon = tm_deref;
- t.tm_year = tm_deref;
- /* not used by mktime.
- t.tm_wday = tm_deref;
- t.tm_yday = tm_deref; */
- t.tm_isdst = tm_deref;
-#undef tm_deref
-
- /* fill in missing fields and set the timezone. */
- mktime (&t);
-
- 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);
- }
- return scm_makfromstr (tbuf, len, 0);
-}
-
-SCM_PROC (s_sys_strptime, "strptime", 2, 0, 0, scm_sys_strptime);
-#ifdef __STDC__
-SCM
-scm_sys_strptime (SCM format, SCM string)
-#else
-SCM
-scm_sys_strptime (format, string)
- SCM format;
- SCM string;
-#endif
-{
-#ifdef HAVE_STRPTIME
- SCM stime;
- struct tm t;
-
- char *fmt, *str, *rest;
- int n;
-
- SCM_ASSERT (SCM_NIMP (format) && SCM_ROSTRINGP (format), format, SCM_ARG1, s_sys_strptime);
- if (SCM_SUBSTRP (format))
- format = scm_makfromstr (SCM_ROCHARS (format), SCM_ROLENGTH (format), 0);
- SCM_ASSERT (SCM_NIMP (string) && SCM_ROSTRINGP (string), string, SCM_ARG2, s_sys_strptime);
- if (SCM_SUBSTRP (string))
- string = scm_makfromstr (SCM_ROCHARS (string), SCM_ROLENGTH (string), 0);
-
- fmt = SCM_CHARS (format);
- str = SCM_CHARS (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);
- tm_init (tm_isdst);
-#undef tm_init
-
- SCM_DEFER_INTS;
- rest = strptime (str, fmt, &t);
- SCM_ALLOW_INTS;
-
- if (rest == NULL)
- SCM_SYSERROR (s_sys_strptime);
-
- stime = scm_make_vector (SCM_MAKINUM (9), scm_long2num (0), SCM_UNDEFINED);
-
-#define stime_set(val) scm_vector_set_x (stime, SCM_MAKINUM (n++), scm_long2num (t.val));
- n = 0;
- stime_set (tm_sec);
- stime_set (tm_min);
- stime_set (tm_hour);
- stime_set (tm_mday);
- stime_set (tm_mon);
- stime_set (tm_year);
- stime_set (tm_wday);
- stime_set (tm_yday);
- stime_set (tm_isdst);
-#undef stime_set
-
- return scm_cons (stime, scm_makfrom0str (rest));
-#else
- SCM_SYSMISSING (s_sys_strptime);
- /* not reached. */
- return SCM_BOOL_F;
-#endif
-}
-
-SCM_PROC (s_sys_mknod, "mknod", 3, 0, 0, scm_sys_mknod);
-#ifdef __STDC__
-SCM
-scm_sys_mknod(SCM path, SCM mode, SCM dev)
-#else
-SCM
-scm_sys_mknod(path, mode, dev)
- SCM path;
- SCM mode;
- SCM dev;
-#endif
-{
-#ifdef HAVE_MKNOD
- int val;
- SCM_ASSERT(SCM_NIMP(path) && SCM_STRINGP(path), path, SCM_ARG1, s_sys_mknod);
- SCM_ASSERT(SCM_INUMP(mode), mode, SCM_ARG2, s_sys_mknod);
- SCM_ASSERT(SCM_INUMP(dev), dev, SCM_ARG3, s_sys_mknod);
- SCM_SYSCALL(val = mknod(SCM_CHARS(path), SCM_INUM(mode), SCM_INUM(dev)));
- if (val != 0)
- SCM_SYSERROR (s_sys_mknod);
- return SCM_UNSPECIFIED;
-#else
- SCM_SYSMISSING (s_sys_mknod);
- /* not reached. */
- return SCM_BOOL_F;
-#endif
-}
-
-
-SCM_PROC (s_sys_nice, "nice", 1, 0, 0, scm_sys_nice);
-#ifdef __STDC__
-SCM
-scm_sys_nice(SCM incr)
-#else
-SCM
-scm_sys_nice(incr)
- SCM incr;
-#endif
-{
-#ifdef HAVE_NICE
- SCM_ASSERT(SCM_INUMP(incr), incr, SCM_ARG1, s_sys_nice);
- if (nice(SCM_INUM(incr)) != 0)
- SCM_SYSERROR (s_sys_nice);
- return SCM_UNSPECIFIED;
-#else
- SCM_SYSMISSING (s_sys_nice);
- /* not reached. */
- return SCM_BOOL_F;
-#endif
-}
-
-
-SCM_PROC (s_sync, "sync", 0, 0, 0, scm_sync);
-#ifdef __STDC__
-SCM
-scm_sync(void)
-#else
-SCM
-scm_sync()
-#endif
-{
-#ifdef HAVE_SYNC
- sync();
-#endif
- SCM_SYSMISSING (s_sync);
- /* not reached. */
- return SCM_BOOL_F;
-}
-
-
-
-#ifdef __STDC__
-void
-scm_init_posix (void)
-#else
-void
-scm_init_posix ()
-#endif
-{
- scm_add_feature ("posix");
-#ifdef HAVE_GETEUID
- scm_add_feature ("EIDs");
-#endif
-#ifdef WAIT_ANY
- scm_sysintern ("WAIT_ANY", SCM_MAKINUM (WAIT_ANY));
-#endif
-#ifdef WAIT_MYPGRP
- scm_sysintern ("WAIT_MYPGRP", SCM_MAKINUM (WAIT_MYPGRP));
-#endif
-#ifdef WNOHANG
- scm_sysintern ("WNOHANG", SCM_MAKINUM (WNOHANG));
-#endif
-#ifdef WUNTRACED
- scm_sysintern ("WUNTRACED", SCM_MAKINUM (WUNTRACED));
-#endif
-
-#ifdef EINTR
- scm_sysintern ("EINTR", SCM_MAKINUM (EINTR));
-#endif
-
-#ifdef SIGHUP
- scm_sysintern ("SIGHUP", SCM_MAKINUM (SIGHUP));
-#endif
-#ifdef SIGINT
- scm_sysintern ("SIGINT", SCM_MAKINUM (SIGINT));
-#endif
-#ifdef SIGQUIT
- scm_sysintern ("SIGQUIT", SCM_MAKINUM (SIGQUIT));
-#endif
-#ifdef SIGILL
- scm_sysintern ("SIGILL", SCM_MAKINUM (SIGILL));
-#endif
-#ifdef SIGTRAP
- scm_sysintern ("SIGTRAP", SCM_MAKINUM (SIGTRAP));
-#endif
-#ifdef SIGABRT
- scm_sysintern ("SIGABRT", SCM_MAKINUM (SIGABRT));
-#endif
-#ifdef SIGIOT
- scm_sysintern ("SIGIOT", SCM_MAKINUM (SIGIOT));
-#endif
-#ifdef SIGBUS
- scm_sysintern ("SIGBUS", SCM_MAKINUM (SIGBUS));
-#endif
-#ifdef SIGFPE
- scm_sysintern ("SIGFPE", SCM_MAKINUM (SIGFPE));
-#endif
-#ifdef SIGKILL
- scm_sysintern ("SIGKILL", SCM_MAKINUM (SIGKILL));
-#endif
-#ifdef SIGUSR1
- scm_sysintern ("SIGUSR1", SCM_MAKINUM (SIGUSR1));
-#endif
-#ifdef SIGSEGV
- scm_sysintern ("SIGSEGV", SCM_MAKINUM (SIGSEGV));
-#endif
-#ifdef SIGUSR2
- scm_sysintern ("SIGUSR2", SCM_MAKINUM (SIGUSR2));
-#endif
-#ifdef SIGPIPE
- scm_sysintern ("SIGPIPE", SCM_MAKINUM (SIGPIPE));
-#endif
-#ifdef SIGALRM
- scm_sysintern ("SIGALRM", SCM_MAKINUM (SIGALRM));
-#endif
-#ifdef SIGTERM
- scm_sysintern ("SIGTERM", SCM_MAKINUM (SIGTERM));
-#endif
-#ifdef SIGSTKFLT
- scm_sysintern ("SIGSTKFLT", SCM_MAKINUM (SIGSTKFLT));
-#endif
-#ifdef SIGCHLD
- scm_sysintern ("SIGCHLD", SCM_MAKINUM (SIGCHLD));
-#endif
-#ifdef SIGCONT
- scm_sysintern ("SIGCONT", SCM_MAKINUM (SIGCONT));
-#endif
-#ifdef SIGSTOP
- scm_sysintern ("SIGSTOP", SCM_MAKINUM (SIGSTOP));
-#endif
-#ifdef SIGTSTP
- scm_sysintern ("SIGTSTP", SCM_MAKINUM (SIGTSTP));
-#endif
-#ifdef SIGTTIN
- scm_sysintern ("SIGTTIN", SCM_MAKINUM (SIGTTIN));
-#endif
-#ifdef SIGTTOU
- scm_sysintern ("SIGTTOU", SCM_MAKINUM (SIGTTOU));
-#endif
-#ifdef SIGIO
- scm_sysintern ("SIGIO", SCM_MAKINUM (SIGIO));
-#endif
-#ifdef SIGPOLL
- scm_sysintern ("SIGPOLL", SCM_MAKINUM (SIGPOLL));
-#endif
-#ifdef SIGURG
- scm_sysintern ("SIGURG", SCM_MAKINUM (SIGURG));
-#endif
-#ifdef SIGXCPU
- scm_sysintern ("SIGXCPU", SCM_MAKINUM (SIGXCPU));
-#endif
-#ifdef SIGXFSZ
- scm_sysintern ("SIGXFSZ", SCM_MAKINUM (SIGXFSZ));
-#endif
-#ifdef SIGVTALRM
- scm_sysintern ("SIGVTALRM", SCM_MAKINUM (SIGVTALRM));
-#endif
-#ifdef SIGPROF
- scm_sysintern ("SIGPROF", SCM_MAKINUM (SIGPROF));
-#endif
-#ifdef SIGWINCH
- scm_sysintern ("SIGWINCH", SCM_MAKINUM (SIGWINCH));
-#endif
-#ifdef SIGLOST
- scm_sysintern ("SIGLOST", SCM_MAKINUM (SIGLOST));
-#endif
-#ifdef SIGPWR
- scm_sysintern ("SIGPWR", SCM_MAKINUM (SIGPWR));
-#endif
- /* access() symbols. */
- scm_sysintern ("R_OK", SCM_MAKINUM (R_OK));
- scm_sysintern ("W_OK", SCM_MAKINUM (W_OK));
- scm_sysintern ("X_OK", SCM_MAKINUM (X_OK));
- scm_sysintern ("F_OK", SCM_MAKINUM (F_OK));
-
-#ifdef LC_COLLATE
- scm_sysintern ("LC_COLLATE", SCM_MAKINUM (LC_COLLATE));
-#endif
-#ifdef LC_CTYPE
- scm_sysintern ("LC_CTYPE", SCM_MAKINUM (LC_CTYPE));
-#endif
-#ifdef LC_MONETARY
- scm_sysintern ("LC_MONETARY", SCM_MAKINUM (LC_MONETARY));
-#endif
-#ifdef LC_NUMERIC
- scm_sysintern ("LC_NUMERIC", SCM_MAKINUM (LC_NUMERIC));
-#endif
-#ifdef LC_TIME
- scm_sysintern ("LC_TIME", SCM_MAKINUM (LC_TIME));
-#endif
-#ifdef LC_MESSAGES
- scm_sysintern ("LC_MESSAGES", SCM_MAKINUM (LC_MESSAGES));
-#endif
-#ifdef LC_ALL
- scm_sysintern ("LC_ALL", SCM_MAKINUM (LC_ALL));
-#endif
-#include "posix.x"
-}
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 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
+
+/* Make GNU/Linux libc declare everything it has. */
+#define _GNU_SOURCE
+
+#include <stdio.h>
+#include <errno.h>
+
+#include "libguile/_scm.h"
+#include "libguile/fports.h"
+#include "libguile/scmsigs.h"
+#include "libguile/feature.h"
+#include "libguile/strings.h"
+#include "libguile/vectors.h"
+#include "libguile/lang.h"
+
+#include "libguile/validate.h"
+#include "libguile/posix.h"
+\f
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
+#ifdef TIME_WITH_SYS_TIME
+# include <sys/time.h>
+# include <time.h>
+#else
+# if HAVE_SYS_TIME_H
+# include <sys/time.h>
+# else
+# include <time.h>
+# endif
+#endif
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#else
+#ifndef ttyname
+extern char *ttyname();
+#endif
+#endif
+
+#ifdef LIBC_H_WITH_UNISTD_H
+#include <libc.h>
+#endif
+
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <fcntl.h>
+
+#ifdef HAVE_PWD_H
+#include <pwd.h>
+#endif
+#ifdef HAVE_IO_H
+#include <io.h>
+#endif
+#ifdef HAVE_WINSOCK2_H
+#include <winsock2.h>
+#endif
+
+#ifdef __MINGW32__
+/* Some defines for Windows here. */
+# include <process.h>
+# define pipe(fd) _pipe (fd, 256, O_BINARY)
+#endif /* __MINGW32__ */
+
+#if HAVE_SYS_WAIT_H
+# include <sys/wait.h>
+#endif
+#ifndef WEXITSTATUS
+# define WEXITSTATUS(stat_val) ((unsigned)(stat_val) >> 8)
+#endif
+#ifndef WIFEXITED
+# define WIFEXITED(stat_val) (((stat_val) & 255) == 0)
+#endif
+
+#include <signal.h>
+
+extern char ** environ;
+
+#ifdef HAVE_GRP_H
+#include <grp.h>
+#endif
+#ifdef HAVE_SYS_UTSNAME_H
+#include <sys/utsname.h>
+#endif
+
+#ifdef HAVE_SETLOCALE
+#include <locale.h>
+#endif
+
+#if HAVE_LIBCRYPT && HAVE_CRYPT_H
+# include <crypt.h>
+#endif
+
+#if HAVE_SYS_RESOURCE_H
+# include <sys/resource.h>
+#endif
+
+#if HAVE_SYS_FILE_H
+# include <sys/file.h>
+#endif
+
+/* Some Unix systems don't define these. CPP hair is dangerous, but
+ this seems safe enough... */
+#ifndef R_OK
+#define R_OK 4
+#endif
+
+#ifndef W_OK
+#define W_OK 2
+#endif
+
+#ifndef X_OK
+#define X_OK 1
+#endif
+
+#ifndef F_OK
+#define F_OK 0
+#endif
+
+/* On NextStep, <utime.h> doesn't define struct utime, unless we
+ #define _POSIX_SOURCE before #including it. I think this is less
+ of a kludge than defining struct utimbuf ourselves. */
+#ifdef UTIMBUF_NEEDS_POSIX
+#define _POSIX_SOURCE
+#endif
+
+#ifdef HAVE_SYS_UTIME_H
+#include <sys/utime.h>
+#endif
+
+#ifdef HAVE_UTIME_H
+#include <utime.h>
+#endif
+
+/* Please don't add any more #includes or #defines here. The hack
+ above means that _POSIX_SOURCE may be #defined, which will
+ encourage header files to do strange things. */
+
+\f
+SCM_SYMBOL (sym_read_pipe, "read pipe");
+SCM_SYMBOL (sym_write_pipe, "write pipe");
+
+SCM_DEFINE (scm_pipe, "pipe", 0, 0, 0,
+ (),
+ "Return a newly created pipe: a pair of ports which are linked\n"
+ "together on the local machine. The @emph{car} is the input\n"
+ "port and the @emph{cdr} is the output port. Data written (and\n"
+ "flushed) to the output port can be read from the input port.\n"
+ "Pipes are commonly used for communication with a newly forked\n"
+ "child process. The need to flush the output port can be\n"
+ "avoided by making it unbuffered using @code{setvbuf}.\n"
+ "\n"
+ "Writes occur atomically provided the size of the data in bytes\n"
+ "is not greater than the value of @code{PIPE_BUF}. Note that\n"
+ "the output port is likely to block if too much data (typically\n"
+ "equal to @code{PIPE_BUF}) has been written but not yet read\n"
+ "from the input port.")
+#define FUNC_NAME s_scm_pipe
+{
+ int fd[2], rv;
+ SCM p_rd, p_wt;
+
+ rv = pipe (fd);
+ if (rv)
+ SCM_SYSERROR;
+
+ p_rd = scm_fdes_to_port (fd[0], "r", sym_read_pipe);
+ p_wt = scm_fdes_to_port (fd[1], "w", sym_write_pipe);
+ return scm_cons (p_rd, p_wt);
+}
+#undef FUNC_NAME
+
+
+#ifdef HAVE_GETGROUPS
+SCM_DEFINE (scm_getgroups, "getgroups", 0, 0, 0,
+ (),
+ "Return a vector of integers representing the current\n"
+ "supplementary group IDs.")
+#define FUNC_NAME s_scm_getgroups
+{
+ SCM ans;
+ int ngroups;
+ size_t size;
+ GETGROUPS_T *groups;
+
+ ngroups = getgroups (0, NULL);
+ if (ngroups <= 0)
+ SCM_SYSERROR;
+
+ size = ngroups * sizeof (GETGROUPS_T);
+ groups = scm_malloc (size);
+ getgroups (ngroups, groups);
+
+ ans = scm_c_make_vector (ngroups, SCM_UNDEFINED);
+
+ {
+ SCM * ve = SCM_WRITABLE_VELTS(ans);
+
+ while (--ngroups >= 0)
+ ve[ngroups] = SCM_MAKINUM (groups [ngroups]);
+ }
+ free (groups);
+ return ans;
+}
+#undef FUNC_NAME
+#endif
+
+#ifdef HAVE_GETPWENT
+SCM_DEFINE (scm_getpwuid, "getpw", 0, 1, 0,
+ (SCM user),
+ "Look up an entry in the user database. @var{obj} can be an integer,\n"
+ "a string, or omitted, giving the behaviour of getpwuid, getpwnam\n"
+ "or getpwent respectively.")
+#define FUNC_NAME s_scm_getpwuid
+{
+ struct passwd *entry;
+
+ SCM ans = scm_c_make_vector (7, SCM_UNSPECIFIED);
+ if (SCM_UNBNDP (user) || SCM_FALSEP (user))
+ {
+ SCM_SYSCALL (entry = getpwent ());
+ if (! entry)
+ {
+ return SCM_BOOL_F;
+ }
+ }
+ else if (SCM_INUMP (user))
+ {
+ entry = getpwuid (SCM_INUM (user));
+ }
+ else
+ {
+ SCM_VALIDATE_STRING (1, user);
+ entry = getpwnam (SCM_STRING_CHARS (user));
+ }
+ if (!entry)
+ SCM_MISC_ERROR ("entry not found", SCM_EOL);
+
+ SCM_VECTOR_SET(ans, 0, scm_makfrom0str (entry->pw_name));
+ SCM_VECTOR_SET(ans, 1, scm_makfrom0str (entry->pw_passwd));
+ SCM_VECTOR_SET(ans, 2, scm_ulong2num ((unsigned long) entry->pw_uid));
+ SCM_VECTOR_SET(ans, 3, scm_ulong2num ((unsigned long) entry->pw_gid));
+ SCM_VECTOR_SET(ans, 4, scm_makfrom0str (entry->pw_gecos));
+ if (!entry->pw_dir)
+ SCM_VECTOR_SET(ans, 5, scm_makfrom0str (""));
+ else
+ SCM_VECTOR_SET(ans, 5, scm_makfrom0str (entry->pw_dir));
+ if (!entry->pw_shell)
+ SCM_VECTOR_SET(ans, 6, scm_makfrom0str (""));
+ else
+ SCM_VECTOR_SET(ans, 6, scm_makfrom0str (entry->pw_shell));
+ return ans;
+}
+#undef FUNC_NAME
+#endif /* HAVE_GETPWENT */
+
+
+#ifdef HAVE_SETPWENT
+SCM_DEFINE (scm_setpwent, "setpw", 0, 1, 0,
+ (SCM arg),
+ "If called with a true argument, initialize or reset the password data\n"
+ "stream. Otherwise, close the stream. The @code{setpwent} and\n"
+ "@code{endpwent} procedures are implemented on top of this.")
+#define FUNC_NAME s_scm_setpwent
+{
+ if (SCM_UNBNDP (arg) || SCM_FALSEP (arg))
+ endpwent ();
+ else
+ setpwent ();
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif
+
+
+#ifdef HAVE_GETGRENT
+/* Combines getgrgid and getgrnam. */
+SCM_DEFINE (scm_getgrgid, "getgr", 0, 1, 0,
+ (SCM name),
+ "Look up an entry in the group database. @var{obj} can be an integer,\n"
+ "a string, or omitted, giving the behaviour of getgrgid, getgrnam\n"
+ "or getgrent respectively.")
+#define FUNC_NAME s_scm_getgrgid
+{
+ struct group *entry;
+ SCM ans = scm_c_make_vector (4, SCM_UNSPECIFIED);
+
+ if (SCM_UNBNDP (name) || SCM_FALSEP (name))
+ {
+ SCM_SYSCALL (entry = getgrent ());
+ if (! entry)
+ {
+ return SCM_BOOL_F;
+ }
+ }
+ else if (SCM_INUMP (name))
+ SCM_SYSCALL (entry = getgrgid (SCM_INUM (name)));
+ else
+ {
+ SCM_VALIDATE_STRING (1, name);
+ SCM_SYSCALL (entry = getgrnam (SCM_STRING_CHARS (name)));
+ }
+ if (!entry)
+ SCM_SYSERROR;
+
+ SCM_VECTOR_SET(ans, 0, scm_makfrom0str (entry->gr_name));
+ SCM_VECTOR_SET(ans, 1, scm_makfrom0str (entry->gr_passwd));
+ SCM_VECTOR_SET(ans, 2, scm_ulong2num ((unsigned long) entry->gr_gid));
+ SCM_VECTOR_SET(ans, 3, scm_makfromstrs (-1, entry->gr_mem));
+ return ans;
+}
+#undef FUNC_NAME
+
+
+
+SCM_DEFINE (scm_setgrent, "setgr", 0, 1, 0,
+ (SCM arg),
+ "If called with a true argument, initialize or reset the group data\n"
+ "stream. Otherwise, close the stream. The @code{setgrent} and\n"
+ "@code{endgrent} procedures are implemented on top of this.")
+#define FUNC_NAME s_scm_setgrent
+{
+ if (SCM_UNBNDP (arg) || SCM_FALSEP (arg))
+ endgrent ();
+ else
+ setgrent ();
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* HAVE_GETGRENT */
+
+
+SCM_DEFINE (scm_kill, "kill", 2, 0, 0,
+ (SCM pid, SCM sig),
+ "Sends a signal to the specified process or group of processes.\n\n"
+ "@var{pid} specifies the processes to which the signal is sent:\n\n"
+ "@table @r\n"
+ "@item @var{pid} greater than 0\n"
+ "The process whose identifier is @var{pid}.\n"
+ "@item @var{pid} equal to 0\n"
+ "All processes in the current process group.\n"
+ "@item @var{pid} less than -1\n"
+ "The process group whose identifier is -@var{pid}\n"
+ "@item @var{pid} equal to -1\n"
+ "If the process is privileged, all processes except for some special\n"
+ "system processes. Otherwise, all processes with the current effective\n"
+ "user ID.\n"
+ "@end table\n\n"
+ "@var{sig} should be specified using a variable corresponding to\n"
+ "the Unix symbolic name, e.g.,\n\n"
+ "@defvar SIGHUP\n"
+ "Hang-up signal.\n"
+ "@end defvar\n\n"
+ "@defvar SIGINT\n"
+ "Interrupt signal.\n"
+ "@end defvar")
+#define FUNC_NAME s_scm_kill
+{
+ SCM_VALIDATE_INUM (1, pid);
+ SCM_VALIDATE_INUM (2, sig);
+ /* Signal values are interned in scm_init_posix(). */
+#ifdef HAVE_KILL
+ if (kill ((int) SCM_INUM (pid), (int) SCM_INUM (sig)) != 0)
+#else
+ if ((int) SCM_INUM (pid) == getpid ())
+ if (raise ((int) SCM_INUM (sig)) != 0)
+#endif
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+#ifdef HAVE_WAITPID
+SCM_DEFINE (scm_waitpid, "waitpid", 1, 1, 0,
+ (SCM pid, SCM options),
+ "This procedure collects status information from a child process which\n"
+ "has terminated or (optionally) stopped. Normally it will\n"
+ "suspend the calling process until this can be done. If more than one\n"
+ "child process is eligible then one will be chosen by the operating system.\n\n"
+ "The value of @var{pid} determines the behaviour:\n\n"
+ "@table @r\n"
+ "@item @var{pid} greater than 0\n"
+ "Request status information from the specified child process.\n"
+ "@item @var{pid} equal to -1 or WAIT_ANY\n"
+ "Request status information for any child process.\n"
+ "@item @var{pid} equal to 0 or WAIT_MYPGRP\n"
+ "Request status information for any child process in the current process\n"
+ "group.\n"
+ "@item @var{pid} less than -1\n"
+ "Request status information for any child process whose process group ID\n"
+ "is -@var{PID}.\n"
+ "@end table\n\n"
+ "The @var{options} argument, if supplied, should be the bitwise OR of the\n"
+ "values of zero or more of the following variables:\n\n"
+ "@defvar WNOHANG\n"
+ "Return immediately even if there are no child processes to be collected.\n"
+ "@end defvar\n\n"
+ "@defvar WUNTRACED\n"
+ "Report status information for stopped processes as well as terminated\n"
+ "processes.\n"
+ "@end defvar\n\n"
+ "The return value is a pair containing:\n\n"
+ "@enumerate\n"
+ "@item\n"
+ "The process ID of the child process, or 0 if @code{WNOHANG} was\n"
+ "specified and no process was collected.\n"
+ "@item\n"
+ "The integer status value.\n"
+ "@end enumerate")
+#define FUNC_NAME s_scm_waitpid
+{
+ int i;
+ int status;
+ int ioptions;
+ SCM_VALIDATE_INUM (1, pid);
+ if (SCM_UNBNDP (options))
+ ioptions = 0;
+ else
+ {
+ SCM_VALIDATE_INUM (2, options);
+ /* Flags are interned in scm_init_posix. */
+ ioptions = SCM_INUM (options);
+ }
+ SCM_SYSCALL (i = waitpid (SCM_INUM (pid), &status, ioptions));
+ if (i == -1)
+ SCM_SYSERROR;
+ return scm_cons (SCM_MAKINUM (0L + i), SCM_MAKINUM (0L + status));
+}
+#undef FUNC_NAME
+#endif /* HAVE_WAITPID */
+
+#ifndef __MINGW32__
+SCM_DEFINE (scm_status_exit_val, "status:exit-val", 1, 0, 0,
+ (SCM status),
+ "Return the exit status value, as would be set if a process\n"
+ "ended normally through a call to @code{exit} or @code{_exit},\n"
+ "if any, otherwise @code{#f}.")
+#define FUNC_NAME s_scm_status_exit_val
+{
+ int lstatus;
+
+ SCM_VALIDATE_INUM (1, status);
+
+ /* On Ultrix, the WIF... macros assume their argument is an lvalue;
+ go figure. SCM_INUM does not yield an lvalue. */
+ lstatus = SCM_INUM (status);
+ if (WIFEXITED (lstatus))
+ return (SCM_MAKINUM (WEXITSTATUS (lstatus)));
+ else
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_status_term_sig, "status:term-sig", 1, 0, 0,
+ (SCM status),
+ "Return the signal number which terminated the process, if any,\n"
+ "otherwise @code{#f}.")
+#define FUNC_NAME s_scm_status_term_sig
+{
+ int lstatus;
+
+ SCM_VALIDATE_INUM (1, status);
+
+ lstatus = SCM_INUM (status);
+ if (WIFSIGNALED (lstatus))
+ return SCM_MAKINUM (WTERMSIG (lstatus));
+ else
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_status_stop_sig, "status:stop-sig", 1, 0, 0,
+ (SCM status),
+ "Return the signal number which stopped the process, if any,\n"
+ "otherwise @code{#f}.")
+#define FUNC_NAME s_scm_status_stop_sig
+{
+ int lstatus;
+
+ SCM_VALIDATE_INUM (1, status);
+
+ lstatus = SCM_INUM (status);
+ if (WIFSTOPPED (lstatus))
+ return SCM_MAKINUM (WSTOPSIG (lstatus));
+ else
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+#endif /* __MINGW32__ */
+
+#ifdef HAVE_GETPPID
+SCM_DEFINE (scm_getppid, "getppid", 0, 0, 0,
+ (),
+ "Return an integer representing the process ID of the parent\n"
+ "process.")
+#define FUNC_NAME s_scm_getppid
+{
+ return SCM_MAKINUM (0L + getppid ());
+}
+#undef FUNC_NAME
+#endif /* HAVE_GETPPID */
+
+
+#ifndef __MINGW32__
+SCM_DEFINE (scm_getuid, "getuid", 0, 0, 0,
+ (),
+ "Return an integer representing the current real user ID.")
+#define FUNC_NAME s_scm_getuid
+{
+ return SCM_MAKINUM (0L + getuid ());
+}
+#undef FUNC_NAME
+
+
+
+SCM_DEFINE (scm_getgid, "getgid", 0, 0, 0,
+ (),
+ "Return an integer representing the current real group ID.")
+#define FUNC_NAME s_scm_getgid
+{
+ return SCM_MAKINUM (0L + getgid ());
+}
+#undef FUNC_NAME
+
+
+
+SCM_DEFINE (scm_geteuid, "geteuid", 0, 0, 0,
+ (),
+ "Return an integer representing the current effective user ID.\n"
+ "If the system does not support effective IDs, then the real ID\n"
+ "is returned. @code{(feature? 'EIDs)} reports whether the\n"
+ "system supports effective IDs.")
+#define FUNC_NAME s_scm_geteuid
+{
+#ifdef HAVE_GETEUID
+ return SCM_MAKINUM (0L + geteuid ());
+#else
+ return SCM_MAKINUM (0L + getuid ());
+#endif
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_getegid, "getegid", 0, 0, 0,
+ (),
+ "Return an integer representing the current effective group ID.\n"
+ "If the system does not support effective IDs, then the real ID\n"
+ "is returned. @code{(feature? 'EIDs)} reports whether the\n"
+ "system supports effective IDs.")
+#define FUNC_NAME s_scm_getegid
+{
+#ifdef HAVE_GETEUID
+ return SCM_MAKINUM (0L + getegid ());
+#else
+ return SCM_MAKINUM (0L + getgid ());
+#endif
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_setuid, "setuid", 1, 0, 0,
+ (SCM id),
+ "Sets both the real and effective user IDs to the integer @var{id}, provided\n"
+ "the process has appropriate privileges.\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_setuid
+{
+ SCM_VALIDATE_INUM (1, id);
+ if (setuid (SCM_INUM (id)) != 0)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_setgid, "setgid", 1, 0, 0,
+ (SCM id),
+ "Sets both the real and effective group IDs to the integer @var{id}, provided\n"
+ "the process has appropriate privileges.\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_setgid
+{
+ SCM_VALIDATE_INUM (1, id);
+ if (setgid (SCM_INUM (id)) != 0)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_seteuid, "seteuid", 1, 0, 0,
+ (SCM id),
+ "Sets the effective user ID to the integer @var{id}, provided the process\n"
+ "has appropriate privileges. If effective IDs are not supported, the\n"
+ "real ID is set instead -- @code{(feature? 'EIDs)} reports whether the\n"
+ "system supports effective IDs.\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_seteuid
+{
+ int rv;
+
+ SCM_VALIDATE_INUM (1, id);
+#ifdef HAVE_SETEUID
+ rv = seteuid (SCM_INUM (id));
+#else
+ rv = setuid (SCM_INUM (id));
+#endif
+ if (rv != 0)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* __MINGW32__ */
+
+
+#ifdef HAVE_SETEGID
+SCM_DEFINE (scm_setegid, "setegid", 1, 0, 0,
+ (SCM id),
+ "Sets the effective group ID to the integer @var{id}, provided the process\n"
+ "has appropriate privileges. If effective IDs are not supported, the\n"
+ "real ID is set instead -- @code{(feature? 'EIDs)} reports whether the\n"
+ "system supports effective IDs.\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_setegid
+{
+ int rv;
+
+ SCM_VALIDATE_INUM (1, id);
+#ifdef HAVE_SETEUID
+ rv = setegid (SCM_INUM (id));
+#else
+ rv = setgid (SCM_INUM (id));
+#endif
+ if (rv != 0)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+
+}
+#undef FUNC_NAME
+#endif
+
+
+#ifdef HAVE_GETPGRP
+SCM_DEFINE (scm_getpgrp, "getpgrp", 0, 0, 0,
+ (),
+ "Return an integer representing the current process group ID.\n"
+ "This is the POSIX definition, not BSD.")
+#define FUNC_NAME s_scm_getpgrp
+{
+ int (*fn)();
+ fn = (int (*) ()) getpgrp;
+ return SCM_MAKINUM (fn (0));
+}
+#undef FUNC_NAME
+#endif /* HAVE_GETPGRP */
+
+
+#ifdef HAVE_SETPGID
+SCM_DEFINE (scm_setpgid, "setpgid", 2, 0, 0,
+ (SCM pid, SCM pgid),
+ "Move the process @var{pid} into the process group @var{pgid}. @var{pid} or\n"
+ "@var{pgid} must be integers: they can be zero to indicate the ID of the\n"
+ "current process.\n"
+ "Fails on systems that do not support job control.\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_setpgid
+{
+ SCM_VALIDATE_INUM (1, pid);
+ SCM_VALIDATE_INUM (2, pgid);
+ /* FIXME(?): may be known as setpgrp. */
+ if (setpgid (SCM_INUM (pid), SCM_INUM (pgid)) != 0)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* HAVE_SETPGID */
+
+#ifdef HAVE_SETSID
+SCM_DEFINE (scm_setsid, "setsid", 0, 0, 0,
+ (),
+ "Creates a new session. The current process becomes the session leader\n"
+ "and is put in a new process group. The process will be detached\n"
+ "from its controlling terminal if it has one.\n"
+ "The return value is an integer representing the new process group ID.")
+#define FUNC_NAME s_scm_setsid
+{
+ pid_t sid = setsid ();
+ if (sid == -1)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* HAVE_SETSID */
+
+#ifdef HAVE_TTYNAME
+SCM_DEFINE (scm_ttyname, "ttyname", 1, 0, 0,
+ (SCM port),
+ "Return a string with the name of the serial terminal device\n"
+ "underlying @var{port}.")
+#define FUNC_NAME s_scm_ttyname
+{
+ char *ans;
+ int fd;
+
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPPORT (1, port);
+ if (!SCM_FPORTP (port))
+ return SCM_BOOL_F;
+ fd = SCM_FPORT_FDES (port);
+ SCM_SYSCALL (ans = ttyname (fd));
+ if (!ans)
+ SCM_SYSERROR;
+ /* ans could be overwritten by another call to ttyname */
+ return (scm_makfrom0str (ans));
+}
+#undef FUNC_NAME
+#endif /* HAVE_TTYNAME */
+
+#ifdef HAVE_CTERMID
+SCM_DEFINE (scm_ctermid, "ctermid", 0, 0, 0,
+ (),
+ "Return a string containing the file name of the controlling\n"
+ "terminal for the current process.")
+#define FUNC_NAME s_scm_ctermid
+{
+ char *result = ctermid (NULL);
+ if (*result == '\0')
+ SCM_SYSERROR;
+ return scm_makfrom0str (result);
+}
+#undef FUNC_NAME
+#endif /* HAVE_CTERMID */
+
+#ifdef HAVE_TCGETPGRP
+SCM_DEFINE (scm_tcgetpgrp, "tcgetpgrp", 1, 0, 0,
+ (SCM port),
+ "Return the process group ID of the foreground process group\n"
+ "associated with the terminal open on the file descriptor\n"
+ "underlying @var{port}.\n"
+ "\n"
+ "If there is no foreground process group, the return value is a\n"
+ "number greater than 1 that does not match the process group ID\n"
+ "of any existing process group. This can happen if all of the\n"
+ "processes in the job that was formerly the foreground job have\n"
+ "terminated, and no other job has yet been moved into the\n"
+ "foreground.")
+#define FUNC_NAME s_scm_tcgetpgrp
+{
+ int fd;
+ pid_t pgid;
+
+ port = SCM_COERCE_OUTPORT (port);
+
+ SCM_VALIDATE_OPFPORT (1, port);
+ fd = SCM_FPORT_FDES (port);
+ if ((pgid = tcgetpgrp (fd)) == -1)
+ SCM_SYSERROR;
+ return SCM_MAKINUM (pgid);
+}
+#undef FUNC_NAME
+#endif /* HAVE_TCGETPGRP */
+
+#ifdef HAVE_TCSETPGRP
+SCM_DEFINE (scm_tcsetpgrp, "tcsetpgrp", 2, 0, 0,
+ (SCM port, SCM pgid),
+ "Set the foreground process group ID for the terminal used by the file\n"
+ "descriptor underlying @var{port} to the integer @var{pgid}.\n"
+ "The calling process\n"
+ "must be a member of the same session as @var{pgid} and must have the same\n"
+ "controlling terminal. The return value is unspecified.")
+#define FUNC_NAME s_scm_tcsetpgrp
+{
+ int fd;
+
+ port = SCM_COERCE_OUTPORT (port);
+
+ SCM_VALIDATE_OPFPORT (1, port);
+ SCM_VALIDATE_INUM (2, pgid);
+ fd = SCM_FPORT_FDES (port);
+ if (tcsetpgrp (fd, SCM_INUM (pgid)) == -1)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* HAVE_TCSETPGRP */
+
+/* return a newly allocated array of char pointers to each of the strings
+ in args, with a terminating NULL pointer. */
+/* Note: a similar function is defined in dynl.c, but we don't necessarily
+ want to export it. */
+static char **allocate_string_pointers (SCM args)
+{
+ char **result;
+ int n_args = scm_ilength (args);
+ int i;
+
+ SCM_ASSERT (n_args >= 0, args, SCM_ARGn, "allocate_string_pointers");
+ result = (char **) scm_malloc ((n_args + 1) * sizeof (char *));
+ result[n_args] = NULL;
+ for (i = 0; i < n_args; i++)
+ {
+ SCM car = SCM_CAR (args);
+
+ if (!SCM_STRINGP (car))
+ {
+ free (result);
+ scm_wrong_type_arg ("allocate_string_pointers", SCM_ARGn, car);
+ }
+ result[i] = SCM_STRING_CHARS (SCM_CAR (args));
+ args = SCM_CDR (args);
+ }
+ return result;
+}
+
+SCM_DEFINE (scm_execl, "execl", 1, 0, 1,
+ (SCM filename, SCM args),
+ "Executes the file named by @var{path} as a new process image.\n"
+ "The remaining arguments are supplied to the process; from a C program\n"
+ "they are accessible as the @code{argv} argument to @code{main}.\n"
+ "Conventionally the first @var{arg} is the same as @var{path}.\n"
+ "All arguments must be strings.\n\n"
+ "If @var{arg} is missing, @var{path} is executed with a null\n"
+ "argument list, which may have system-dependent side-effects.\n\n"
+ "This procedure is currently implemented using the @code{execv} system\n"
+ "call, but we call it @code{execl} because of its Scheme calling interface.")
+#define FUNC_NAME s_scm_execl
+{
+ char **execargv;
+ SCM_VALIDATE_STRING (1, filename);
+ execargv = allocate_string_pointers (args);
+ execv (SCM_STRING_CHARS (filename), execargv);
+ SCM_SYSERROR;
+ /* not reached. */
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_execlp, "execlp", 1, 0, 1,
+ (SCM filename, SCM args),
+ "Similar to @code{execl}, however if\n"
+ "@var{filename} does not contain a slash\n"
+ "then the file to execute will be located by searching the\n"
+ "directories listed in the @code{PATH} environment variable.\n\n"
+ "This procedure is currently implemented using the @code{execvp} system\n"
+ "call, but we call it @code{execlp} because of its Scheme calling interface.")
+#define FUNC_NAME s_scm_execlp
+{
+ char **execargv;
+ SCM_VALIDATE_STRING (1, filename);
+ execargv = allocate_string_pointers (args);
+ execvp (SCM_STRING_CHARS (filename), execargv);
+ SCM_SYSERROR;
+ /* not reached. */
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+static char **
+environ_list_to_c (SCM envlist, int arg, const char *proc)
+{
+ int num_strings;
+ char **result;
+ int i;
+
+ num_strings = scm_ilength (envlist);
+ SCM_ASSERT (num_strings >= 0, envlist, arg, proc);
+ result = (char **) malloc ((num_strings + 1) * sizeof (char *));
+ if (result == NULL)
+ scm_memory_error (proc);
+ for (i = 0; !SCM_NULL_OR_NIL_P (envlist); ++i, envlist = SCM_CDR (envlist))
+ {
+ SCM str = SCM_CAR (envlist);
+ int len;
+ char *src;
+
+ SCM_ASSERT (SCM_STRINGP (str), envlist, arg, proc);
+ len = SCM_STRING_LENGTH (str);
+ src = SCM_STRING_CHARS (str);
+ result[i] = malloc (len + 1);
+ if (result[i] == NULL)
+ scm_memory_error (proc);
+ memcpy (result[i], src, len);
+ result[i][len] = 0;
+ }
+ result[i] = 0;
+ return result;
+}
+
+SCM_DEFINE (scm_execle, "execle", 2, 0, 1,
+ (SCM filename, SCM env, SCM args),
+ "Similar to @code{execl}, but the environment of the new process is\n"
+ "specified by @var{env}, which must be a list of strings as returned by the\n"
+ "@code{environ} procedure.\n\n"
+ "This procedure is currently implemented using the @code{execve} system\n"
+ "call, but we call it @code{execle} because of its Scheme calling interface.")
+#define FUNC_NAME s_scm_execle
+{
+ char **execargv;
+ char **exec_env;
+
+ SCM_VALIDATE_STRING (1, filename);
+
+ execargv = allocate_string_pointers (args);
+ exec_env = environ_list_to_c (env, SCM_ARG2, FUNC_NAME);
+ execve (SCM_STRING_CHARS (filename), execargv, exec_env);
+ SCM_SYSERROR;
+ /* not reached. */
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+#ifdef HAVE_FORK
+SCM_DEFINE (scm_fork, "primitive-fork", 0, 0, 0,
+ (),
+ "Creates a new \"child\" process by duplicating the current \"parent\" process.\n"
+ "In the child the return value is 0. In the parent the return value is\n"
+ "the integer process ID of the child.\n\n"
+ "This procedure has been renamed from @code{fork} to avoid a naming conflict\n"
+ "with the scsh fork.")
+#define FUNC_NAME s_scm_fork
+{
+ int pid;
+ pid = fork ();
+ if (pid == -1)
+ SCM_SYSERROR;
+ return SCM_MAKINUM (0L+pid);
+}
+#undef FUNC_NAME
+#endif /* HAVE_FORK */
+
+#ifdef __MINGW32__
+# include "win32-uname.h"
+#endif
+
+#if defined (HAVE_UNAME) || defined (__MINGW32__)
+SCM_DEFINE (scm_uname, "uname", 0, 0, 0,
+ (),
+ "Return an object with some information about the computer\n"
+ "system the program is running on.")
+#define FUNC_NAME s_scm_uname
+{
+ struct utsname buf;
+ SCM ans = scm_c_make_vector (5, SCM_UNSPECIFIED);
+ if (uname (&buf) < 0)
+ SCM_SYSERROR;
+ SCM_VECTOR_SET(ans, 0, scm_makfrom0str (buf.sysname));
+ SCM_VECTOR_SET(ans, 1, scm_makfrom0str (buf.nodename));
+ SCM_VECTOR_SET(ans, 2, scm_makfrom0str (buf.release));
+ SCM_VECTOR_SET(ans, 3, scm_makfrom0str (buf.version));
+ SCM_VECTOR_SET(ans, 4, scm_makfrom0str (buf.machine));
+/*
+ a linux special?
+ SCM_VECTOR_SET(ans, 5, scm_makfrom0str (buf.domainname));
+*/
+ return ans;
+}
+#undef FUNC_NAME
+#endif /* HAVE_UNAME */
+
+SCM_DEFINE (scm_environ, "environ", 0, 1, 0,
+ (SCM env),
+ "If @var{env} is omitted, return the current environment (in the\n"
+ "Unix sense) as a list of strings. Otherwise set the current\n"
+ "environment, which is also the default environment for child\n"
+ "processes, to the supplied list of strings. Each member of\n"
+ "@var{env} should be of the form @code{NAME=VALUE} and values of\n"
+ "@code{NAME} should not be duplicated. If @var{env} is supplied\n"
+ "then the return value is unspecified.")
+#define FUNC_NAME s_scm_environ
+{
+ if (SCM_UNBNDP (env))
+ return scm_makfromstrs (-1, environ);
+ else
+ {
+ char **new_environ;
+
+ new_environ = environ_list_to_c (env, SCM_ARG1, FUNC_NAME);
+ /* Free the old environment, except when called for the first
+ * time.
+ */
+ {
+ char **ep;
+ static int first = 1;
+ if (!first)
+ {
+ for (ep = environ; *ep != NULL; ep++)
+ free (*ep);
+ free ((char *) environ);
+ }
+ first = 0;
+ }
+ environ = new_environ;
+ return SCM_UNSPECIFIED;
+ }
+}
+#undef FUNC_NAME
+
+#ifdef L_tmpnam
+
+SCM_DEFINE (scm_tmpnam, "tmpnam", 0, 0, 0,
+ (),
+ "Return a name in the file system that does not match any\n"
+ "existing file. However there is no guarantee that another\n"
+ "process will not create the file after @code{tmpnam} is called.\n"
+ "Care should be taken if opening the file, e.g., use the\n"
+ "@code{O_EXCL} open flag or use @code{mkstemp!} instead.")
+#define FUNC_NAME s_scm_tmpnam
+{
+ char name[L_tmpnam];
+ char *rv;
+
+ SCM_SYSCALL (rv = tmpnam (name));
+ if (rv == NULL)
+ /* not SCM_SYSERROR since errno probably not set. */
+ SCM_MISC_ERROR ("tmpnam failed", SCM_EOL);
+ return scm_makfrom0str (name);
+}
+#undef FUNC_NAME
+
+#endif
+
+#ifndef HAVE_MKSTEMP
+extern int mkstemp (char *);
+#endif
+
+SCM_DEFINE (scm_mkstemp, "mkstemp!", 1, 0, 0,
+ (SCM tmpl),
+ "Create a new unique file in the file system and returns a new\n"
+ "buffered port open for reading and writing to the file.\n"
+ "@var{tmpl} is a string specifying where the file should be\n"
+ "created: it must end with @code{XXXXXX} and will be changed in\n"
+ "place to return the name of the temporary file.")
+#define FUNC_NAME s_scm_mkstemp
+{
+ char *c_tmpl;
+ int rv;
+
+ SCM_VALIDATE_STRING_COPY (1, tmpl, c_tmpl);
+ SCM_SYSCALL (rv = mkstemp (c_tmpl));
+ if (rv == -1)
+ SCM_SYSERROR;
+ return scm_fdes_to_port (rv, "w+", tmpl);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_utime, "utime", 1, 2, 0,
+ (SCM pathname, SCM actime, SCM modtime),
+ "@code{utime} sets the access and modification times for the\n"
+ "file named by @var{path}. If @var{actime} or @var{modtime} is\n"
+ "not supplied, then the current time is used. @var{actime} and\n"
+ "@var{modtime} must be integer time values as returned by the\n"
+ "@code{current-time} procedure.\n"
+ "@lisp\n"
+ "(utime \"foo\" (- (current-time) 3600))\n"
+ "@end lisp\n"
+ "will set the access time to one hour in the past and the\n"
+ "modification time to the current time.")
+#define FUNC_NAME s_scm_utime
+{
+ int rv;
+ struct utimbuf utm_tmp;
+
+ SCM_VALIDATE_STRING (1, pathname);
+ if (SCM_UNBNDP (actime))
+ SCM_SYSCALL (time (&utm_tmp.actime));
+ else
+ utm_tmp.actime = SCM_NUM2ULONG (2, actime);
+
+ if (SCM_UNBNDP (modtime))
+ SCM_SYSCALL (time (&utm_tmp.modtime));
+ else
+ utm_tmp.modtime = SCM_NUM2ULONG (3, modtime);
+
+ SCM_SYSCALL (rv = utime (SCM_STRING_CHARS (pathname), &utm_tmp));
+ if (rv != 0)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_access, "access?", 2, 0, 0,
+ (SCM path, SCM how),
+ "Return @code{#t} if @var{path} corresponds to an existing file\n"
+ "and the current process has the type of access specified by\n"
+ "@var{how}, otherwise @code{#f}. @var{how} should be specified\n"
+ "using the values of the variables listed below. Multiple\n"
+ "values can be combined using a bitwise or, in which case\n"
+ "@code{#t} will only be returned if all accesses are granted.\n"
+ "\n"
+ "Permissions are checked using the real id of the current\n"
+ "process, not the effective id, although it's the effective id\n"
+ "which determines whether the access would actually be granted.\n"
+ "\n"
+ "@defvar R_OK\n"
+ "test for read permission.\n"
+ "@end defvar\n"
+ "@defvar W_OK\n"
+ "test for write permission.\n"
+ "@end defvar\n"
+ "@defvar X_OK\n"
+ "test for execute permission.\n"
+ "@end defvar\n"
+ "@defvar F_OK\n"
+ "test for existence of the file.\n"
+ "@end defvar")
+#define FUNC_NAME s_scm_access
+{
+ int rv;
+
+ SCM_VALIDATE_STRING (1, path);
+ SCM_VALIDATE_INUM (2, how);
+ rv = access (SCM_STRING_CHARS (path), SCM_INUM (how));
+ return SCM_NEGATE_BOOL(rv);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_getpid, "getpid", 0, 0, 0,
+ (),
+ "Return an integer representing the current process ID.")
+#define FUNC_NAME s_scm_getpid
+{
+ return SCM_MAKINUM ((unsigned long) getpid ());
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0,
+ (SCM str),
+ "Modifies the environment of the current process, which is\n"
+ "also the default environment inherited by child processes.\n\n"
+ "If @var{string} is of the form @code{NAME=VALUE} then it will be written\n"
+ "directly into the environment, replacing any existing environment string\n"
+ "with\n"
+ "name matching @code{NAME}. If @var{string} does not contain an equal\n"
+ "sign, then any existing string with name matching @var{string} will\n"
+ "be removed.\n\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_putenv
+{
+ int rv;
+ char *ptr;
+
+ SCM_VALIDATE_STRING (1, str);
+
+ if (strchr (SCM_STRING_CHARS (str), '=') == NULL)
+ {
+ /* No '=' in argument means we should remove the variable from
+ the environment. Not all putenvs understand this. To be
+ safe, we do it explicitely using unsetenv. */
+ unsetenv (SCM_STRING_CHARS (str));
+ }
+ else
+ {
+ /* must make a new copy to be left in the environment, safe from gc. */
+ ptr = malloc (SCM_STRING_LENGTH (str) + 1);
+ if (ptr == NULL)
+ SCM_MEMORY_ERROR;
+ strncpy (ptr, SCM_STRING_CHARS (str), SCM_STRING_LENGTH (str));
+ ptr[SCM_STRING_LENGTH (str)] = 0;
+ rv = putenv (ptr);
+ if (rv < 0)
+ SCM_SYSERROR;
+ }
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+#ifdef HAVE_SETLOCALE
+SCM_DEFINE (scm_setlocale, "setlocale", 1, 1, 0,
+ (SCM category, SCM locale),
+ "If @var{locale} is omitted, return the current value of the\n"
+ "specified locale category as a system-dependent string.\n"
+ "@var{category} should be specified using the values\n"
+ "@code{LC_COLLATE}, @code{LC_ALL} etc.\n"
+ "\n"
+ "Otherwise the specified locale category is set to the string\n"
+ "@var{locale} and the new value is returned as a\n"
+ "system-dependent string. If @var{locale} is an empty string,\n"
+ "the locale will be set using environment variables.")
+#define FUNC_NAME s_scm_setlocale
+{
+ char *clocale;
+ char *rv;
+
+ SCM_VALIDATE_INUM (1, category);
+ if (SCM_UNBNDP (locale))
+ {
+ clocale = NULL;
+ }
+ else
+ {
+ SCM_VALIDATE_STRING (2, locale);
+ clocale = SCM_STRING_CHARS (locale);
+ }
+
+ rv = setlocale (SCM_INUM (category), clocale);
+ if (rv == NULL)
+ SCM_SYSERROR;
+ return scm_makfrom0str (rv);
+}
+#undef FUNC_NAME
+#endif /* HAVE_SETLOCALE */
+
+#ifdef HAVE_MKNOD
+SCM_DEFINE (scm_mknod, "mknod", 4, 0, 0,
+ (SCM path, SCM type, SCM perms, SCM dev),
+ "Creates a new special file, such as a file corresponding to a device.\n"
+ "@var{path} specifies the name of the file. @var{type} should\n"
+ "be one of the following symbols:\n"
+ "regular, directory, symlink, block-special, char-special,\n"
+ "fifo, or socket. @var{perms} (an integer) specifies the file permissions.\n"
+ "@var{dev} (an integer) specifies which device the special file refers\n"
+ "to. Its exact interpretation depends on the kind of special file\n"
+ "being created.\n\n"
+ "E.g.,\n"
+ "@lisp\n"
+ "(mknod \"/dev/fd0\" 'block-special #o660 (+ (* 2 256) 2))\n"
+ "@end lisp\n\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_mknod
+{
+ int val;
+ char *p;
+ int ctype = 0;
+
+ SCM_VALIDATE_STRING (1, path);
+ SCM_VALIDATE_SYMBOL (2, type);
+ SCM_VALIDATE_INUM (3, perms);
+ SCM_VALIDATE_INUM (4, dev);
+
+ p = SCM_SYMBOL_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;
+#ifdef S_IFSOCK
+ else if (strcmp (p, "socket") == 0)
+ ctype = S_IFSOCK;
+#endif
+ else
+ SCM_OUT_OF_RANGE (2, type);
+
+ SCM_SYSCALL (val = mknod (SCM_STRING_CHARS (path), ctype | SCM_INUM (perms),
+ SCM_INUM (dev)));
+ if (val != 0)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* HAVE_MKNOD */
+
+#ifdef HAVE_NICE
+SCM_DEFINE (scm_nice, "nice", 1, 0, 0,
+ (SCM incr),
+ "Increment the priority of the current process by @var{incr}. A higher\n"
+ "priority value means that the process runs less often.\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_nice
+{
+ SCM_VALIDATE_INUM (1, incr);
+ if (nice(SCM_INUM(incr)) != 0)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* HAVE_NICE */
+
+#ifdef HAVE_SYNC
+SCM_DEFINE (scm_sync, "sync", 0, 0, 0,
+ (),
+ "Flush the operating system disk buffers.\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_sync
+{
+ sync();
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* HAVE_SYNC */
+
+#if HAVE_LIBCRYPT && HAVE_CRYPT_H
+SCM_DEFINE (scm_crypt, "crypt", 2, 0, 0,
+ (SCM key, SCM salt),
+ "Encrypt @var{key} using @var{salt} as the salt value to the\n"
+ "crypt(3) library call.")
+#define FUNC_NAME s_scm_crypt
+{
+ char * p;
+
+ SCM_VALIDATE_STRING (1, key);
+ SCM_VALIDATE_STRING (2, salt);
+
+ p = crypt (SCM_STRING_CHARS (key), SCM_STRING_CHARS (salt));
+ return scm_makfrom0str (p);
+}
+#undef FUNC_NAME
+#endif /* HAVE_LIBCRYPT && HAVE_CRYPT_H */
+
+#if HAVE_CHROOT
+SCM_DEFINE (scm_chroot, "chroot", 1, 0, 0,
+ (SCM path),
+ "Change the root directory to that specified in @var{path}.\n"
+ "This directory will be used for path names beginning with\n"
+ "@file{/}. The root directory is inherited by all children\n"
+ "of the current process. Only the superuser may change the\n"
+ "root directory.")
+#define FUNC_NAME s_scm_chroot
+{
+ SCM_VALIDATE_STRING (1, path);
+
+ if (chroot (SCM_STRING_CHARS (path)) == -1)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* HAVE_CHROOT */
+
+
+#ifdef __MINGW32__
+/* Wrapper function to supplying `getlogin()' under Windows. */
+static char * getlogin (void)
+{
+ static char user[256];
+ static unsigned long len = 256;
+
+ if (!GetUserName (user, &len))
+ return NULL;
+ return user;
+}
+#endif /* __MINGW32__ */
+
+
+#if defined (HAVE_GETLOGIN) || defined (__MINGW32__)
+SCM_DEFINE (scm_getlogin, "getlogin", 0, 0, 0,
+ (void),
+ "Return a string containing the name of the user logged in on\n"
+ "the controlling terminal of the process, or @code{#f} if this\n"
+ "information cannot be obtained.")
+#define FUNC_NAME s_scm_getlogin
+{
+ char * p;
+
+ p = getlogin ();
+ if (!p || !*p)
+ return SCM_BOOL_F;
+ return scm_makfrom0str (p);
+}
+#undef FUNC_NAME
+#endif /* HAVE_GETLOGIN */
+
+#if HAVE_CUSERID
+SCM_DEFINE (scm_cuserid, "cuserid", 0, 0, 0,
+ (void),
+ "Return a string containing a user name associated with the\n"
+ "effective user id of the process. Return @code{#f} if this\n"
+ "information cannot be obtained.")
+#define FUNC_NAME s_scm_cuserid
+{
+ char * p;
+
+ p = cuserid (NULL);
+ if (!p || !*p)
+ return SCM_BOOL_F;
+ return scm_makfrom0str (p);
+}
+#undef FUNC_NAME
+#endif /* HAVE_CUSERID */
+
+#if HAVE_GETPRIORITY
+SCM_DEFINE (scm_getpriority, "getpriority", 2, 0, 0,
+ (SCM which, SCM who),
+ "Return the scheduling priority of the process, process group\n"
+ "or user, as indicated by @var{which} and @var{who}. @var{which}\n"
+ "is one of the variables @code{PRIO_PROCESS}, @code{PRIO_PGRP}\n"
+ "or @code{PRIO_USER}, and @var{who} is interpreted relative to\n"
+ "@var{which} (a process identifier for @code{PRIO_PROCESS},\n"
+ "process group identifier for @code{PRIO_PGRP}, and a user\n"
+ "identifier for @code{PRIO_USER}. A zero value of @var{who}\n"
+ "denotes the current process, process group, or user. Return\n"
+ "the highest priority (lowest numerical value) of any of the\n"
+ "specified processes.")
+#define FUNC_NAME s_scm_getpriority
+{
+ int cwhich, cwho, ret;
+
+ SCM_VALIDATE_INUM_COPY (1, which, cwhich);
+ SCM_VALIDATE_INUM_COPY (2, who, cwho);
+
+ /* We have to clear errno and examine it later, because -1 is a
+ legal return value for getpriority(). */
+ errno = 0;
+ ret = getpriority (cwhich, cwho);
+ if (errno != 0)
+ SCM_SYSERROR;
+ return SCM_MAKINUM (ret);
+}
+#undef FUNC_NAME
+#endif /* HAVE_GETPRIORITY */
+
+#if HAVE_SETPRIORITY
+SCM_DEFINE (scm_setpriority, "setpriority", 3, 0, 0,
+ (SCM which, SCM who, SCM prio),
+ "Set the scheduling priority of the process, process group\n"
+ "or user, as indicated by @var{which} and @var{who}. @var{which}\n"
+ "is one of the variables @code{PRIO_PROCESS}, @code{PRIO_PGRP}\n"
+ "or @code{PRIO_USER}, and @var{who} is interpreted relative to\n"
+ "@var{which} (a process identifier for @code{PRIO_PROCESS},\n"
+ "process group identifier for @code{PRIO_PGRP}, and a user\n"
+ "identifier for @code{PRIO_USER}. A zero value of @var{who}\n"
+ "denotes the current process, process group, or user.\n"
+ "@var{prio} is a value in the range -20 and 20, the default\n"
+ "priority is 0; lower priorities cause more favorable\n"
+ "scheduling. Sets the priority of all of the specified\n"
+ "processes. Only the super-user may lower priorities.\n"
+ "The return value is not specified.")
+#define FUNC_NAME s_scm_setpriority
+{
+ int cwhich, cwho, cprio;
+
+ SCM_VALIDATE_INUM_COPY (1, which, cwhich);
+ SCM_VALIDATE_INUM_COPY (2, who, cwho);
+ SCM_VALIDATE_INUM_COPY (3, prio, cprio);
+
+ if (setpriority (cwhich, cwho, cprio) == -1)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* HAVE_SETPRIORITY */
+
+#if HAVE_GETPASS
+SCM_DEFINE (scm_getpass, "getpass", 1, 0, 0,
+ (SCM prompt),
+ "Display @var{prompt} to the standard error output and read\n"
+ "a password from @file{/dev/tty}. If this file is not\n"
+ "accessible, it reads from standard input. The password may be\n"
+ "up to 127 characters in length. Additional characters and the\n"
+ "terminating newline character are discarded. While reading\n"
+ "the password, echoing and the generation of signals by special\n"
+ "characters is disabled.")
+#define FUNC_NAME s_scm_getpass
+{
+ char * p;
+ SCM passwd;
+
+ SCM_VALIDATE_STRING (1, prompt);
+
+ p = getpass(SCM_STRING_CHARS (prompt));
+ passwd = scm_makfrom0str (p);
+
+ /* Clear out the password in the static buffer. */
+ memset (p, 0, strlen (p));
+
+ return passwd;
+}
+#undef FUNC_NAME
+#endif /* HAVE_GETPASS */
+
+/* Wrapper function for flock() support under M$-Windows. */
+#ifdef __MINGW32__
+# include <io.h>
+# include <sys/locking.h>
+# include <errno.h>
+# ifndef _LK_UNLCK
+ /* Current MinGW package fails to define this. *sigh* */
+# define _LK_UNLCK 0
+# endif
+# define LOCK_EX 1
+# define LOCK_UN 2
+# define LOCK_SH 4
+# define LOCK_NB 8
+
+static int flock (int fd, int operation)
+{
+ long pos, len;
+ int ret, err;
+
+ /* Disable invalid arguments. */
+ if (((operation & (LOCK_EX | LOCK_SH)) == (LOCK_EX | LOCK_SH)) ||
+ ((operation & (LOCK_EX | LOCK_UN)) == (LOCK_EX | LOCK_UN)) ||
+ ((operation & (LOCK_SH | LOCK_UN)) == (LOCK_SH | LOCK_UN)))
+ {
+ errno = EINVAL;
+ return -1;
+ }
+
+ /* Determine mode of operation and discard unsupported ones. */
+ if (operation == (LOCK_NB | LOCK_EX))
+ operation = _LK_NBLCK;
+ else if (operation & LOCK_UN)
+ operation = _LK_UNLCK;
+ else if (operation == LOCK_EX)
+ operation = _LK_LOCK;
+ else
+ {
+ errno = EINVAL;
+ return -1;
+ }
+
+ /* Save current file pointer and seek to beginning. */
+ if ((pos = lseek (fd, 0, SEEK_CUR)) == -1 || (len = filelength (fd)) == -1)
+ return -1;
+ lseek (fd, 0L, SEEK_SET);
+
+ /* Deadlock if necessary. */
+ do
+ {
+ ret = _locking (fd, operation, len);
+ }
+ while (ret == -1 && errno == EDEADLOCK);
+
+ /* Produce meaningful error message. */
+ if (errno == EACCES && operation == _LK_NBLCK)
+ err = EDEADLOCK;
+ else
+ err = errno;
+
+ /* Return to saved file position pointer. */
+ lseek (fd, pos, SEEK_SET);
+ errno = err;
+ return ret;
+}
+#endif /* __MINGW32__ */
+
+#if HAVE_FLOCK || defined (__MINGW32__)
+SCM_DEFINE (scm_flock, "flock", 2, 0, 0,
+ (SCM file, SCM operation),
+ "Apply or remove an advisory lock on an open file.\n"
+ "@var{operation} specifies the action to be done:\n"
+ "@table @code\n"
+ "@item LOCK_SH\n"
+ "Shared lock. More than one process may hold a shared lock\n"
+ "for a given file at a given time.\n"
+ "@item LOCK_EX\n"
+ "Exclusive lock. Only one process may hold an exclusive lock\n"
+ "for a given file at a given time.\n"
+ "@item LOCK_UN\n"
+ "Unlock the file.\n"
+ "@item LOCK_NB\n"
+ "Don't block when locking. May be specified by bitwise OR'ing\n"
+ "it to one of the other operations.\n"
+ "@end table\n"
+ "The return value is not specified. @var{file} may be an open\n"
+ "file descriptor or an open file descriptor port.")
+#define FUNC_NAME s_scm_flock
+{
+ int coperation, fdes;
+
+ if (SCM_INUMP (file))
+ fdes = SCM_INUM (file);
+ else
+ {
+ SCM_VALIDATE_OPFPORT (2, file);
+
+ fdes = SCM_FPORT_FDES (file);
+ }
+ SCM_VALIDATE_INUM_COPY (2, operation, coperation);
+ if (flock (fdes, coperation) == -1)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* HAVE_FLOCK */
+
+#if HAVE_SETHOSTNAME
+SCM_DEFINE (scm_sethostname, "sethostname", 1, 0, 0,
+ (SCM name),
+ "Set the host name of the current processor to @var{name}. May\n"
+ "only be used by the superuser. The return value is not\n"
+ "specified.")
+#define FUNC_NAME s_scm_sethostname
+{
+ SCM_VALIDATE_STRING (1, name);
+
+ if (sethostname (SCM_STRING_CHARS (name), SCM_STRING_LENGTH (name)) == -1)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* HAVE_SETHOSTNAME */
+
+#if HAVE_GETHOSTNAME
+SCM_DEFINE (scm_gethostname, "gethostname", 0, 0, 0,
+ (void),
+ "Return the host name of the current processor.")
+#define FUNC_NAME s_scm_gethostname
+{
+ /* 256 is for Solaris, under Linux ENAMETOOLONG is returned if not
+ large enough. */
+ int len = 256, res;
+ char *p = scm_malloc (len);
+ SCM name;
+
+ res = gethostname (p, len);
+ while (res == -1 && errno == ENAMETOOLONG)
+ {
+ p = scm_realloc (p, len * 2);
+ len *= 2;
+ res = gethostname (p, len);
+ }
+ if (res == -1)
+ {
+ free (p);
+ SCM_SYSERROR;
+ }
+ name = scm_makfrom0str (p);
+ free (p);
+ return name;
+}
+#undef FUNC_NAME
+#endif /* HAVE_GETHOSTNAME */
+
+void
+scm_init_posix ()
+{
+ scm_add_feature ("posix");
+#ifdef HAVE_GETEUID
+ scm_add_feature ("EIDs");
+#endif
+#ifdef WAIT_ANY
+ scm_c_define ("WAIT_ANY", SCM_MAKINUM (WAIT_ANY));
+#endif
+#ifdef WAIT_MYPGRP
+ scm_c_define ("WAIT_MYPGRP", SCM_MAKINUM (WAIT_MYPGRP));
+#endif
+#ifdef WNOHANG
+ scm_c_define ("WNOHANG", SCM_MAKINUM (WNOHANG));
+#endif
+#ifdef WUNTRACED
+ scm_c_define ("WUNTRACED", SCM_MAKINUM (WUNTRACED));
+#endif
+
+ /* access() symbols. */
+ scm_c_define ("R_OK", SCM_MAKINUM (R_OK));
+ scm_c_define ("W_OK", SCM_MAKINUM (W_OK));
+ scm_c_define ("X_OK", SCM_MAKINUM (X_OK));
+ scm_c_define ("F_OK", SCM_MAKINUM (F_OK));
+
+#ifdef LC_COLLATE
+ scm_c_define ("LC_COLLATE", SCM_MAKINUM (LC_COLLATE));
+#endif
+#ifdef LC_CTYPE
+ scm_c_define ("LC_CTYPE", SCM_MAKINUM (LC_CTYPE));
+#endif
+#ifdef LC_MONETARY
+ scm_c_define ("LC_MONETARY", SCM_MAKINUM (LC_MONETARY));
+#endif
+#ifdef LC_NUMERIC
+ scm_c_define ("LC_NUMERIC", SCM_MAKINUM (LC_NUMERIC));
+#endif
+#ifdef LC_TIME
+ scm_c_define ("LC_TIME", SCM_MAKINUM (LC_TIME));
+#endif
+#ifdef LC_MESSAGES
+ scm_c_define ("LC_MESSAGES", SCM_MAKINUM (LC_MESSAGES));
+#endif
+#ifdef LC_ALL
+ scm_c_define ("LC_ALL", SCM_MAKINUM (LC_ALL));
+#endif
+#ifdef PIPE_BUF
+ scm_c_define ("PIPE_BUF", scm_long2num (PIPE_BUF));
+#endif
+
+#ifdef PRIO_PROCESS
+ scm_c_define ("PRIO_PROCESS", SCM_MAKINUM (PRIO_PROCESS));
+#endif
+#ifdef PRIO_PGRP
+ scm_c_define ("PRIO_PGRP", SCM_MAKINUM (PRIO_PGRP));
+#endif
+#ifdef PRIO_USER
+ scm_c_define ("PRIO_USER", SCM_MAKINUM (PRIO_USER));
+#endif
+
+#ifdef LOCK_SH
+ scm_c_define ("LOCK_SH", SCM_MAKINUM (LOCK_SH));
+#endif
+#ifdef LOCK_EX
+ scm_c_define ("LOCK_EX", SCM_MAKINUM (LOCK_EX));
+#endif
+#ifdef LOCK_UN
+ scm_c_define ("LOCK_UN", SCM_MAKINUM (LOCK_UN));
+#endif
+#ifdef LOCK_NB
+ scm_c_define ("LOCK_NB", SCM_MAKINUM (LOCK_NB));
+#endif
+
+#include "libguile/cpp_sig_symbols.c"
+#include "libguile/posix.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
HCoop / bpt / guile.git / blobdiff