guile/libguile/posix.c

/*	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
 * 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.  
 */


#include <stdio.h>
#include "_scm.h"
#include "fports.h"
#include "scmsigs.h"
#include "feature.h"
#include "sequences.h"

#include "posix.h"


#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

#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.  */




SCM_PROC (s_pipe, "pipe", 0, 0, 0, scm_pipe);

SCM 
scm_pipe ()
{
  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_pipe);
  f_rd = fdopen (fd[0], "r");
  if (!f_rd)
    {
      SCM_SYSCALL (close (fd[0]));
      SCM_SYSCALL (close (fd[1]));
      scm_syserror (s_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_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_SETCAR (p_rd, scm_tc16_fport | scm_mode_bits ("r"));
  SCM_SETCAR (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_getgroups, "getgroups", 0, 0, 0, scm_getgroups);

SCM
scm_getgroups()
{
  SCM grps, ans;
  int ngroups = getgroups (0, NULL);
  if (!ngroups)
    scm_syserror (s_getgroups);
  SCM_NEWCELL(grps);
  SCM_DEFER_INTS;
  {
    GETGROUPS_T *groups;
    int val;

    groups = (GETGROUPS_T *) scm_must_malloc(ngroups * sizeof(GETGROUPS_T),
					     s_getgroups);
    val = getgroups(ngroups, groups);
    if (val < 0)
      {
	scm_must_free((char *)groups);
	scm_syserror (s_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_getpwuid, "getpw", 0, 1, 0, scm_getpwuid);

SCM 
scm_getpwuid (user)
     SCM user;
{
  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_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_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);

SCM 
scm_setpwent (arg)
     SCM arg;
{
  if (SCM_UNBNDP (arg) || SCM_FALSEP (arg))
    endpwent ();
  else
    setpwent ();
  return SCM_UNSPECIFIED;
}



/* Combines getgrgid and getgrnam.  */
SCM_PROC (s_getgrgid, "getgr", 0, 1, 0, scm_getgrgid);

SCM 
scm_getgrgid (name)
     SCM name;
{
  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_ROSTRINGP (name), name, SCM_ARG1,
		  s_getgrgid);
      SCM_SYSCALL (entry = getgrnam (SCM_ROCHARS (name)));
    }
  if (!entry)
    scm_syserror (s_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);

SCM 
scm_setgrent (arg)
     SCM arg;
{
  if (SCM_UNBNDP (arg) || SCM_FALSEP (arg))
    endgrent ();
  else
    setgrent ();
  return SCM_UNSPECIFIED;
}



SCM_PROC (s_kill, "kill", 2, 0, 0, scm_kill);

SCM 
scm_kill (pid, sig)
     SCM pid;
     SCM sig;
{
  SCM_ASSERT (SCM_INUMP (pid), pid, SCM_ARG1, s_kill);
  SCM_ASSERT (SCM_INUMP (sig), sig, SCM_ARG2, s_kill);
  /* Signal values are interned in scm_init_posix().  */
  if (kill ((int) SCM_INUM (pid), (int) SCM_INUM (sig)) != 0)
    scm_syserror (s_kill);
  return SCM_UNSPECIFIED;
}



SCM_PROC (s_waitpid, "waitpid", 1, 1, 0, scm_waitpid);

SCM 
scm_waitpid (pid, options)
     SCM pid;
     SCM options;
{
#ifdef HAVE_WAITPID
  int i;
  int status;
  int ioptions;
  SCM_ASSERT (SCM_INUMP (pid), pid, SCM_ARG1, s_waitpid);
  if (SCM_UNBNDP (options))
    ioptions = 0;
  else
    {
      SCM_ASSERT (SCM_INUMP (options), options, SCM_ARG2, s_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_waitpid);
  return scm_cons (SCM_MAKINUM (0L + i), SCM_MAKINUM (0L + status));
#else
  scm_sysmissing (s_waitpid);
  /* not reached.  */
  return SCM_BOOL_F;
#endif
}



SCM_PROC (s_getppid, "getppid", 0, 0, 0, scm_getppid);

SCM 
scm_getppid ()
{
  return SCM_MAKINUM (0L + getppid ());
}



SCM_PROC (s_getuid, "getuid", 0, 0, 0, scm_getuid);

SCM 
scm_getuid ()
{
  return SCM_MAKINUM (0L + getuid ());
}



SCM_PROC (s_getgid, "getgid", 0, 0, 0, scm_getgid);

SCM 
scm_getgid ()
{
  return SCM_MAKINUM (0L + getgid ());
}



SCM_PROC (s_geteuid, "geteuid", 0, 0, 0, scm_geteuid);

SCM 
scm_geteuid ()
{
#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);

SCM 
scm_getegid ()
{
#ifdef HAVE_GETEUID
  return SCM_MAKINUM (0L + getegid ());
#else
  return SCM_MAKINUM (0L + getgid ());
#endif
}


SCM_PROC (s_setuid, "setuid", 1, 0, 0, scm_setuid);

SCM 
scm_setuid (id)
     SCM id;
{
  SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_setuid);
  if (setuid (SCM_INUM (id)) != 0)
    scm_syserror (s_setuid);
  return SCM_UNSPECIFIED;
}

SCM_PROC (s_setgid, "setgid", 1, 0, 0, scm_setgid);

SCM 
scm_setgid (id)
     SCM id;
{
  SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_setgid);
  if (setgid (SCM_INUM (id)) != 0)
    scm_syserror (s_setgid);
  return SCM_UNSPECIFIED;
}

SCM_PROC (s_seteuid, "seteuid", 1, 0, 0, scm_seteuid);

SCM 
scm_seteuid (id)
     SCM id;
{
  int rv;

  SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_seteuid);
#ifdef HAVE_SETEUID
  rv = seteuid (SCM_INUM (id));
#else
  rv = setuid (SCM_INUM (id));
#endif
  if (rv != 0)
    scm_syserror (s_seteuid);
  return SCM_UNSPECIFIED;
}

SCM_PROC (s_setegid, "setegid", 1, 0, 0, scm_setegid);

SCM 
scm_setegid (id)
     SCM id;
{
  int rv;

  SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_setegid);
#ifdef HAVE_SETEUID
  rv = setegid (SCM_INUM (id));
#else
  rv = setgid (SCM_INUM (id));
#endif
  if (rv != 0)
    scm_syserror (s_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_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_setpgid);
  SCM_ASSERT (SCM_INUMP (pgid), pgid, SCM_ARG2, s_setpgid);
  /* FIXME(?): may be known as setpgrp.  */
  if (setpgid (SCM_INUM (pid), SCM_INUM (pgid)) != 0)
    scm_syserror (s_setpgid);
  return SCM_UNSPECIFIED;
#else
  scm_sysmissing (s_setpgid);
  /* not reached.  */
  return SCM_BOOL_F;
#endif
}

SCM_PROC (s_setsid, "setsid", 0, 0, 0, scm_setsid);
SCM 
scm_setsid ()
{
#ifdef HAVE_SETSID
  pid_t sid = setsid ();
  if (sid == -1)
    scm_syserror (s_setsid);
  return SCM_UNSPECIFIED;
#else
  scm_sysmissing (s_setsid);
  /* not reached.  */
  return SCM_BOOL_F;
#endif
}

SCM_PROC (s_ttyname, "ttyname", 1, 0, 0, scm_ttyname);

SCM 
scm_ttyname (port)
     SCM port;
{
  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_ctermid, "ctermid", 0, 0, 0, scm_ctermid);
SCM 
scm_ctermid ()
{
#ifdef HAVE_CTERMID
  char *result = ctermid (NULL);
  if (*result == '\0')
    scm_syserror (s_ctermid);
  return scm_makfrom0str (result);
#else
  scm_sysmissing (s_ctermid);
  /* not reached.  */
  return SCM_BOOL_F;
#endif
}

SCM_PROC (s_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_tcgetpgrp);
  fd = fileno ((FILE *)SCM_STREAM (port));
  if (fd == -1 || (pgid = tcgetpgrp (fd)) == -1)
    scm_syserror (s_tcgetpgrp);
  return SCM_MAKINUM (pgid);
#else
  scm_sysmissing (s_tcgetpgrp);
  /* not reached.  */
  return SCM_BOOL_F;
#endif
}    

SCM_PROC (s_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_tcsetpgrp);
  SCM_ASSERT (SCM_INUMP (pgid), pgid, SCM_ARG2, s_tcsetpgrp);
  fd = fileno ((FILE *)SCM_STREAM (port));
  if (fd == -1 || tcsetpgrp (fd, SCM_INUM (pgid)) == -1)
    scm_syserror (s_tcsetpgrp);
  return SCM_UNSPECIFIED;
#else
  scm_sysmissing (s_tcsetpgrp);
  /* not reached.  */
  return SCM_BOOL_F;
#endif
}    

/* Copy exec args from an SCM vector into a new C array.  */

static char ** scm_convert_exec_args SCM_P ((SCM args));

static char **
scm_convert_exec_args (args)
     SCM args;
{
  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_execl, "execl", 0, 0, 1, scm_execl);

SCM
scm_execl (args)
     SCM args;
{
  char **execargv;
  SCM filename = SCM_CAR (args);
  SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, SCM_ARG1, s_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_execl);
  /* not reached.  */
  return SCM_BOOL_F;
}

SCM_PROC (s_execlp, "execlp", 0, 0, 1, scm_execlp);

SCM
scm_execlp (args)
     SCM args;
{
  char **execargv;
  SCM filename = SCM_CAR (args);
  SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename,
	      SCM_ARG1, s_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_execlp);
  /* not reached.  */
  return SCM_BOOL_F;
}

SCM_PROC (s_fork, "primitive-fork", 0, 0, 0, scm_fork);

SCM
scm_fork()
{
  int pid;
  pid = fork ();
  if (pid == -1)
    scm_syserror (s_fork);
  return SCM_MAKINUM (0L+pid);
}


SCM_PROC (s_uname, "uname", 0, 0, 0, scm_uname);

SCM 
scm_uname ()
{
#ifdef HAVE_UNAME
  struct utsname buf;
  SCM ans = scm_make_vector(SCM_MAKINUM(5), SCM_UNSPECIFIED, SCM_BOOL_F);
  SCM *ve = SCM_VELTS (ans);
  SCM_DEFER_INTS;
  if (uname (&buf))
    scm_syserror (s_uname);
  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);
*/
  SCM_ALLOW_INTS;
  return ans;
#else
  scm_sysmissing (s_uname);
  /* not reached.  */
  return SCM_BOOL_F;
#endif
}

SCM_PROC (s_environ, "environ", 0, 1, 0, scm_environ);

SCM
scm_environ (env)
     SCM env;
{
  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;
    }
}

#ifdef L_tmpnam

SCM_PROC (s_tmpnam, "tmpnam", 0, 0, 0, scm_tmpnam);

SCM scm_tmpnam()
{
  char name[L_tmpnam];
  SCM_SYSCALL (tmpnam (name););
  return scm_makfrom0str (name);
}
#endif

SCM_PROC (s_open_pipe, "open-pipe", 2, 0, 0, scm_open_pipe);

SCM 
scm_open_pipe (pipestr, modes)
     SCM pipestr;
     SCM modes;
{
  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_SETCAR (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);

SCM
scm_open_input_pipe(pipestr)
     SCM pipestr;
{
  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);

SCM
scm_open_output_pipe(pipestr)
     SCM pipestr;
{
  return scm_open_pipe(pipestr, scm_makfromstr("w", (sizeof "w")-1, 0));
}


SCM_PROC (s_utime, "utime", 1, 2, 0, scm_utime);

SCM 
scm_utime (pathname, actime, modtime)
     SCM pathname;
     SCM actime;
     SCM modtime;
{
  int rv;
  struct utimbuf utm_tmp;

  SCM_ASSERT (SCM_NIMP (pathname) && SCM_STRINGP (pathname), pathname,
	      SCM_ARG1, s_utime);

  if (SCM_UNBNDP (actime))
    SCM_SYSCALL (time (&utm_tmp.actime));
  else
    utm_tmp.actime = scm_num2ulong (actime, (char *) SCM_ARG2, s_utime);

  if (SCM_UNBNDP (modtime))
    SCM_SYSCALL (time (&utm_tmp.modtime));
  else
    utm_tmp.modtime = scm_num2ulong (modtime, (char *) SCM_ARG3, s_utime);

  SCM_SYSCALL (rv = utime (SCM_CHARS (pathname), &utm_tmp));
  if (rv != 0)
    scm_syserror (s_utime);
  return SCM_UNSPECIFIED;
}

SCM_PROC (s_access, "access?", 2, 0, 0, scm_access);

SCM 
scm_access (path, how)
     SCM path;
     SCM how;
{
  int rv;

  SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, SCM_ARG1,
	      s_access);
  if (SCM_SUBSTRP (path))
    path = scm_makfromstr (SCM_ROCHARS (path), SCM_ROLENGTH (path), 0);
  SCM_ASSERT (SCM_INUMP (how), how, SCM_ARG2, s_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);

SCM 
scm_getpid ()
{
  return SCM_MAKINUM ((unsigned long) getpid ());
}

SCM_PROC (s_putenv, "putenv", 1, 0, 0, scm_putenv);

SCM
scm_putenv (str)
     SCM str;
{
#ifdef HAVE_PUTENV
  int rv;

  SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_putenv);
  rv = putenv (SCM_CHARS (str));
  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);

SCM
scm_setlocale (category, locale)
     SCM category;
     SCM locale;
{
#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);

SCM
scm_strftime (format, stime)
     SCM format;
     SCM stime;
{
  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_strptime, "strptime", 2, 0, 0, scm_strptime);

SCM
scm_strptime (format, string)
     SCM format;
     SCM string;
{
#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_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_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_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_strptime);
  /* not reached.  */
  return SCM_BOOL_F;
#endif
}

SCM_PROC (s_mknod, "mknod", 3, 0, 0, scm_mknod);

SCM
scm_mknod(path, mode, dev)
     SCM path;
     SCM mode;
     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)));
  if (val != 0)
    scm_syserror (s_mknod);
  return SCM_UNSPECIFIED;
#else
  scm_sysmissing (s_mknod);
  /* not reached.  */
  return SCM_BOOL_F;
#endif
}


SCM_PROC (s_nice, "nice", 1, 0, 0, scm_nice);

SCM
scm_nice(incr)
     SCM incr;
{
#ifdef HAVE_NICE
  SCM_ASSERT(SCM_INUMP(incr), incr, SCM_ARG1, s_nice);
  if (nice(SCM_INUM(incr)) != 0)
    scm_syserror (s_nice);
  return SCM_UNSPECIFIED;
#else
  scm_sysmissing (s_nice);
  /* not reached.  */
  return SCM_BOOL_F;
#endif
}


SCM_PROC (s_sync, "sync", 0, 0, 0, scm_sync);

SCM
scm_sync()
{
#ifdef HAVE_SYNC
  sync();
#else
  scm_sysmissing (s_sync);
  /* not reached.  */
#endif
  return SCM_BOOL_F;
}




void 
scm_init_posix ()
{
  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 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"
}