/* libsizzle/posix.c - Posix/Unix functions
 
  Copyright (C) 2000 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
 
  This 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 software 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 package; see the file COPYING.  If not, write to
  the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  Boston, MA 02111-1307, USA.  */

#if HAVE_CONFIG_H
# include <config.h>
#endif 

#include <assert.h>
#include <string.h>
#include <errno.h>

#if ENABLE_NLS
# include <libintl.h>
# define _(String) gettext(String)
#else
# define _(String) (String)
#endif

#if ENABLE_POSIX

/* FIXME: This crap is required under GNU/Linux if you want to reduce
   the compiler warnings.  Any better solution?  */
#ifndef __USE_BSD
# define __USE_BSD
#endif
#ifndef __USE_XOPEN
# define __USE_XOPEN
#endif
#ifndef __USE_XOPEN_EXTENDED
# define __USE_XOPEN_EXTENDED
#endif
#ifndef __USE_POSIX
# define __USE_POSIX
#endif
#if HAVE_UNISTD_H
# include <unistd.h>
#endif
#ifndef __MINGW32__
# include <pwd.h>
#endif
#include <sys/stat.h>
#if HAVE_SYS_UTSNAME_H
# include <sys/utsname.h>
#endif
#if HAVE_UTIME_H
# include <utime.h>
#endif
#if HAVE_SYS_UTIME_H
# include <sys/utime.h>
#endif
#include <fcntl.h>
#include <signal.h>
#include <stdlib.h>
#include <time.h>
#include <sys/types.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
#if HAVE_DIRECT_H && defined (__MINGW32__)
# include <direct.h>
#endif

#ifndef __MINGW32__
# 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
# define FILENAME(de) (de)->d_name
#else 
# include <windows.h>
# define FILENAME(de) (de).cFileName
# define closedir(de) dir_entry.cFileName[0] = '\0'; FindClose (de)
#endif /* not __MINGW32__ */

#ifdef __MINGW32__
# include <windows.h>
# include <winsock.h>
# include <process.h>
# include <io.h>

#ifndef WNOHANG
/* Bits in the third argument to `waitpid'. */
#define WNOHANG         1       /* Don't block waiting.  */
#define WUNTRACED       2       /* Report status of stopped children.  */
#endif

/*
 * This is the Win32 port of sizzle's posix interface.
 * Functions not yet ported (or even never portable) are
 *    - interruptable sleep (by signals)
 *    - O_NOCTTY, O_SYNC
 *    - getppid, getpgid, getpgrp, getgroups
 *    - getuid, setuid, geteuid, seteuid
 *    - getgid, setgid, getegid, setegid
 *    - getpwnam, getpwuid
 *    - lstat, link, symlink, readlink
 *    - chown
 *    - fork, wait, nice
 *    - sync
 *    - strptime (part of libiberty)
 */

#endif /* __MINGW32__ */

/* Some Unix systems don't define these.  CPP hair is dangerous, but
   this seems safe enough... (thx to the Guile ppl for this one) */
#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

#endif /* ENABLE_POSIX */

#include "alloc.h"
#include "node.h"
#include "vector.h"
#include "list.h"
#include "validate.h"
#include "capi.h"
#include "posix.h"
#if ENABLE_UVECTOR
#include "uvector.h"
#endif /* ENABLE_UVECTOR */
#include "fport.h"
#include "fdport.h"
#include "fport.h"
#include "port.h"
#include "modules.h"

#ifndef O_BINARY
# define O_BINARY 0
#endif

static zzz_scm_t core_posix_module;

static zzz_scm_t zzz_system_error_exception;

static zzz_scm_t stat_regular_symbol;
static zzz_scm_t stat_directory_symbol;
static zzz_scm_t stat_symlink_symbol;
static zzz_scm_t stat_block_special_symbol;
static zzz_scm_t stat_char_special_symbol;
static zzz_scm_t stat_fifo_symbol;
static zzz_scm_t stat_socket_symbol;
static zzz_scm_t stat_unknown_symbol;

zzz_object_t zzz_tagged_type_dir_stream;

zzz_scm_t
zzz_make_system_exception (void)
{
  return zzz_make_exception (zzz_system_error_exception,
			     zzz_make_string (strerror (errno), -1));
}

/*:doc
  getenv
  (getenv str) => string
  Return the value of the environment variable @var{str}.  Return @code{#f} if
  the environment variable @var{str} is not defined.
  doc:*/
#define FUNC_NAME "getenv"
static result_t
getenv_func (zzz_scm_t env, zzz_scm_t str, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  char * val;

  CHECK_TYPE (1, string_p (str), zzz_string_type_name);
  val = getenv (string_val (str));
  if (!val)
    *result = zzz_false_value;
  else
    *result = zzz_make_string (val, strlen (val));
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

#if ENABLE_POSIX

/*:doc
  system
  (system [command]) => integer|boolean
  Execute the given @var{command} using the operating system's command
  processor and return the exit code of the command.  If @var{command} is not
  given, test whether a command processor is available and return @code{#t} if
  it is, @code{#f} otherwise.
  doc:*/
#define FUNC_NAME "system"
static result_t
system_func (zzz_scm_t env, zzz_scm_t string, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int errcode;

  if (string == zzz_undefined)
    {
      errcode = system (NULL);
      *result = zzz_make_bool (errcode);
    }
  else
    {
      CHECK_TYPE (1, string_p (string), zzz_string_type_name);
      errcode = system (string_val (string));
      if (errcode == -1 || errcode == 127)
	{
	  *result = zzz_make_system_exception ();
	  return RESULT_EXCEPTION;
	}
      *result = zzz_make_integer (errcode);
    }
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  putenv
  (putenv string) => *unspecified*
  Put the string @var{string}, which must have the format @code{VARNAME=VALUE},
  into the current process environment.
  doc:*/
#define FUNC_NAME "putenv"
static result_t
putenv_func (zzz_scm_t env, zzz_scm_t string, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
#ifdef __MINGW32__
  char var[256];
#endif /* __MINGW32__ */

#if HAVE_PUTENV
#ifdef __MINGW32__
  CHECK_TYPE (1, string_p (string), zzz_string_type_name);
  CHECK_TYPE (1, string_len (string) < sizeof (var) - 2,
	      "string with lesser characters");
  strcpy (var, string_val (string));
  if (!strstr (var, "=")) strcat (var, "=");
  if (putenv (var) == -1)
#else
  CHECK_TYPE (1, string_p (string), zzz_string_type_name);
  if (putenv (string_val (string)) == -1)
#endif
    {
      *result = zzz_make_misc_error_exception
	(zzz_make_string (_("call to `putenv()' failed"), -1));
      return RESULT_EXCEPTION;
    }
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
#else /* !HAVE_PUTENV */
  *result = zzz_make_not_available_exception
    (zzz_make_symbol (s_func_name, -1));
  return RESULT_EXCEPTION;  
#endif /* !HAVE_PUTENV */
}
#undef FUNC_NAME

/*:doc
  getcwd
  (getcwd) => string
  Return the current working directory.
  doc:*/
#define FUNC_NAME "getcwd"
static result_t
getcwd_func (zzz_scm_t env, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

#if HAVE_GETCWD
  char * b;
  char * buf;
  unsigned size = 64;

  buf = zzz_malloc (size);
  while ((b = getcwd (buf, size)) == NULL && errno == ERANGE)
    {
      buf = zzz_realloc (buf, size * 2, size);
      size *= 2;
    }
  if (b == NULL)
    {
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
#ifdef __MINGW32__
  /* convert '\' to '/' and snip leading [drive:] */
  b = buf; while (*b) { if (*b == '\\') *b = '/'; b++; }
  b = buf;
  if (b[1] == ':' && (b[0] - 'A' == _getdrive () - 1 || 
		      b[0] - 'a' == _getdrive () - 1))
    b+=2;
  *result = zzz_make_string (b, strlen (b));
#else /* !__MINGW32__ */
  *result = zzz_make_string (buf, strlen (buf));
#endif
  zzz_free (buf, size);
  return RESULT_SUCCESS;
#else /* !HAVE_GETCWD */
  *result = zzz_make_not_available_exception
    (zzz_make_symbol (s_func_name, -1));
  return RESULT_EXCEPTION;  
#endif /* !HAVE_GETCWD */
}
#undef FUNC_NAME

/*:doc
  chdir
  (chdir string) => *unspecified*
  Change the current working directory to @var{string}.
  doc:*/
#define FUNC_NAME "chdir"
static result_t
chdir_func (zzz_scm_t env, zzz_scm_t dirname, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int err;

  CHECK_TYPE (1, string_p (dirname), zzz_string_type_name);
  CHECK_SAFE_FILENAME (1, dirname, zzz_safe_filename_type_name);
  if ((err = chdir (string_val (dirname))) == -1)
    {
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  getpid
  (getpid)
  Get the process identification of the current process.
  doc:*/
#define FUNC_NAME "getpid"
static result_t
getpid_func (zzz_scm_t env, zzz_scm_t * result)
{
  *result = zzz_make_integer (getpid ());
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  getppid
  (getppid)
  Get the process idenfication of the parent of the current process.
  doc:*/
#define FUNC_NAME "getppid"
static result_t
getppid_func (zzz_scm_t env, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

#if HAVE_GETPPID
  *result = zzz_make_integer (getppid ());
  return RESULT_SUCCESS;
#else /* !HAVE_GETPPID */
  *result = zzz_make_not_available_exception
    (zzz_make_symbol (s_func_name, -1));
  return RESULT_EXCEPTION;
#endif /* HAVE_GETPPID */
}
#undef FUNC_NAME

/*:doc
  getuid
  (getuid)
  Get the user identification of the user running the current process.
  doc:*/
#define FUNC_NAME "getuid"
static result_t
getuid_func (zzz_scm_t env, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

#if HAVE_GETUID
  *result = zzz_make_integer (getuid ());
  return RESULT_SUCCESS;
#else /* !HAVE_GETUID */
  *result = zzz_make_not_available_exception
    (zzz_make_symbol (s_func_name, -1));
  return RESULT_EXCEPTION;
#endif /* !HAVE_GETUID */
}
#undef FUNC_NAME

/*:doc
  setuid
  (setuid uid) => *unspecified*
  Set the user identification of the current process to @var{uid}.
  doc:*/
#define FUNC_NAME "setuid"
static result_t
setuid_func (zzz_scm_t env, zzz_scm_t uid, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, integer_p (uid), zzz_integer_type_name);
#if HAVE_SETUID
  if (setuid (integer_val (uid)) == -1)
    {
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
#else /* !HAVE_SETUID */
  *result = zzz_make_not_available_exception
    (zzz_make_symbol (s_func_name, -1));
  return RESULT_EXCEPTION;
#endif /* !HAVE_SETUID */
}
#undef FUNC_NAME

/*:doc
  geteuid
  (geteuid) => integer
  Returns the effective user identifier of the running Sizzle process.  A
  @code{system-error} exception may be raised if an error occurs.
  doc:*/
#define FUNC_NAME "geteuid"
static result_t
geteuid_func (zzz_scm_t env, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

#if HAVE_GETEUID
  *result = zzz_make_integer (geteuid ());
  return RESULT_SUCCESS;
#else /* HAVE_GETEUID */
  *result = zzz_make_not_available_exception
    (zzz_make_symbol (s_func_name, -1));
  return RESULT_EXCEPTION;
#endif /* HAVE_GETEUID */
}
#undef FUNC_NAME

/*:doc
  seteuid
  (seteuid euid) => *unspecified*
  Set the effective user identifier of the current Sizzle process to
  @var{euid}.  This function may raise a @code{system-error} exception if
  an error occurs.  The return value is not specified.
  doc:*/
#define FUNC_NAME "seteuid"
static result_t
seteuid_func (zzz_scm_t env, zzz_scm_t uid, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, integer_p (uid), zzz_integer_type_name);
#if HAVE_SETEUID
  if (seteuid (integer_val (uid)) == -1)
    {
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
#else /* HAVE_SETEUID */
  *result = zzz_make_not_available_exception
    (zzz_make_symbol (s_func_name, -1));
  return RESULT_EXCEPTION;
#endif /* HAVE_SETEUID */
}
#undef FUNC_NAME

/*:doc
  getgid
  (getgid) => integer
  Returns the group identifier of the running Sizzle process.  A
  @code{system-error} exception may be raised if an error occurs.
  doc:*/
#define FUNC_NAME "getgid"
static result_t
getgid_func (zzz_scm_t env, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

#if HAVE_GETGID
  *result = zzz_make_integer (getgid ());
  return RESULT_SUCCESS;
#else /* !HAVE_GETGID */
  *result = zzz_make_not_available_exception
    (zzz_make_symbol (s_func_name, -1));
  return RESULT_EXCEPTION;
#endif /* !HAVE_GETGID */
}
#undef FUNC_NAME

/*:doc
  setgid
  (setgid gid) => *unspecified*
  Set the group identifier of the running Sizzle process to @var{gid}.  A
  @code{system-error} exception may be raised if an error occurs.  The
  return value is not specified.
  doc:*/
#define FUNC_NAME "setgid"
static result_t
setgid_func (zzz_scm_t env, zzz_scm_t gid, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, integer_p (gid), zzz_integer_type_name);
#if HAVE_SETGID
  if (setgid (integer_val (gid)) == -1)
    {
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
  *result = zzz_unspecified;
  return !RESULT_SUCCESS;
#else /* HAVE_SETGID */
  *result = zzz_make_not_available_exception
    (zzz_make_symbol (s_func_name, -1));
  return RESULT_EXCEPTION;
#endif /* !HAVE_SETGID */
}
#undef FUNC_NAME

/*:doc
  getegid
  (getegid) => integer
  Returns the effective group identifier of the running Sizzle process.  A
  @code{system-error} exception may be raised if an error occurs.
  doc:*/
#define FUNC_NAME "getegid"
static result_t
getegid_func (zzz_scm_t env, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

#if HAVE_GETEGID
  *result = zzz_make_integer (getegid ());
  return RESULT_SUCCESS;
#else /* HAVE_GETEGID */
  *result = zzz_make_not_available_exception
    (zzz_make_symbol (s_func_name, -1));
  return RESULT_EXCEPTION;
#endif /* HAVE_GETEGID */
}
#undef FUNC_NAME

/*:doc
  setegid
  (setegid egid) => *unspecified*
  Set the effective group identifier of the running Sizzle process to
  @var{egid}.  A @code{system-error} exception may be raised if an error
  occurs. The return value is not specified.
  doc:*/
#define FUNC_NAME "setegid"
static result_t
setegid_func (zzz_scm_t env, zzz_scm_t gid, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, integer_p (gid), zzz_integer_type_name);
#if HAVE_SETEGID
  if (setegid (integer_val (gid)) == -1)
    {
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
#else /* HAVE_SETEGID */
  *result = zzz_make_not_available_exception
    (zzz_make_symbol (s_func_name, -1));
  return RESULT_EXCEPTION;
#endif /* HAVE_SETEGID */
}
#undef FUNC_NAME

/*:doc
  getpgid
  (getpgid pid) => integer
  Returns the process group identifier of the process specified by
  @var{pid}.  If @var{pid} is zero, the process identifier of the current
  process is used.  This function may raise a @code{system-error}
  exception if an error occurs.
  doc:*/
#define FUNC_NAME "getpgid"
static result_t
getpgid_func (zzz_scm_t env, zzz_scm_t pid, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, integer_p (pid), zzz_integer_type_name);
#if HAVE_GETPGID
  *result = zzz_make_integer (getpgid (integer_val (pid)));
  return RESULT_SUCCESS;
#else /* HAVE_GETPGID */
  *result = zzz_make_not_available_exception
    (zzz_make_symbol (s_func_name, -1));
  return RESULT_EXCEPTION;
#endif /* HAVE_GETPGID */
}
#undef FUNC_NAME

/*:doc
  getpgrp
  (getpgrp) => integer
  This is equivalent to @code{(getpgid 0)}.
  doc:*/
#define FUNC_NAME "getpgrp"
static result_t
getpgrp_func (zzz_scm_t env, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

#if HAVE_GETPGRP
  *result = zzz_make_integer (getpgrp ());
  return RESULT_SUCCESS;
#else /* HAVE_GETPGRP */
  *result = zzz_make_not_available_exception
    (zzz_make_symbol (s_func_name, -1));
  return RESULT_EXCEPTION;
#endif /* HAVE_GETPGRP */
}
#undef FUNC_NAME

#ifndef __MINGW32__
static zzz_scm_t
make_pw_vector (struct passwd * passwd)
{
  zzz_scm_t res = zzz_make_vector (7);

  zzz_vector_put (res, 0, zzz_make_string (passwd->pw_name, -1));
  zzz_vector_put (res, 1, zzz_make_string (passwd->pw_passwd, -1));
  zzz_vector_put (res, 2, zzz_make_integer (passwd->pw_uid));
  zzz_vector_put (res, 3, zzz_make_integer (passwd->pw_gid));
  zzz_vector_put (res, 4, zzz_make_string (passwd->pw_gecos, -1));
  zzz_vector_put (res, 5, zzz_make_string (passwd->pw_dir, -1));
  zzz_vector_put (res, 6, zzz_make_string (passwd->pw_shell, -1));
  return res;
}
#endif /* not __MINGW32__ */

/*:doc
  getpwnam
  (getpwnam name) => vector
  Returns a vector containing the broken out fields of a line from
  @file{/etc/passwd} for the entry that matches the user name
  @var{name}. This function may raise a @code{system-error} exception
  if an error occurs.  The returned vector contains the seven fields:
  username, password, uid, gid, gecos, dir, shell.
  doc:*/
#define FUNC_NAME "getpwnam"
static result_t
getpwnam_func (zzz_scm_t env, zzz_scm_t name, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

#ifndef __MINGW32__
  struct passwd * passwd;
#endif /* __MINGW32__ */

  CHECK_TYPE (1, string_p (name), zzz_string_type_name);
#ifndef __MINGW32__
  passwd = getpwnam (string_val (name));
  if (passwd != NULL)
    {
      *result = make_pw_vector (passwd);
      return RESULT_SUCCESS;
    }
  else
    {
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
#else /* __MINGW32__ */
  *result = zzz_make_not_available_exception
    (zzz_make_symbol (s_func_name, -1));
  return RESULT_EXCEPTION;
#endif /* !__MINGW32__ */
}
#undef FUNC_NAME

/*:doc
  getpwuid
  (getpwuid uid) => vector
  Returns a vector containing the broken out fields of a line from
  @file{/etc/passwd} for the entry that matches the user identifier
  @var{uid}.  This function may raise a @code{system-error} exception if an
  error occurs.  The returned vector has the same format as for
  @code{getpwnam}.
  doc:*/
#define FUNC_NAME "getpwuid"
static result_t
getpwuid_func (zzz_scm_t env, zzz_scm_t uid, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

#ifndef __MINGW32__
  struct passwd * passwd;
#endif /* __MINGW32__ */

  CHECK_TYPE (1, integer_p (uid), zzz_integer_type_name);
#ifndef __MINGW32__
  passwd = getpwuid (integer_val (uid));
  if (passwd != NULL)
    {
      *result = make_pw_vector (passwd);
      return RESULT_SUCCESS;
    }
  else
    {
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
#else /* __MINGW32__ */
  *result = zzz_make_not_available_exception
    (zzz_make_symbol (s_func_name, -1));
  return RESULT_EXCEPTION;
#endif /* !__MINGW32__ */
}
#undef FUNC_NAME

/*:doc
  getpwent
  (getpwent) => vector
  Returns a vector containing the broken out fields of a line from
  @file{/etc/passwd} for the next entry.  The returned vector has the
  same format as for @code{getpwnam}.
  doc:*/
#define FUNC_NAME "getpwent"
static result_t
getpwent_func (zzz_scm_t env, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

#ifndef __MINGW32__
  struct passwd * passwd;
#endif /* __MINGW32__ */

#ifndef __MINGW32__
  passwd = getpwent ();
  if (passwd != NULL)
    {
      *result = make_pw_vector (passwd);
      return RESULT_SUCCESS;
    }
  else
    {
      *result = zzz_false_value;
      return RESULT_SUCCESS;
    }
#else /* __MINGW32__ */
  *result = zzz_make_not_available_exception
    (zzz_make_symbol (s_func_name, -1));
  return RESULT_EXCEPTION;
#endif /* __MINGW32__ */
}
#undef FUNC_NAME

/*:doc
  setpwent
  (setpwent) => *unspecified*
  Reset the entry pointer for the passwd database, so that the next
  call to @code{getpwent} will return the first entry.  The return
  value is not specified.
  doc:*/
#define FUNC_NAME "setpwent"
static result_t
setpwent_func (zzz_scm_t env, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

#ifndef __MINGW32__
  struct passwd * passwd;
#endif /* __MINGW32__ */

#ifndef __MINGW32__
  setpwent ();
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
#else /* __MINGW32__ */
  *result = zzz_make_not_available_exception
    (zzz_make_symbol (s_func_name, -1));
  return RESULT_EXCEPTION;
#endif /* __MINGW32__ */
}
#undef FUNC_NAME

/*:doc
  endpwent
  (endpwent) => *unspecified*
  Close the @file{/etc/passwd} user information database.
  doc:*/
#define FUNC_NAME "endpwent"
static result_t
endpwent_func (zzz_scm_t env, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

#ifndef __MINGW32__
  struct passwd * passwd;
#endif /* __MINGW32__ */

#ifndef __MINGW32__
  endpwent ();
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
#else /* __MINGW32__ */
  *result = zzz_make_not_available_exception
    (zzz_make_symbol (s_func_name, -1));
  return RESULT_EXCEPTION;
#endif /* __MINGW32__ */
}
#undef FUNC_NAME

/*:doc
  getgroups
  (getgroups) => vector
  Returns a vector containing all groups the current user belongs to.
  This function may raise a @code{system-error} exception if an error
  occurs.
  doc:*/
#define FUNC_NAME "getgroups"
static result_t
getgroups_func (zzz_scm_t env, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

#if HAVE_GETGROUPS
  GETGROUPS_T * groups;
  int grp_cnt, cnt;
  zzz_scm_t res;

  grp_cnt = getgroups (0, NULL);
  groups = zzz_malloc (grp_cnt * sizeof (GETGROUPS_T));
  if ((cnt = getgroups (grp_cnt, groups)) == -1)
    {
      zzz_free (groups, grp_cnt * sizeof (GETGROUPS_T));
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
  assert (cnt == grp_cnt);
  res = zzz_make_vector (cnt);
  while (--cnt >= 0)
    zzz_vector_put (res, cnt, zzz_make_integer (groups[cnt]));
  *result = res;
  zzz_free (groups, grp_cnt * sizeof (GETGROUPS_T));
  return RESULT_SUCCESS;
#else /* HAVE_GETGROUPS */
  *result = zzz_make_not_available_exception
    (zzz_make_symbol (s_func_name, -1));
  return RESULT_EXCEPTION;
#endif /* HAVE_GETGROUPS */
}
#undef FUNC_NAME

static zzz_scm_t
make_stat_vector (struct stat * stat)
{
  zzz_scm_t res = zzz_make_vector (15);

  zzz_vector_put (res, 0, zzz_make_integer (stat->st_dev));
  zzz_vector_put (res, 1, zzz_make_integer (stat->st_ino));
  zzz_vector_put (res, 2, zzz_make_integer (stat->st_mode));
  zzz_vector_put (res, 3, zzz_make_integer (stat->st_nlink));
  zzz_vector_put (res, 4, zzz_make_integer (stat->st_uid));
  zzz_vector_put (res, 5, zzz_make_integer (stat->st_gid));
#ifdef HAVE_ST_RDEV
  zzz_vector_put (res, 6, zzz_make_integer (stat->st_rdev));
#else
  zzz_vector_put (res, 6, zzz_false_value);
#endif
  zzz_vector_put (res, 7, zzz_make_integer (stat->st_size));
  zzz_vector_put (res, 8, zzz_make_integer (stat->st_atime));
  zzz_vector_put (res, 9, zzz_make_integer (stat->st_mtime));
  zzz_vector_put (res, 10, zzz_make_integer (stat->st_ctime));
#if HAVE_ST_BLKSIZE
  zzz_vector_put (res, 11, zzz_make_integer (stat->st_blksize));
#else
  zzz_vector_put (res, 11, zzz_make_integer (4096));
#endif
#if HAVE_ST_BLOCKS
  zzz_vector_put (res, 12, zzz_make_integer (stat->st_blocks));
#else
  zzz_vector_put (res, 12, zzz_false_value);
#endif
  {
    int mode = stat->st_mode;
    
    if (S_ISREG (mode))
      zzz_vector_put (res, 13, stat_regular_symbol);
    else if (S_ISDIR (mode))
      zzz_vector_put (res, 13, stat_directory_symbol);
#ifdef S_ISLNK
    else if (S_ISLNK (mode))
      zzz_vector_put (res, 13, stat_symlink_symbol);
#endif
#ifdef S_ISBLK
    else if (S_ISBLK (mode))
      zzz_vector_put (res, 13, stat_block_special_symbol);
#endif
    else if (S_ISCHR (mode))
      zzz_vector_put (res, 13, stat_char_special_symbol);
#ifdef S_ISFIFO
    else if (S_ISFIFO (mode))
      zzz_vector_put (res, 13, stat_fifo_symbol);
#endif
#ifdef S_ISSOCK
    else if (S_ISSOCK (mode))
      zzz_vector_put (res, 13, stat_socket_symbol);
#endif
    else
      zzz_vector_put (res, 13, stat_unknown_symbol);

    zzz_vector_put (res, 14, zzz_make_integer ((~S_IFMT) & mode));
  }
  return res;
}

/*:doc
  stat
  (stat filename) => vector
  Returns information about the specified file.  You do not need any
  access rights to the file to get this information but you need
  search rights to all directories named in the path leading to the
  file.  This function may raise a @code{system-error} exception if an
  error occurs.
  doc:*/
#define FUNC_NAME "stat"
static result_t
stat_func (zzz_scm_t env, zzz_scm_t filename, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  struct stat st;

  CHECK_TYPE (1, string_p (filename), zzz_string_type_name);
  CHECK_SAFE_FILENAME (1, filename, zzz_safe_filename_type_name);
  if (stat (string_val (filename), &st) != -1)
    {
      *result = make_stat_vector (&st);
      return RESULT_SUCCESS;
    }
  else
    {
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
}
#undef FUNC_NAME

/*:doc
  lstat
  (lstat filename) => filename
  Like @code{stat}, but does not follow symbolic links.
  doc:*/
#define FUNC_NAME "lstat"
static result_t
lstat_func (zzz_scm_t env, zzz_scm_t filename, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

#ifndef __MINGW32__
  struct stat st;

  CHECK_TYPE (1, string_p (filename), zzz_string_type_name);
  CHECK_SAFE_FILENAME (1, filename, zzz_safe_filename_type_name);
  if (lstat (string_val (filename), &st) != -1)
    {
      *result = make_stat_vector (&st);
      return RESULT_SUCCESS;
    }
  else
    {
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
#else /* __MINGW32__ */
  *result = zzz_make_not_available_exception
    (zzz_make_symbol (s_func_name, -1));
  return RESULT_EXCEPTION;
#endif /* !__MINGW32__ */
}
#undef FUNC_NAME

/*:doc
  access?
  (access? name mode) => boolean
  Checks whether the process would be allowed to read, write or test
  for existence of the file (or other file system object) whose name
  is pathname.  If pathname is a symbolic link permissions of the file
  referred to by this symbolic link are tested.  Returns @code{#t} if
  access is permitted, @code{#f} otherwise.  This function may raise a
  @code{system-error} exception if an error occurs.  @var{mode} is a
  mask of one or more of the following constants: @code{R_OK}, @code{W_OK},
  @code{X_OK}, @code{F_OK}.  @code{access?} is only successful if all 
  requested permissions are granted.
  doc:*/
#define FUNC_NAME "access?"
static result_t
access_p_func (zzz_scm_t env, zzz_scm_t name, zzz_scm_t mode,
	       zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, string_p (name), zzz_string_type_name);
  CHECK_TYPE (2, integer_p (mode), zzz_integer_type_name);
  if (access (string_val (name), integer_val (mode)) != -1)
    *result = zzz_true_value;
  else
    *result = zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

#ifdef __MINGW32__
/*
 * Create an anonymous pipe in Win32 whose handles are inheritable.
 */
static int
pipe (int pipedes[2])
{
  SECURITY_ATTRIBUTES sa = { sizeof (SECURITY_ATTRIBUTES), 
			     NULL,    /* NULL security descriptor */
			     TRUE };  /* inherit handles */

  if (!CreatePipe ((PHANDLE) &pipedes[0], (PHANDLE) &pipedes[1], &sa, 0))
    return -1;
  return 0;
}
#endif /* __MINGW32__ */

/*:doc
  sys:pipe
  (sys:pipe) => pair
  Creates a pair of file descriptors, pointing to a pipe inode. The car of
  the returned pair is a file descriptor for reading, the cdr is a file
  descriptor for writing.  This function may raise a @code{system-error}
  exception if an error occurs.
  doc:*/
#define FUNC_NAME "sys:pipe"
static result_t
sys_pipe_func (zzz_scm_t env, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int p[2];

  if (pipe (p) == -1)
    {
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
  *result = zzz_cons (zzz_make_integer (p[0]),
		      zzz_make_integer (p[1]));
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  pipe
  (pipe) => pair
  Creates a pair of ports, pointing to a pipe inode. The car of the
  returned pair is an input port for reading, the cdr is an output
  port for writing.  This function may raise a @code{system-error}
  exception if an error occurs.
  doc:*/
#define FUNC_NAME "pipe"
static result_t
pipe_func (zzz_scm_t env, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int p[2];

  if (pipe (p) == -1)
    {
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
  *result = zzz_cons (zzz_make_fdport (p[0], 1, 0),
		      zzz_make_fdport (p[1], 0, 1));
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  open-fdes
  (open-fdes filename flags [mode]) => fdesc
  Attempts to open the file called @var{filename} and returns a file
  descriptor.  @var{flags} is a mask of one or more of the constants
  @code{O_*}.  If @var{flags} contains @code{O_CREAT}, the argument @var{mode}
  must be given.  It denotes the set of file permission to give to the new
  file.
  doc:*/
#define FUNC_NAME "open-fdes"
static result_t
open_fdes_func (zzz_scm_t env, zzz_scm_t fname, zzz_scm_t flags,
		zzz_scm_t mode, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int fdes;

  CHECK_TYPE (1, string_p (fname), zzz_string_type_name);
  CHECK_SAFE_FILENAME (1, fname, zzz_safe_filename_type_name);
  CHECK_TYPE (2, integer_p (flags), zzz_integer_type_name);
  if ((integer_val (flags) & O_CREAT) != 0)
    CHECK_TYPE (3, integer_val (mode), zzz_integer_type_name);
  else
    mode = zzz_make_integer (0);
  if ((fdes = open (string_val (fname), integer_val (flags) | O_BINARY,
		    integer_val (mode))) == -1)
    {
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
  *result = zzz_make_integer (fdes);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  creat
  (sys:creat filename mode) => fdesc
  This is equivalent to @code{open} with flags equal to @code{(logior
  O_CREAT O_WRONLY O_TRUNC)}.
  doc:*/
#define FUNC_NAME "sys:creat"
static result_t
creat_func (zzz_scm_t env, zzz_scm_t fname, zzz_scm_t mode, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int fdes;

  CHECK_TYPE (1, string_p (fname), zzz_string_type_name);
  CHECK_SAFE_FILENAME (1, fname, zzz_safe_filename_type_name);
  CHECK_TYPE (2, integer_p (mode), zzz_integer_type_name);
  if ((fdes = creat (string_val (fname), 
		     integer_val (mode) | O_BINARY)) == -1)
    {
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
  *result = zzz_make_integer (fdes);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  close
  (close fdesc) => *unspecified*
  If @var{fdesc} is an integer, closes the file descriptor, so that it
  no longer refers to any file and may be reused.  If @var{fdesc} is a
  port, it will be closed.  This function may raise a
  @code{system-error} exception if an error occurs.
  doc:*/
#define FUNC_NAME "close"
static result_t
close_func (zzz_scm_t env, zzz_scm_t fd, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, integer_p (fd) || port_p (fd), _("file descriptor or port"));
  if (integer_p (fd))
    {
      if (close (integer_val (fd)) == -1)
	{
	  *result = zzz_make_system_exception ();
	  return RESULT_EXCEPTION;
	}
    }
  else if (port_p (fd))
    {
      return zzz_port_close (fd, result);
    }
  else
    abort ();			/* Sanity check. */
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  sys:write
  (sys:write fd u8vec cnt) => *unspecified*
  Write @var{count} bytes from the homogenous unsigned 8-bit vector
  @var{u8vec} to the file referenced by the file descriptor @var{fd}.
  Returns the number of bytes actually written.  This function may raise a
  @code{system-error} exception if an error occurs.
  doc:*/
#define FUNC_NAME "sys:write"
static result_t
write_func (zzz_scm_t env, zzz_scm_t fd, zzz_scm_t str, zzz_scm_t cnt,
	    zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

#if ENABLE_UVECTOR
  CHECK_TYPE (1, integer_p (fd), zzz_integer_type_name);
  CHECK_TYPE (2, u8vector_p (str), zzz_u8vector_type_name);
  CHECK_TYPE (3, integer_p (cnt), zzz_integer_type_name);
  if ((unsigned) integer_val (cnt) > u8vector_len (str))
    {
      *result = zzz_make_wta_exception
	(zzz_cons
	 (zzz_make_string
	  (_("count argument greater than vector length in call to `"), -1),
	  zzz_cons (zzz_make_string (FUNC_NAME, -1),
		    zzz_cons (zzz_make_string ("'", -1), NULL))));
      return RESULT_EXCEPTION;
    }
  if (write (integer_val (fd), u8vector_val (str), integer_val (cnt)) == -1)
    {
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
#else /* !ENABLE_UVECTOR */
  *result = zzz_make_not_available_exception
    (zzz_make_symbol (s_func_name, -1));
  return RESULT_EXCEPTION;
#endif /* !ENABLE_UVECTOR */
}
#undef FUNC_NAME

/*:doc
  sys:read!
  (sys:read! fd u8vec cnt) => *unspecified*
  Read @var{count} bytes from the file referenced by the file descriptor
  @var{fd} and stores them into the homogenous unsigned 8-bit vector
  @var{u8vec}.  The return value is not specified.  This function may
  raise a @code{system-error} exception if an error occurs.
  doc:*/
#define FUNC_NAME "sys:read!"
static result_t
read_x_func (zzz_scm_t env, zzz_scm_t fd, zzz_scm_t str, zzz_scm_t cnt,
	     zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

#if ENABLE_UVECTOR
  CHECK_TYPE (1, integer_p (fd), zzz_integer_type_name);
  CHECK_TYPE (2, u8vector_p (str), zzz_u8vector_type_name);
  CHECK_TYPE (3, integer_p (cnt), zzz_integer_type_name);
  if ((unsigned) integer_val (cnt) > u8vector_len (str))
    {
      *result = zzz_make_wta_exception
	(zzz_cons
	 (zzz_make_string
	  (_("count argument greater than vector length in call to `"), -1),
	  zzz_cons (zzz_make_string (FUNC_NAME, -1),
		    zzz_cons (zzz_make_string ("'", -1), NULL))));
      return RESULT_EXCEPTION;
    }
  if (read (integer_val (fd), u8vector_val (str), integer_val (cnt)) == -1)
    {
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
#else /* !ENABLE_UVECTOR */
  *result = zzz_make_not_available_exception
    (zzz_make_symbol (s_func_name, -1));
  return RESULT_EXCEPTION;
#endif /* !ENABLE_UVECTOR */
}
#undef FUNC_NAME

/*:doc
  sys:read
  (sys:read fd cnt) => u8vec
  Read @var{count} bytes from the file referenced by the file descriptor
  @var{fd} and returns a homogenous unsigned 8-bit vector containing those
  bytes.  This function may raise a @code{system-error} exception if an
  error occurs.
  doc:*/
#define FUNC_NAME "sys:read"
static result_t
read_func (zzz_scm_t env, zzz_scm_t fd, zzz_scm_t cnt, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
#if ENABLE_UVECTOR
  zzz_scm_t res;
  int read_cnt;

  CHECK_TYPE (1, integer_p (fd), zzz_integer_type_name);
  CHECK_TYPE (2, integer_p (cnt), zzz_string_type_name);
  res = zzz_make_u8vector (integer_val (cnt));
  if ((read_cnt = read (integer_val (fd), u8vector_val (res),
			integer_val (cnt))) == -1)
    {
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
  if (read_cnt < integer_val (cnt))
    {
      *result = zzz_make_u8vector (read_cnt);
      memmove (u8vector_val (*result), u8vector_val (res), read_cnt);
    }
  else
    *result = res;
  return RESULT_SUCCESS;
#else /* !ENABLE_UVECTOR */
  *result = zzz_make_not_available_exception
    (zzz_make_symbol (s_func_name, -1));
  return RESULT_EXCEPTION;
#endif /* !ENABLE_UVECTOR */
}
#undef FUNC_NAME

/*:doc
  unlink
  (unlink filename) => *unspecified*
  Deletes a name from the filesystem. If that name was the last link to a
  file and no processes have the file open the file is deleted and the
  space it was using is made available for reuse.  The return value is not
  specified.  This function may raise a @code{system-error} exception if
  an error occurs.
  doc:*/
#define FUNC_NAME "unlink"
static result_t
unlink_func (zzz_scm_t env, zzz_scm_t fname, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, string_p (fname), zzz_string_type_name);
  CHECK_SAFE_FILENAME (1, fname, zzz_safe_filename_type_name);
  if (unlink (string_val (fname)) == -1)
    {
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  link
  (link oldpath newpath) => *unspecified*
  Creates a new link (also known as a hard link) to an existing file.  If
  @var{newpath} exists it will not be overwritten.  The return value is
  not specified.  This function may raise a @code{system-error} exception
  if an error occurs.
  doc:*/
#define FUNC_NAME "link"
static result_t
link_func (zzz_scm_t env, zzz_scm_t oldname, zzz_scm_t newname,
	   zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, string_p (oldname), zzz_string_type_name);
  CHECK_TYPE (2, string_p (newname), zzz_string_type_name);
#if HAVE_LINK
  if (link (string_val (oldname), string_val (newname)) == -1)
    {
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
#else /* !HAVE_LINK */
  *result = zzz_make_not_available_exception
    (zzz_make_symbol (s_func_name, -1));
  return RESULT_EXCEPTION;
#endif /* !HAVE_LINK */
}
#undef FUNC_NAME

/*:doc
  symlink
  (symlink oldpath newpath) => *unspecified*
  Creates a new symbolic link to an existing file.  If @var{newpath}
  exists it will not be overwritten.  The return value is not specified.
  This function may raise a @code{system-error} exception if an error
  occurs.
  doc:*/
#define FUNC_NAME "symlink"
static result_t
symlink_func (zzz_scm_t env, zzz_scm_t oldname, zzz_scm_t newname,
	      zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, string_p (oldname), zzz_string_type_name);
  CHECK_TYPE (2, string_p (newname), zzz_string_type_name);
#if HAVE_SYMLINK
  if (symlink (string_val (oldname), string_val (newname)) == -1)
    {
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
#else /* !HAVE_SYMLINK */
  *result = zzz_make_not_available_exception
    (zzz_make_symbol (s_func_name, -1));
  return RESULT_EXCEPTION;
#endif /* !HAVE_SYMLINK */
}
#undef FUNC_NAME

/*:doc
  rename
  (rename oldpath newpath) => *unspecified*
  Renames a file, moving it between directories if required.
  @var{oldpath} and @var{newpath} must refer to the same file system.  The
  return value is not specified.  This function may raise a
  @code{system-error} exception if an error occurs.
  doc:*/
#define FUNC_NAME "rename"
static result_t
rename_func (zzz_scm_t env, zzz_scm_t oldname, zzz_scm_t newname,
	     zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, string_p (oldname), zzz_string_type_name);
  CHECK_TYPE (2, string_p (newname), zzz_string_type_name);
  if (rename (string_val (oldname), string_val (newname)) == -1)
    {
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  readlink
  (readlink filename) => string
  Returns the name of the file the link @var{filename} is referring to.
  This function may raise a @code{system-error} exception if an error
  occurs.
  doc:*/
#define FUNC_NAME "readlink"
static result_t
readlink_func (zzz_scm_t env, zzz_scm_t fname, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
#if HAVE_READLINK
  char * buf;
  int res;
#endif

  CHECK_TYPE (1, string_p (fname), zzz_string_type_name);
  CHECK_SAFE_FILENAME (1, fname, zzz_safe_filename_type_name);
#if HAVE_READLINK
  buf = zzz_malloc (1024 * 4);
  if ((res = readlink (string_val (fname), buf, 1024 * 4)) == -1)
    {
      zzz_free (buf, 1024 * 4);
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
  *result = zzz_make_string (buf, res);
  zzz_free (buf, 1024 * 4);
  return RESULT_SUCCESS;
#else /* !HAVE_READLINK */
  *result = zzz_make_not_available_exception
    (zzz_make_symbol (s_func_name, -1));
  return RESULT_EXCEPTION;
#endif /* !HAVE_READLINK */
}
#undef FUNC_NAME

/*:doc
  chmod
  (chmod path mode) => *unspecified*
  The mode of the file given by @var{path} is changed to @var{mode}.
  @var{mode} is a mask made from the @code{S_I...} constants listed in the
  description of @code{stat}.  This function may raise a
  @code{system-error} exception if an error occurs.
  doc:*/
#define FUNC_NAME "chmod"
static result_t
chmod_func (zzz_scm_t env, zzz_scm_t fname, zzz_scm_t mode, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, string_p (fname), zzz_string_type_name);
  CHECK_SAFE_FILENAME (1, fname, zzz_safe_filename_type_name);
  CHECK_TYPE (2, integer_p (mode), zzz_integer_type_name);
  if (chmod (string_val (fname), integer_val (mode)) == -1)
    {
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  chown
  (chown path uid gid) => *unspecified*
  Set the user identifier and group identifier of the file @var{path} to
  @var{uid} and @var{gid}.  If any of @var{uid} or @var{gid} is equal to
  -1, that component of @var{path}'s ownership is not changed.  This
  function may raise a @code{system-error} exception if an error occurs.
  doc:*/
#define FUNC_NAME "chown"
static result_t
chown_func (zzz_scm_t env, zzz_scm_t fname, zzz_scm_t owner, zzz_scm_t group,
	    zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, string_p (fname), zzz_string_type_name);
  CHECK_SAFE_FILENAME (1, fname, zzz_safe_filename_type_name);
  CHECK_TYPE (2, integer_p (owner), zzz_integer_type_name);
  CHECK_TYPE (3, integer_p (group), zzz_integer_type_name);
#if HAVE_CHOWN
  if (chown (string_val (fname), integer_val (owner),
	     integer_val (group)) == -1)
    {
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
#else /* !HAVE_CHOWN */
  *result = zzz_make_not_available_exception
    (zzz_make_symbol (s_func_name, -1));
  return RESULT_EXCEPTION;
#endif /* !HAVE_CHOWN */
}
#undef FUNC_NAME

/*:doc
  primitive-exit
  (primitive-exit [status]) => *no-return*
  Terminate the current process without performing any cleanup.  The exit
  status is STATUS, which defaults to 0 if not specified.  This procedure
  has no return value, because it never returns.
  doc:*/
#define FUNC_NAME "primitive-exit"
static result_t
primitive_exit_func (zzz_scm_t env, zzz_scm_t code, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int n;

  if (code == zzz_undefined)
    n = 0;
  else
    {
      CHECK_TYPE (1, integer_p (code), zzz_integer_type_name);
      n = integer_val (code);
    }
  exit (n);
  /* NOT REACHED */
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  fork
  (fork) => pid
  Creates a child process that differs from the parent process only in its
  process identifier and parent process identifier, and in the fact that
  resource utilizations are set to 0.  File locks and pending signals
  are not inherited.  This function may raise a @code{system-error}
  exception if an error occurs.
  doc:*/
#define FUNC_NAME "fork"
static result_t
fork_func (zzz_scm_t env, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

#if HAVE_FORK
  int res;
  if ((res = fork ()) == -1)
    {
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
  *result = zzz_make_integer (res);
  return RESULT_SUCCESS;
#else /* !HAVE_FORK */
  *result = zzz_make_not_available_exception
    (zzz_make_symbol (s_func_name, -1));
  return RESULT_EXCEPTION;
#endif /* !HAVE_FORK */
}
#undef FUNC_NAME

/*:doc
  wait
  (wait) => pair
  Waits for any child process to terminate and returns a pair whose car is
  the process id of the child and whose cdr is the exit code.  This
  function may raise a @code{system-error} exception if an error occurs.
  doc:*/
#define FUNC_NAME "wait"
static result_t
wait_func (zzz_scm_t env, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

#if HAVE_WAIT
  int pid, status;
  pid = wait (&status);
  *result = zzz_cons (zzz_make_integer (pid), zzz_make_integer (status));
  return RESULT_SUCCESS;
#else /* !HAVE_WAIT */
  *result = zzz_make_not_available_exception
    (zzz_make_symbol (s_func_name, -1));
  return RESULT_EXCEPTION;
#endif /* !HAVE_WAIT */
}
#undef FUNC_NAME

/*:doc
  waitpid
  (waitpid pid [options]) => pair
  Waits until child process @var{pid} has terminated.  For usage of the
  @var{options} argument, refer to the @code{waitpid} man page.  This
  function may raise a @code{system-error} exception if an error occurs.
  doc:*/
#define FUNC_NAME "waitpid"
static result_t
waitpid_func (zzz_scm_t env, zzz_scm_t pid, zzz_scm_t options,
	      zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
#if HAVE_WAITPID
  int rpid, status, opts;
#elif defined (__MINGW32__)
  DWORD status;
  int opts = 0;
#endif

  CHECK_TYPE (1, integer_p (pid), zzz_integer_type_name);
#if HAVE_WAITPID
  if (options != zzz_undefined)
    {
      CHECK_TYPE (2, integer_p (options), zzz_integer_type_name);
      opts = integer_val (options);
    }
  else
    opts = 0;
  rpid = waitpid (integer_val (pid), &status, opts);
  *result = zzz_cons (zzz_make_integer (rpid), zzz_make_integer (status));
  return RESULT_SUCCESS;
#elif defined (__MINGW32__)
  if (options != zzz_undefined)
    {
      CHECK_TYPE (2, integer_p (options), zzz_integer_type_name);
      opts = integer_val (options);
    }
  status = WaitForSingleObject ((HANDLE) integer_val (pid), 
				opts & WNOHANG ? 1 : INFINITE);
  switch (status)
    {
      /* no child signalled */
    case WAIT_TIMEOUT:
      *result = zzz_cons (zzz_make_integer (0), zzz_make_integer (0));
      return RESULT_SUCCESS;
      /* child signalled */
    case WAIT_OBJECT_0:
      *result = zzz_cons (zzz_make_integer (integer_val (pid)), 
			  zzz_make_integer (0));
      CloseHandle ((HANDLE) integer_val (pid));
      return RESULT_SUCCESS;
      /* invalid process handle */
    case WAIT_FAILED:
    default:
      break;
    }
  *result = zzz_make_system_exception ();
  return RESULT_EXCEPTION;
#else /* __MINGW32__ */
  *result = zzz_make_not_available_exception
    (zzz_make_symbol (s_func_name, -1));
  return RESULT_EXCEPTION;
#endif /* !HAVE_WAITPID && !__MINGW32__ */
}
#undef FUNC_NAME

/*:doc
  kill
  (kill pid sig) => 
  Sends any signal to any process group or process.  If @var{pid} is
  positive, then signal @var{sig} is sent to @var{pid}.
  If @var{pid} equals 0, then @var{sig} is sent to every process in the
  process group of the current process.  If @var{pid} equals -1, then
  @var{sig} is sent to every process except for the first one, from higher
  numbers in the process table to lower.  If @var{pid} is less than -1,
  then @var{sig} is sent to every process in the process group -@var{pid}.
  If @var{sig} is 0, then no signal is sent, but error checking is still
  performed.
  This function may raise a @code{system-error} exception if an error
  occurs.
  doc:*/
#define FUNC_NAME "kill"
static result_t
kill_func (zzz_scm_t env, zzz_scm_t pid, zzz_scm_t signal, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, integer_p (pid), zzz_integer_type_name);
  CHECK_TYPE (2, integer_p (signal), zzz_integer_type_name);
#if HAVE_KILL
  if (kill (integer_val (pid), integer_val (signal)) == -1)
    {
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
#elif defined (__MINGW32__)
  if (integer_val (pid) == getpid ())
    {
      /*
       * valid arguments are:
       * SIGABRT SIGFPE SIGILL SIGINT SIGSEGV SIGTERM SIGBREAK
       */
      if (raise (integer_val (signal)) != 0)
	{
	  *result = zzz_make_system_exception ();
	  return RESULT_EXCEPTION;
	}
    }
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
#else /* __MINGW32__ */
  *result = zzz_make_not_available_exception
    (zzz_make_symbol (s_func_name, -1));
  return RESULT_EXCEPTION;
#endif /* !HAVE_KILL && !__MINGW32__ */
}
#undef FUNC_NAME

/*:doc
  sleep
  (sleep n) => integer
  Suspend the running process for @var{n} seconds, or until a signal wakes
  up the process.  This function may raise a @code{system-error} exception
  if an error occurs.
  doc:*/
#define FUNC_NAME "sleep"
static result_t
sleep_func (zzz_scm_t env, zzz_scm_t secs, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, integer_p (secs), zzz_integer_type_name);
#ifdef __MINGW32__
  Sleep (integer_val (secs) * 1000);
  *result = zzz_make_integer (0);
#else /* !__MINGW32__ */
  *result = zzz_make_integer (sleep (integer_val (secs)));
#endif /* !__MINGW32__ */
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

static char **
get_argument_vector (char * funcname, zzz_scm_t list, zzz_scm_t * result,
		     int * length)
{
  int len, i;
  char ** args;

  if ((len = zzz_list_length (list)) < 0)
    {
      *result = zzz_make_wta_exception
	(zzz_make_list
	 (zzz_make_string (_("inproper list in call to `"), -1),
	  zzz_make_string (funcname, -1),
	  zzz_make_string ("'", -1),
	  NULL));
      return NULL;
    }
  args = zzz_malloc ((len + 1) * sizeof (char *));
  i = 0;
  while (cons_p (list))
    {
      if (!string_p (car (list)))
	{
	  *result = zzz_make_wta_exception
	    (zzz_make_list
	     (zzz_make_string (_("invalid argument list in call to `"), -1),
	      zzz_make_string (funcname, -1),
	      zzz_make_string ("'", -1),
	      NULL));
	  zzz_free (args, (len + 1) * sizeof (char *));
	  return NULL;
	}
      args[i++] = string_val (car (list));
      list = cdr (list);
    }
  args[i] = NULL;
  *length = len + 1;
  return args;
}

/*:doc
  execl
  (execl filename args) => *no-return*
  Execute the file @var{filename}, passing the list @var{args} as command
  line options.  This function may raise a @code{system-error} exception
  if an error occurs.  It will not return if it is successful, because the
  new process overlays the old one.
  doc:*/
#define FUNC_NAME "execl"
static result_t
execl_func (zzz_scm_t env, zzz_scm_t filename, zzz_scm_t arglist,
	    zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  char ** args;
  int length;

  CHECK_TYPE (1, string_p (filename), zzz_string_type_name);
  CHECK_SAFE_FILENAME (1, filename, zzz_safe_filename_type_name);
  CHECK_TYPE (2, list_p (arglist), zzz_list_type_name);
  args = get_argument_vector (s_func_name, arglist, result, &length);
  if (!args)
    return RESULT_EXCEPTION;
  if (execv (string_val (filename), args) == -1)
    {
      zzz_free (args, length * sizeof (char *));
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
  /* NOT REACHED */
  zzz_free (args, length * sizeof (char *));
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  execlp
  (execlp filename args) => *no-return*
  Like @code{execl}, but search the path for @var{filename}.  This
  function may raise a @code{system-error} exception if an error
  occurs.  It will not return if it is successful, because the new
  process overlays the old one.
  doc:*/
#define FUNC_NAME "execlp"
static result_t
execlp_func (zzz_scm_t env, zzz_scm_t filename, zzz_scm_t arglist,
	     zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  char ** args;
  int length;

  CHECK_TYPE (1, string_p (filename), zzz_string_type_name);
  CHECK_SAFE_FILENAME (1, filename, zzz_safe_filename_type_name);
  CHECK_TYPE (2, list_p (arglist), zzz_list_type_name);
  args = get_argument_vector (s_func_name, arglist, result, &length);
  if (!args)
    return RESULT_EXCEPTION;
  if (execvp (string_val (filename), args) == -1)
    {
      zzz_free (args, length * sizeof (char *));
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
  /* NOT REACHED */
  zzz_free (args, length * sizeof (char *));
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  execle
  (execle filename args env) => *no-return*
  Like @code{execl}, but pass the environment list @var{env} together
  with the command line arguments @var{args} to the process.  This
  function may raise a @code{system-error} exception if an error
  occurs.  It will not return if it is successful, because the new
  process overlays the old one.
  doc:*/
#define FUNC_NAME "execle"
static result_t
execle_func (zzz_scm_t env, zzz_scm_t filename, zzz_scm_t arglist,
	     zzz_scm_t environ, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  char ** args;
  char ** envs;
  int alength, elength;

  CHECK_TYPE (1, string_p (filename), zzz_string_type_name);
  CHECK_SAFE_FILENAME (1, filename, zzz_safe_filename_type_name);
  CHECK_TYPE (2, list_p (arglist), zzz_list_type_name);
  CHECK_TYPE (3, list_p (environ), zzz_list_type_name);
  args = get_argument_vector (s_func_name, arglist, result, &alength);
  if (!args)
    return RESULT_EXCEPTION;
  envs = get_argument_vector (s_func_name, environ, result, &elength);
  if (!envs)
    {
      zzz_free (args, alength * sizeof (char *));
      return RESULT_EXCEPTION;
    }
  if (execve (string_val (filename), args, envs) == -1)
    {
      zzz_free (args, alength * sizeof (char *));
      zzz_free (envs, elength * sizeof (char *));
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
  /* NOT REACHED */
  zzz_free (args, alength * sizeof (char *));
  zzz_free (envs, elength * sizeof (char *));
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  nice
  (nice inc) => *unspecified*
  Change the current process priority by amount @var{inc}.  You must be
  the system administrator to pass a negative @var{inc}.  This function
  may raise a @code{system-error} exception if an error occurs.
  doc:*/
#define FUNC_NAME "nice"
static result_t
nice_func (zzz_scm_t env, zzz_scm_t val, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, integer_p (val), zzz_integer_type_name);
#if HAVE_NICE
  if (nice (integer_val (val)) == -1)
    {
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
#else /* !HAVE_NICE */
  *result = zzz_make_not_available_exception
    (zzz_make_symbol (s_func_name, -1));
  return RESULT_EXCEPTION;
#endif /* !HAVE_NICE */
}
#undef FUNC_NAME

/*:doc
  sync
  (sync) => *unspecified*
  Force all dirty block from the cache of the operating system to be
  written to the disks.  This function may raise a @code{system-error}
  exception if an error occurs.
  doc:*/
#define FUNC_NAME "sync"
static result_t
sync_func (zzz_scm_t env, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

#if HAVE_SYNC
  /* sync() has no return value under Solaris.  Since it is not very
     useful anyway, ignore it.  */
  sync ();
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
#else /* !HAVE_SYNC */
  *result = zzz_make_not_available_exception
    (zzz_make_symbol (s_func_name, -1));
  return RESULT_EXCEPTION;
#endif /* !HAVE_SYNC */
}
#undef FUNC_NAME

#ifdef __MINGW32__ 

#ifndef HAVE_SYS_UTSNAME_H

#define _UTSNAME_LENGTH 65
#ifndef _UTSNAME_NODENAME_LENGTH
# define _UTSNAME_NODENAME_LENGTH _UTSNAME_LENGTH
#endif

struct utsname
{
  /* Name of the implementation of the operating system.  */
  char sysname[_UTSNAME_LENGTH];

  /* Name of this node on the network.  */
  char nodename[_UTSNAME_NODENAME_LENGTH];

  /* Current release level of this implementation.  */
  char release[_UTSNAME_LENGTH];
  /* Current version level of this release.  */
  char version[_UTSNAME_LENGTH];

  /* Name of the hardware type the system is running on.  */
  char machine[_UTSNAME_LENGTH];
};

#endif /* not HAVE_SYS_UTSNAME_H */

/*
 * Simple implementation of POSIX's uname() for Win32.
 */
int
uname (struct utsname *uts)
{
  enum { WinNT, Win95, Win98, WinUnknown};
  OSVERSIONINFO osver;
  SYSTEM_INFO sysinfo;
  DWORD sLength;
  DWORD os = WinUnknown;

  memset (uts, 0, sizeof (*uts));

  osver.dwOSVersionInfoSize = sizeof (osver);
  GetVersionEx (&osver);
  GetSystemInfo (&sysinfo);

  switch (osver.dwPlatformId)
    {
    case VER_PLATFORM_WIN32_NT: /* NT or Windows 2000 */
      if (osver.dwMajorVersion == 4)
        strcpy (uts->sysname, "Windows NT4x"); /* NT4x */
      else if (osver.dwMajorVersion <= 3)
        strcpy (uts->sysname, "Windows NT3x"); /* NT3x */
      else if (osver.dwMajorVersion == 5)
        strcpy (uts->sysname, "Windows 2000"); /* 2k */
      os = WinNT;
      break;

    case VER_PLATFORM_WIN32_WINDOWS: /* Win95, Win98 or WinME */
      if ((osver.dwMajorVersion > 4) || 
          ((osver.dwMajorVersion == 4) && (osver.dwMinorVersion > 0)))
        {
	  if (osver.dwMinorVersion >= 90)
	    strcpy (uts->sysname, "Windows ME"); /* ME */
	  else
	    strcpy (uts->sysname, "Windows 98"); /* 98 */
          os = Win98;
        }
      else
        {
          strcpy (uts->sysname, "Windows 95"); /* 95 */
          os = Win95;
        }
      break;

    case VER_PLATFORM_WIN32s: /* Windows 3.x */
      strcpy (uts->sysname, "Windows");
      break;
    }

  sprintf (uts->version, "%d.%02d", 
	   osver.dwMajorVersion, osver.dwMinorVersion);

  if (osver.szCSDVersion[0] != '\0' &&
      (strlen (osver.szCSDVersion) + strlen (uts->version) + 1) < 
      sizeof (uts->version))
    {
      strcat (uts->version, " ");
      strcat (uts->version, osver.szCSDVersion);
    }

  sprintf (uts->release, "Build %d", osver.dwBuildNumber & 0xFFFF);

#ifdef SYSINFO_UNION
  switch (sysinfo.u.s.wProcessorArchitecture)
#else
  switch (sysinfo.wProcessorArchitecture)
#endif
    {
    case PROCESSOR_ARCHITECTURE_PPC:
      strcpy (uts->machine, "ppc");
      break;
    case PROCESSOR_ARCHITECTURE_ALPHA:
      strcpy (uts->machine, "alpha");
      break;
    case PROCESSOR_ARCHITECTURE_MIPS:
      strcpy (uts->machine, "mips");
      break;
    case PROCESSOR_ARCHITECTURE_INTEL:
      /* 
       * dwProcessorType is only valid in Win95 and Win98 and WinME
       * wProcessorLevel is only valid in WinNT 
       */
      switch (os)
        {
        case Win95:
        case Win98:
          switch (sysinfo.dwProcessorType)
            {
            case PROCESSOR_INTEL_386:
            case PROCESSOR_INTEL_486:
            case PROCESSOR_INTEL_PENTIUM:
              sprintf (uts->machine, "i%d", sysinfo.dwProcessorType);
              break;
            default:
              strcpy (uts->machine, "i386");
              break;
          }
          break;
        case WinNT:
          sprintf (uts->machine, "i%d86", sysinfo.wProcessorLevel);
          break;
        default:
          strcpy (uts->machine, "unknown");
          break;
      }
      break;
    default:
      strcpy (uts->machine, "unknown");
      break;
  }
  
  sLength = sizeof (uts->nodename) - 1;
  GetComputerName (uts->nodename, &sLength);
  return 0;
}
#endif /* __MINGW32__ */

/*:doc
  uname
  (uname) => vector
  Return a vector containing information about the system. This
  function may raise a @code{system-error} exception if an error
  occurs.  The returned vector contains the following fields: sysname,
  nodename, release, version, machine.
  doc:*/
#define FUNC_NAME "uname"
static result_t
uname_func (zzz_scm_t env, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t res;

#if HAVE_UNAME || defined(__MINGW32__)
  struct utsname utsname;

  if (uname (&utsname) == -1)
    {
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
  res = zzz_make_vector (5);
  zzz_vector_put (res, 0, zzz_make_string (utsname.sysname, -1));
  zzz_vector_put (res, 1, zzz_make_string (utsname.nodename, -1));
  zzz_vector_put (res, 2, zzz_make_string (utsname.release, -1));
  zzz_vector_put (res, 3, zzz_make_string (utsname.version, -1));
  zzz_vector_put (res, 4, zzz_make_string (utsname.machine, -1));
  *result = res;
  return RESULT_SUCCESS;
#else /* !(HAVE_UNAME || defined(__MINGW32__)) */
  *result = zzz_make_not_available_exception
    (zzz_make_symbol (s_func_name, -1));
  return RESULT_EXCEPTION;
#endif /* !(HAVE_UNAME || defined(__MINGW32__)) */
}
#undef FUNC_NAME

/*:doc
  utime
  (utime filename [timelist]) => *unspecified*
  If @var{timelist} is omitted, set the access and modification time for
  the file @var{filename} to the current time.  Otherwise, @var{timelist}
  must be a list of two integer values, which will be used to set the
  access and modification time of @var{filename}.  This function may raise
  a @code{system-error} exception if an error occurs.
  doc:*/
#define FUNC_NAME "utime"
static result_t
utime_func (zzz_scm_t env, zzz_scm_t filename, zzz_scm_t timelist,
	    zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  struct utimbuf utimbuf;
  int res;

  CHECK_TYPE (1, string_p (filename), zzz_string_type_name);
  CHECK_SAFE_FILENAME (1, filename, zzz_safe_filename_type_name);
  if (timelist != zzz_undefined)
    {
      CHECK_TYPE (2, list_p (timelist) && zzz_list_length (timelist) == 2,
		  _("proper utime list"));
      CHECK_TYPE (2, integer_p (car (timelist)), _("proper utime list"));
      CHECK_TYPE (2, integer_p (car (cdr (timelist))), _("proper utime list"));
    }
  else
    timelist = NULL;
  if (timelist)
    {
      utimbuf.actime = integer_val (car (timelist));
      utimbuf.modtime = integer_val (car (cdr (timelist)));
      res = utime (string_val (filename), &utimbuf);
    }
  else
    res = utime (string_val (filename), NULL);
  if (res == -1)
    {
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  tmpnam
  (tmpnam) => string
  The @code{tmpnam} procedure generates a unique temporary filename in the
  standard directory for temporary files (normally @file{/tmp}).
  doc:*/
#define FUNC_NAME "tmpnam"
static result_t
tmpnam_func (zzz_scm_t env, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  
#if HAVE_TMPNAM
  char * s;

  s = tmpnam (NULL);
  if (!s)
    {
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
  *result = zzz_make_string (s, -1);
  return RESULT_SUCCESS;
#else /* !HAVE_TMPNAM */
  *result = zzz_make_not_available_exception
    (zzz_make_symbol (s_func_name, -1));
  return RESULT_EXCEPTION;
#endif /* !HAVE_TMPNAM */
}
#undef FUNC_NAME

/*:doc
  tmpfile
  (tmpfile) =>  port
  The @code{tmpfile} procedure generates a unique temporary filename in
  the standard directory for temporary files (normally @file{/tmp}) .  The
  temporary file is then opened in binary read/write (w+b) mode.  The file
  will be automatically deleted when it is closed or the program
  terminates.  The return value is a port open for input and output.  This
  function may raise a @code{system-error} exception if an error occurs.
  doc:*/
#define FUNC_NAME "tmpfile"
static result_t
tmpfile_func (zzz_scm_t env, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

#if HAVE_TMPFILE
  FILE * f;
  
  f = tmpfile ();
  if (!f)
    {
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
  *result = zzz_make_fport (f, 1, 1);
  return RESULT_SUCCESS;
#else /* !HAVE_TMPFILE */
  *result = zzz_make_not_available_exception
    (zzz_make_symbol (s_func_name, -1));
  return RESULT_EXCEPTION;
#endif /* !HAVE_TMPFILE */
}
#undef FUNC_NAME

/*:doc
  umask
  (umask [mask]) => integer
  @code{umask} sets the umask to @code{(logand mask #o777)}.  The
  umask is used by open(2) to set initial file permissions on a
  newly-created file.  Specifically, permissions in the umask are
  turned off from the mode argument to open(2) (so, for example, the
  common umask default value of 022 results in new files being created
  with permissions 0666 & ~022 = 0644 = rw-r--r-- in the usual case
  where the mode is specified as 0666).  If @var{mask} is not given,
  the current umask value is returned, without changing the umask for
  the process.
  doc:*/
#define FUNC_NAME "umask"
static result_t
umask_func (zzz_scm_t env, zzz_scm_t mask, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  if (undefined_p (mask))
    {
      int msk = umask (0);
      umask (msk);
      *result = zzz_make_integer (msk);
    }
  else
    {
      CHECK_TYPE (1, integer_p (mask), zzz_integer_type_name);
      *result = zzz_make_integer (umask (integer_val (mask)));
    }
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/* Convert a value of `struct tm', passed in as TIME to a Scheme
   vector holding the components of the struct.  */
static zzz_scm_t
tm_to_vector (struct tm *time, int zoff, char * zname)
{
  zzz_scm_t result = zzz_make_vector (11);

  zzz_vector_put (result, 0, zzz_make_integer (time->tm_sec));
  zzz_vector_put (result, 1, zzz_make_integer (time->tm_min));
  zzz_vector_put (result, 2, zzz_make_integer (time->tm_hour));
  zzz_vector_put (result, 3, zzz_make_integer (time->tm_mday));
  zzz_vector_put (result, 4, zzz_make_integer (time->tm_mon));
  zzz_vector_put (result, 5, zzz_make_integer (time->tm_year));
  zzz_vector_put (result, 6, zzz_make_integer (time->tm_wday));
  zzz_vector_put (result, 7, zzz_make_integer (time->tm_yday));
  zzz_vector_put (result, 8, zzz_make_integer (time->tm_isdst));
  zzz_vector_put (result, 9, zzz_make_integer (zoff));
  zzz_vector_put (result, 10,
		  zname ? zzz_make_string (zname, -1) : zzz_false_value);
  return result;
}

/*:doc
  strptime
  (strptime format string) => pair
  Parse the string @var{string} according to the format specifier
  @var{format}.  Check out @code{man strptime} for the format
  specification.  Returns a pair consisting of a time vector and the
  number of characters of @var{string} which have been used up when
  parsing.  This procedure is essentialy the counterpart of
  @code{strftime}.
  doc:*/
#define FUNC_NAME "strptime"
static result_t
strptime_func (zzz_scm_t env, zzz_scm_t format, zzz_scm_t string,
	       zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

#if HAVE_STRPTIME
  struct tm t;
  char * rest;

  CHECK_TYPE (1, string_p (format), zzz_string_type_name);
  CHECK_TYPE (2, string_p (string), zzz_string_type_name);
  t.tm_sec = 0;
  t.tm_min = 0;
  t.tm_hour = 0;
  t.tm_mday = 0;
  t.tm_mon = 0;
  t.tm_year = 0;
  t.tm_wday = 0;
  t.tm_yday = 0;
  t.tm_isdst = -1;
  if ((rest = strptime (string_val (string), string_val (format), &t)) == NULL)
    {
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
  *result = zzz_cons (tm_to_vector (&t, 0, NULL),
		      zzz_make_integer (rest - string_val (string)));
  return RESULT_SUCCESS;
#else /* !HAVE_STRPTIME */
  *result = zzz_make_not_available_exception
    (zzz_make_symbol (s_func_name, -1));
  return RESULT_EXCEPTION;
#endif /* !HAVE_STRPTIME */
}
#undef FUNC_NAME

result_t
scheme_to_tm (zzz_scm_t timevec, struct tm * t, char * func_name,
	      zzz_scm_t * result)
{
  zzz_scm_t * velts;
  int i;

  if (!vector_p (timevec) || vector_len (timevec) != 11)
    {
      *result = zzz_make_wta_exception
	(zzz_make_list (zzz_make_string ("invalid time vector in call to `",
					 -1),
			zzz_make_string (func_name, -1),
			zzz_make_string ("'", -1),
			NULL));
      return RESULT_EXCEPTION;
    }
  velts = vector_val (timevec);
  for (i = 0; i < 10; i++)
    if (!integer_p (velts[i]))
      {
	*result = zzz_make_wta_exception
	  (zzz_make_list (zzz_make_string ("invalid time vector in call to `",
					   -1),
			  zzz_make_string (func_name, -1),
			  zzz_make_string ("'", -1),
			  NULL));
	return RESULT_EXCEPTION;
      }
  if (!bool_p (velts[10]) && !string_p (velts[10]))
    {
      *result = zzz_make_wta_exception
	(zzz_make_list (zzz_make_string ("invalid time vector in call to `",
					 -1),
			zzz_make_string (func_name, -1),
			zzz_make_string ("'", -1),
			NULL));
      return RESULT_EXCEPTION;
    }
  t->tm_sec = integer_val (velts[0]);
  t->tm_min = integer_val (velts[1]);
  t->tm_hour = integer_val (velts[2]);
  t->tm_mday = integer_val (velts[3]);
  t->tm_mon = integer_val (velts[4]);
  t->tm_year = integer_val (velts[5]);
  t->tm_wday = integer_val (velts[6]);
  t->tm_yday = integer_val (velts[7]);
  t->tm_isdst = integer_val (velts[8]);
  return RESULT_SUCCESS;
}

/*:doc
  strftime
  (strftime format vec) => string
  Format the time-representing vector @var{vec} according to the format
  specifier @var{format} to a string and return that string.  For details
  of the format specified, have a look at @code{man strftime}.
  doc:*/
#define FUNC_NAME "strftime"
static result_t
strftime_func (zzz_scm_t env, zzz_scm_t format, zzz_scm_t vec,
	       zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

#if HAVE_STRFTIME
  result_t err;
  struct tm t;
  int len = 0, size = 64;
  char * buf;

  CHECK_TYPE (1, string_p (format), zzz_string_type_name);
  CHECK_TYPE (2, vector_p (vec), zzz_vector_type_name);
  if ((err = scheme_to_tm (vec, &t, s_func_name, result)) != RESULT_SUCCESS)
    return err;
  buf = zzz_malloc (size);
  while ((len = strftime (buf, size, string_val (format), &t)) == size)
    {
      zzz_free (buf, size);
      size *= 2;
      buf = zzz_malloc (size);
    }
  *result = zzz_make_string (buf, len);
  zzz_free (buf, size);
  return RESULT_SUCCESS;
#else /* !HAVE_STRFTIME */
  *result = zzz_make_not_available_exception
    (zzz_make_symbol (s_func_name, -1));
  return RESULT_EXCEPTION;
#endif /* !HAVE_STRFTIME */
}
#undef FUNC_NAME

/*:doc
  gmtime
  (gmtime x) => vector
  Split up the time object @var{x}, which represents the current time
  in standard Unix convention in seconds since January 1, 1970.
  Returns a vector with the split up fields of the time.  The times in
  the vector is in Coordinated Universal Time. The result vector
  contains the following fields: seconds, minutes, hours, day of
  month, month, year, day of the week, day in the year, daylight
  saving time, time zone offset, time zone name or @code{#f} if not
  specified.
  doc:*/
#define FUNC_NAME "gmtime"
static result_t
gmtime_func (zzz_scm_t env, zzz_scm_t time, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  struct tm * t;
  time_t itime;
  
  CHECK_TYPE (1, integer_p (time), zzz_integer_type_name);
  itime = integer_val (time);
  t = gmtime (&itime);
  if (t == NULL)
    {
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
  *result = tm_to_vector (t, 0, "GMT");
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  localtime
  (localtime x) => vector
  Returns @var{x} converted to local time in a vector of the format
  defined in the description of @code{gmtime}.
  Bug: Right now time zone offset and time zone names are not correctly
  set by @code{localtime}.
  doc:*/
#define FUNC_NAME "localtime"
static result_t
localtime_func (zzz_scm_t env, zzz_scm_t time, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  struct tm * t;
  time_t itime;
  
  CHECK_TYPE (1, integer_p (time), zzz_integer_type_name);
  itime = integer_val (time);
  t = localtime (&itime);
  if (t == NULL)
    {
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
  *result = tm_to_vector (t, 0, "GMT");
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  current-time
  (current-time) => integer
  Return the current time in an integer, represented in the number of
  seconds elapsed since 00:00:00 on January 1, 1970, Coordinated Universal
  Time (UTC).  The value returned by this procedure can be used in calls
  to @code{gmtime} or @code{localtime}, which split up the time value into
  its various parts.
  doc:*/
#define FUNC_NAME "current-time"
static result_t
current_time_func (zzz_scm_t env, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  time_t t;

  if ((t = time (0)) < 0)
    {
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
  *result = zzz_make_integer (t);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

#ifdef __MINGW32__
static WIN32_FIND_DATA dir_entry;
#endif

/*:doc
  directory-files
  (directory-files [dirname]) => list
  Return a list containing all files in the directory @var{dirname}.  This
  procedure may throw a @code{system-error} exception if an error occurs.
  doc:*/
#define FUNC_NAME "directory-files"
static result_t
directory_files_func (zzz_scm_t env, zzz_scm_t dirname, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  zzz_scm_t res = NULL;
  zzz_scm_t * resp = &res;
#ifndef __MINGW32__
  DIR *dir;
  struct dirent *dent = NULL;
#else
  HANDLE dir;
  WIN32_FIND_DATA dent;
  char tmp[MAX_PATH];
#endif

  CHECK_TYPE (1, string_p (dirname), zzz_string_type_name);
  CHECK_SAFE_FILENAME (1, dirname, zzz_safe_filename_type_name);
#ifdef __MINGW32__
  strcpy (tmp, string_val (dirname));
  strcat (tmp, "/*");
  if ((dir = FindFirstFile (tmp, &dent)) == 
      INVALID_HANDLE_VALUE)
#else
  if (!(dir = opendir (string_val (dirname))))
#endif
    {
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
#ifndef __MINGW32__
  while ((dent = readdir (dir)))
#else
  do
#endif
    {
      *resp = zzz_cons (zzz_make_string (FILENAME(dent), -1), NULL);
      resp = cdr_addr (*resp);
    }
#ifdef __MINGW32__
  while (FindNextFile (dir, &dent));
#endif
  closedir (dir);
  *result = res;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

#ifdef __MINGW32__

#define F_DUPFD  0
#define F_GETFD  1
#define F_SETFD  2
#define F_GETFL  3
#define F_SETFL  4
#define F_GETLK  5
#define F_SETLK  6
#define F_SETLKW 7
#define F_SETOWN 8
#define F_GETOWN 9

#define O_NONBLOCK 04000
#define O_NDELAY   O_NONBLOCK
#define O_ASYNC    020000

/* 
 * Kind of dummy implementation of fcntl () in Win32. Use with 
 * sockets only.
 */
static int
fcntl (int fd, int cmd, long arg)
{
  unsigned long opt = 1;
  
  if (cmd == F_SETFL)
    {
      if (arg & (O_NONBLOCK | O_NDELAY))
	{
	  if (ioctlsocket (fd, FIONBIO, &opt) == SOCKET_ERROR)
	    return -1;
	  return 0;
	}
      if (arg & O_ASYNC)
	{
	  if (ioctlsocket (fd, FIOASYNC, &opt) == SOCKET_ERROR)
	    return -1;
	  return 0;
	}
    }

  errno = EINVAL;
  return -1;
}
#endif /* __MINGW32__ */

/*:doc
  fcntl
  (fcntl fd cmd [arg]) => integer
  @code{fcnt} performs one of various operations on the file descriptor
  @var{fd}.  Refer to the Sizzle reference manual and the @code{fcntl} 
  man page for the possible commands and more information.
  doc:*/
#define FUNC_NAME "fcntl"
static result_t
fcntl_func (zzz_scm_t env, zzz_scm_t fdesc, zzz_scm_t cmd, zzz_scm_t argument,
	    zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  int arg;
  int ret;

  CHECK_TYPE (1, integer_p (fdesc), _("file descriptor"));
  CHECK_TYPE (2, integer_p (cmd), zzz_integer_type_name);
#if defined (HAVE_FCNTL) || defined (__MINGW32__)
  if (undefined_p (argument))
    arg = 0;
  else
    {
      CHECK_TYPE (3, integer_p (argument), zzz_integer_type_name);
      arg = integer_val (argument);
    }
  if ((ret = fcntl (integer_val (fdesc), integer_val (cmd), arg)) == -1)
    {
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
  *result = zzz_make_integer (ret);
  return RESULT_SUCCESS;
#else /* !(HAVE_FCNTL || defined (__MINGW32__)) */
  *result = zzz_make_not_available_exception
    (zzz_make_symbol (s_func_name, -1));
  return RESULT_EXCEPTION;
#endif /* !(HAVE_FCNTL || defined (__MINGW32__)) */
}
#undef FUNC_NAME

#ifdef __MINGW32__
#define fsync(fd) _commit (fd)
#endif /* __MINGW32__ */

/*:doc
  fsync
  (fsync fdesc) => *unspecified*
  @var{fdesc} must be either a valid file descripor or a file port.
  All pending output is written if @var{fdesc} is a file port.  The
  data buffered for the underlying file descriptor is then forced to
  be written to disk using the system call @code{fsync}.
  doc:*/
#define FUNC_NAME "fsync"
static result_t
fsync_func (zzz_scm_t env, zzz_scm_t fdesc, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
#if HAVE_FSYNC || defined (__MINGW32__)
  int fd;
  result_t err;
#endif /* !(HAVE_FSYNC || defined (__MINGW32)) */

  CHECK_TYPE (1, integer_p (fdesc) || fdport_p (fdesc),
	      _("file descriptor or file port"));
#if HAVE_FSYNC || defined (__MINGW32__)
  if (integer_p (fdesc))
    fd = integer_val (fdesc);
  else if (fdport_p (fdesc))
    {
      fd = fdport_fd (fdesc);
      if ((err = zzz_port_flush (fdesc, result)) != RESULT_SUCCESS)
	return err;
    }
  else
    abort ();			/* Sanity check.  */
  if (fsync (fd) == -1)
    {
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
#else /* !(HAVE_FSYNC || defined (__MINGW32)) */
  *result = zzz_make_not_available_exception
    (zzz_make_symbol (s_func_name, -1));
  return RESULT_EXCEPTION;
#endif /* !(HAVE_FSYNC || defined (__MINGW32)) */
}
#undef FUNC_NAME

/*:doc
  copy-file
  (copy-file oldfile newfile) => *unspecified*
  Copy the file specified by @var{path-from} to @var{path-to}.  The
  return value is unspecified.
  doc:*/
#define FUNC_NAME "copy-file"
static result_t
copy_file (zzz_scm_t env, zzz_scm_t oldfile, zzz_scm_t newfile,
	   zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  struct stat oldstat;
  int n;
  char buf[BUFSIZ];
  int oldfd;
  int newfd;

  CHECK_TYPE (1, string_p (oldfile), zzz_string_type_name);
  CHECK_TYPE (2, string_p (newfile), zzz_string_type_name);

  if (stat (string_val (oldfile), &oldstat) == -1)
    {
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
  if ((oldfd = open (string_val (oldfile), O_RDONLY | O_BINARY)) == -1)
    {
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }

  /* use POSIX flags instead of 07777?.  */
  if ((newfd = open (string_val (newfile), 
		     O_WRONLY | O_CREAT | O_TRUNC | O_BINARY,
		     oldstat.st_mode & 07777)) == -1)
    {
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }

  while ((n = read (oldfd, buf, sizeof (buf))) > 0)
    {
      if (write (newfd, buf, n) != n)
	{
	  close (oldfd);
	  close (newfd);
	  *result = zzz_make_system_exception ();
	  return RESULT_EXCEPTION;
	}
    }
  close (oldfd);
  if (close (newfd) == -1)
    {
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

zzz_scm_t
#ifdef __MINGW32__
zzz_make_dir_stream (HANDLE dir)
#else
zzz_make_dir_stream (DIR * dir)
#endif
{
  return zzz_create_tagged_cell (zzz_tagged_type_dir_stream, dir, NULL, NULL);
}

static void *
dir_stream_constructor (zzz_tagged_t tagged, void * data0,
			void * data1, void * data2)
{
  tagged->fill[1] = (zzz_object_t) data0;
  tagged->fill[2] = 1;
  return tagged;
}

static void
dir_stream_print (zzz_scm_t port, zzz_tagged_t tagged, zzz_print_state_t state)
{
  zzz_scm_t result;
#ifdef __MINGW32__
  HANDLE dir = tagged_data0 (tagged);
#else
  DIR * dir = tagged_data0 (tagged);
#endif

  zzz_port_puts (port, "#<dir-stream:", 13, &result);
  if (tagged_data1 (tagged))
    zzz_port_puts (port, "(open)", 6, &result);
  else
    zzz_port_puts (port, "(closed)", 8, &result);
  zzz_port_puts (port, ">", 1, &result);
}

static void
dir_stream_free (zzz_tagged_t tagged)
{
  if (dir_stream_open_p (tagged))
    closedir (dir_stream_dir (tagged));
}

/*:doc
  directory-stream?
  (directory-stream? obj) => boolean
  Return @code{#t} if @var{obj} is a directory stream, @code{#f} otherwise.
  doc:*/
#define FUNC_NAME "directory-stream?"
result_t
directory_stream_p (zzz_scm_t env, zzz_scm_t obj, zzz_scm_t * result)
{
  if (dir_stream_p (obj))
    *result = zzz_true_value;
  else
    *result = zzz_false_value;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  opendir
  (opendir str) => directory-stream
  Open the directory called @var{str} and return a directory stream for that
  directory, which can be used in calls to @code{readdir}, @code{closedir}
  and @code{rewinddir}.  This procedure may raise a @code{system-error}
  exception if an error occurs.
  doc:*/
#define FUNC_NAME "opendir"
result_t
opendir_func (zzz_scm_t env, zzz_scm_t str, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

#ifdef __MINGW32__
  HANDLE dir;
  char tmp[MAX_PATH];
#else
  DIR * dir;
#endif

  CHECK_TYPE (1, string_p (str), zzz_string_type_name);
  CHECK_SAFE_FILENAME (1, str, zzz_safe_filename_type_name);
#ifdef __MINGW32__
  strcpy (tmp, string_val (str));
  strcat (tmp, "/*");
  dir = FindFirstFile (tmp, &dir_entry);
  if (dir == INVALID_HANDLE_VALUE)
#else
  dir = opendir (string_val (str));
  if (!dir)
#endif
    {
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
  *result = zzz_make_dir_stream (dir);
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  closedir
  (closedir stream) => *unspecified*
  Close the directory stream @var{stream}.  The return value is not
  specified.
  doc:*/
#define FUNC_NAME "closedir"
result_t
closedir_func (zzz_scm_t env, zzz_scm_t stream, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, dir_stream_p (stream), _("directory stream"));
  dir_stream_open_p (stream) = 0;
  closedir (dir_stream_dir (stream));
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  readdir
  (readdir stream) => string
  Return the next filename from the directory stream @var{stream}, or
  the end-of-file object if all files have been read.  This procedure
  may raise a @code{system-error} exception if an error occurs.
  doc:*/
#define FUNC_NAME "readdir"
result_t
readdir_func (zzz_scm_t env, zzz_scm_t stream, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

#ifndef __MINGW32__
  struct dirent * dent;
#endif

  CHECK_TYPE (1, dir_stream_p (stream) && dir_stream_open_p (stream),
	      _("open directory stream"));
#ifndef __MINGW32__
  errno = 0;
  dent = readdir (dir_stream_dir (stream));
  if (errno != 0)
    {
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
  if (dent)
    *result = zzz_make_string (FILENAME(dent), -1);
  else
    *result = zzz_eof_object;
#else
  if (FILENAME(dir_entry)[0])
    *result = zzz_make_string (FILENAME(dir_entry), -1);
  else
    *result = zzz_eof_object;
  if (!FindNextFile (dir_stream_dir (stream), &dir_entry))
    FILENAME(dir_entry)[0] = '\0';
#endif
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  rewinddir
  (rewinddir stream) => string
  Rewind the directory stream to the beginning, so that on the next call
  to @code{readdir}, the first file from the stream will be read.  The
  return value is not specified.
  doc:*/
#define FUNC_NAME "rewinddir"
result_t
rewinddir_func (zzz_scm_t env, zzz_scm_t stream, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

  CHECK_TYPE (1, dir_stream_p (stream) && dir_stream_open_p (stream),
	      _("open directory stream"));

#ifndef __MINGW32__
  rewinddir (dir_stream_dir (stream));
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
#else /* !__MINGW32__ */
  *result = zzz_make_not_available_exception
    (zzz_make_symbol (s_func_name, -1));
  return RESULT_EXCEPTION;
#endif /* !__MINGW32__ */
}
#undef FUNC_NAME

/*:doc
  fileno
  (fileno port) => integer
  doc:*/
#define FUNC_NAME "fileno"
static result_t
fileno_func (zzz_scm_t env, zzz_scm_t port, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;
  
  CHECK_TYPE (1, fdport_p (port), zzz_fdport_type_name);
  *result = zzz_make_integer (fdport_fd (port));
  return RESULT_SUCCESS;
}
#undef FUNC_NAME

/*:doc
  getdrive
  (getdrive) => integer
  (Under Windows) get the current drive number (1 = A, 2 = B, ...).
  doc:*/
#define FUNC_NAME "getdrive"
result_t
getdrive_func (zzz_scm_t env, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

#ifdef __MINGW32__
  /* 1 = A, 2 = B, ... */
  *result = zzz_make_integer (_getdrive ());
  return RESULT_SUCCESS;
#else /* !__MINGW32__ */
  *result = zzz_make_not_available_exception
    (zzz_make_symbol (s_func_name, -1));
  return RESULT_EXCEPTION;
#endif /* __MINGW32__ */
}
#undef FUNC_NAME

/*:doc
  chdrive
  (chdrive drv) => integer
  (Under Windows) set the current drive number to @var{drv}
  (1 = A, 2 = B, ...).  The return value is not specified.
  doc:*/
#define FUNC_NAME "chdrive"
result_t
chdrive_func (zzz_scm_t env, zzz_scm_t drive, zzz_scm_t * result)
{
  static char * s_func_name = FUNC_NAME;

#ifdef __MINGW32__
  CHECK_TYPE (1, integer_p (drive), _("drive number (1=A, 2=B, ...)")); 
  if (_chdrive (integer_val (drive)) != 0)
    {
      *result = zzz_make_system_exception ();
      return RESULT_EXCEPTION;
    }
  *result = zzz_unspecified;
  return RESULT_SUCCESS;
#else /* !__MINGW32__ */
  *result = zzz_make_not_available_exception
    (zzz_make_symbol (s_func_name, -1));
  return RESULT_EXCEPTION;
#endif /* __MINGW32__ */
}
#undef FUNC_NAME

#include "posix-ext.c"

/* Include the automagically generated primitives from `fnmatch.if'.  */
#if HAVE_FNMATCH
# include "fnmatch.c"
#endif /* HAVE_FNMATCH */

#endif /* ENABLE_POSIX */

result_t
zzz_init_posix (void)
{
  /* Define exception for system call errors.  */
  /*:doc
    system-error
    Exception
    Thrown when a system call fails.
    doc:*/
  zzz_protect_global (&zzz_system_error_exception);
  zzz_system_error_exception = zzz_make_symbol ("system-error", -1);

#if ENABLE_POSIX

  zzz_c_create_module ("core posix", &core_posix_module);

  /* Define some constants to be used in system calls.  They
     correspond to the C macros of the same name.  */
#if 0
  zzz_c_define_constant (core_posix_module, "R_OK", zzz_make_integer (R_OK));
  zzz_c_define_constant (core_posix_module, "W_OK", zzz_make_integer (W_OK));
  zzz_c_define_constant (core_posix_module, "X_OK", zzz_make_integer (X_OK));
  zzz_c_define_constant (core_posix_module, "F_OK", zzz_make_integer (F_OK));

  zzz_c_define_constant (core_posix_module, "O_RDONLY",
			 zzz_make_integer (O_RDONLY));
  zzz_c_define_constant (core_posix_module, "O_WRONLY",
			 zzz_make_integer (O_WRONLY));
  zzz_c_define_constant (core_posix_module, "O_RDWR",
			 zzz_make_integer (O_RDWR));
  zzz_c_define_constant (core_posix_module, "O_CREAT",
			 zzz_make_integer (O_CREAT));
  zzz_c_define_constant (core_posix_module, "O_EXCL",
			 zzz_make_integer (O_EXCL));
#ifndef __MINGW32__
  zzz_c_define_constant (core_posix_module, "O_NOCTTY",
			 zzz_make_integer (O_NOCTTY));
  zzz_c_define_constant (core_posix_module, "O_SYNC",
			 zzz_make_integer (O_SYNC));
#endif /* !__MINGW32__ */
  zzz_c_define_constant (core_posix_module, "O_TRUNC",
			 zzz_make_integer (O_TRUNC));
  zzz_c_define_constant (core_posix_module, "O_APPEND",
			 zzz_make_integer (O_APPEND));


  /* Win32: These three are for setting a socket's flag only. */
  zzz_c_define_constant (core_posix_module, "O_NONBLOCK",
			 zzz_make_integer (O_NONBLOCK));
  zzz_c_define_constant (core_posix_module, "O_NDELAY",
			 zzz_make_integer (O_NDELAY));
#ifdef O_ASYNC
  zzz_c_define_constant (core_posix_module, "O_ASYNC",
			 zzz_make_integer (O_ASYNC));
#endif /* defined(O_ASYNC) */

#ifndef __MINGW32__
  zzz_c_define_constant (core_posix_module, "S_ISUID",
			 zzz_make_integer (S_ISUID));
  zzz_c_define_constant (core_posix_module, "S_ISGID",
			 zzz_make_integer (S_ISGID));
  zzz_c_define_constant (core_posix_module, "S_IRWXG",
			 zzz_make_integer (S_IRWXG));
  zzz_c_define_constant (core_posix_module, "S_IRGRP",
			 zzz_make_integer (S_IRGRP));
  zzz_c_define_constant (core_posix_module, "S_IWGRP",
			 zzz_make_integer (S_IWGRP));
  zzz_c_define_constant (core_posix_module, "S_IXGRP",
			 zzz_make_integer (S_IXGRP));
  zzz_c_define_constant (core_posix_module, "S_IROTH",
			 zzz_make_integer (S_IROTH));
  zzz_c_define_constant (core_posix_module, "S_IWOTH",
			 zzz_make_integer (S_IWOTH));
  zzz_c_define_constant (core_posix_module, "S_IXOTH",
			 zzz_make_integer (S_IXOTH));
  zzz_c_define_constant (core_posix_module, "S_IRWXO",
			 zzz_make_integer (S_IRWXO));
#endif /* !__MINGW32__ */
  zzz_c_define_constant (core_posix_module, "S_IRWXU",
			 zzz_make_integer (S_IRWXU));
  zzz_c_define_constant (core_posix_module, "S_IRUSR",
			 zzz_make_integer (S_IRUSR));
  zzz_c_define_constant (core_posix_module, "S_IWUSR",
			 zzz_make_integer (S_IWUSR));
  zzz_c_define_constant (core_posix_module, "S_IXUSR",
			 zzz_make_integer (S_IXUSR));
#endif /* ENABLE_POSIX */
#endif

  /* Define all system specific functions.  */
  zzz_define_function ("getenv", (zzz_prim_t) getenv_func, argv_1_0_0);
#if ENABLE_POSIX
  zzz_c_define_function (core_posix_module, "system",
			 (zzz_prim_t) system_func, argv_0_1_0);
  zzz_c_define_function (core_posix_module, "putenv",
			 (zzz_prim_t) putenv_func, argv_1_0_0);
  zzz_c_define_function (core_posix_module, "getcwd",
			 (zzz_prim_t) getcwd_func, argv_0_0_0);
  zzz_c_define_function (core_posix_module, "chdir",
			 (zzz_prim_t) chdir_func, argv_1_0_0);
  zzz_c_define_function (core_posix_module, "getpid",
			 (zzz_prim_t) getpid_func, argv_0_0_0);
  zzz_c_define_function (core_posix_module, "getppid",
			 (zzz_prim_t) getppid_func, argv_0_0_0);
  zzz_c_define_function (core_posix_module, "getuid",
			 (zzz_prim_t) getuid_func, argv_0_0_0);
  zzz_c_define_function (core_posix_module, "setuid",
			 (zzz_prim_t) setuid_func, argv_1_0_0);
  zzz_c_define_function (core_posix_module, "seteuid",
			 (zzz_prim_t) seteuid_func, argv_1_0_0);
  zzz_c_define_function (core_posix_module, "geteuid",
			 (zzz_prim_t) geteuid_func, argv_0_0_0);
  zzz_c_define_function (core_posix_module, "getgid",
			 (zzz_prim_t) getgid_func, argv_0_0_0);
  zzz_c_define_function (core_posix_module, "setgid",
			 (zzz_prim_t) setgid_func, argv_1_0_0);
  zzz_c_define_function (core_posix_module, "getegid",
			 (zzz_prim_t) getegid_func, argv_0_0_0);
  zzz_c_define_function (core_posix_module, "setegid",
			 (zzz_prim_t) setegid_func, argv_1_0_0);
  zzz_c_define_function (core_posix_module, "getpgid",
			 (zzz_prim_t) getpgid_func, argv_1_0_0);
  zzz_c_define_function (core_posix_module, "getpgrp",
			 (zzz_prim_t) getpgrp_func, argv_0_0_0);
  zzz_c_define_function (core_posix_module, "getpwnam",
			 (zzz_prim_t) getpwnam_func, argv_1_0_0);
  zzz_c_define_function (core_posix_module, "getpwuid",
			 (zzz_prim_t) getpwuid_func, argv_1_0_0);
  /* FIXME: Document us in the reference manual.  */
  zzz_c_define_function (core_posix_module, "getpwent",
			 (zzz_prim_t) getpwent_func, argv_0_0_0);
  zzz_c_define_function (core_posix_module, "setpwent",
			 (zzz_prim_t) setpwent_func, argv_0_0_0);
  zzz_c_define_function (core_posix_module, "endpwent",
			 (zzz_prim_t) endpwent_func, argv_0_0_0);

  zzz_c_define_function (core_posix_module, "getgroups",
			 (zzz_prim_t) getgroups_func, argv_0_0_0);

  zzz_protect_global (&stat_regular_symbol);
  zzz_protect_global (&stat_directory_symbol);
  zzz_protect_global (&stat_symlink_symbol);
  zzz_protect_global (&stat_block_special_symbol);
  zzz_protect_global (&stat_char_special_symbol);
  zzz_protect_global (&stat_fifo_symbol);
  zzz_protect_global (&stat_socket_symbol);
  zzz_protect_global (&stat_unknown_symbol);

  stat_regular_symbol = zzz_make_symbol ("regular", -1);
  stat_directory_symbol = zzz_make_symbol ("directory", -1);
  stat_symlink_symbol = zzz_make_symbol ("symlink", -1);
  stat_block_special_symbol = zzz_make_symbol ("block-special", -1);
  stat_char_special_symbol = zzz_make_symbol ("char-special", -1);
  stat_fifo_symbol = zzz_make_symbol ("fifo", -1);
  stat_socket_symbol = zzz_make_symbol ("socket", -1);
  stat_unknown_symbol = zzz_make_symbol ("unknown", -1);
  zzz_c_define_function (core_posix_module, "stat", (zzz_prim_t) stat_func,
			 argv_1_0_0);
  zzz_c_define_function (core_posix_module, "lstat", (zzz_prim_t) lstat_func,
			 argv_1_0_0);
  zzz_c_define_function (core_posix_module, "access?",
			 (zzz_prim_t) access_p_func, argv_2_0_0);

  zzz_c_define_function (core_posix_module, "sys:pipe",
			 (zzz_prim_t) sys_pipe_func, argv_0_0_0);
  zzz_c_define_function (core_posix_module, "pipe",
			 (zzz_prim_t) pipe_func, argv_0_0_0);
  zzz_c_define_function (core_posix_module, "open-fdes",
			 (zzz_prim_t) open_fdes_func, argv_2_1_0);
  zzz_c_define_function (core_posix_module, "sys:creat",
			 (zzz_prim_t) creat_func, argv_2_0_0);
  zzz_c_define_function (core_posix_module, "close",
			 (zzz_prim_t) close_func, argv_1_0_0);
  zzz_c_define_function (core_posix_module, "sys:write",
			 (zzz_prim_t) write_func, argv_3_0_0);
  zzz_c_define_function (core_posix_module, "sys:read!",
			 (zzz_prim_t) read_x_func, argv_3_0_0);
  zzz_c_define_function (core_posix_module, "sys:read",
			 (zzz_prim_t) read_func, argv_2_0_0);
  zzz_c_define_function (core_posix_module, "unlink",
			 (zzz_prim_t) unlink_func, argv_1_0_0);
  zzz_c_define_function (core_posix_module, "link",
			 (zzz_prim_t) link_func, argv_2_0_0);
  zzz_c_define_function (core_posix_module, "symlink",
			 (zzz_prim_t) symlink_func, argv_2_0_0);
  zzz_c_define_function (core_posix_module, "rename",
			 (zzz_prim_t) rename_func, argv_2_0_0);
  zzz_c_define_function (core_posix_module, "readlink",
			 (zzz_prim_t) readlink_func, argv_1_0_0);
  zzz_c_define_function (core_posix_module, "chmod",
			 (zzz_prim_t) chmod_func, argv_2_0_0);
  zzz_c_define_function (core_posix_module, "chown",
			 (zzz_prim_t) chown_func, argv_3_0_0);
  zzz_c_define_function (core_posix_module, "primitive-exit",
			 (zzz_prim_t) primitive_exit_func, argv_0_1_0);
  zzz_c_define_function (core_posix_module, "fork",
			 (zzz_prim_t) fork_func, argv_0_0_0);
  zzz_c_define_function (core_posix_module, "kill",
			 (zzz_prim_t) kill_func, argv_2_0_0);
  zzz_c_define_function (core_posix_module, "wait",
			 (zzz_prim_t) wait_func, argv_0_0_0);

#ifdef WNOHANG
  zzz_c_define_constant (core_posix_module, "WNOHANG",
			 zzz_make_integer (WNOHANG));
#endif
#ifdef WUNTRACED
  zzz_c_define_constant (core_posix_module, "WUNTRACED",
			 zzz_make_integer (WUNTRACED));
#endif

  zzz_c_define_function (core_posix_module, "waitpid",
			 (zzz_prim_t) waitpid_func, argv_1_1_0);
  zzz_c_define_function (core_posix_module, "sleep",
			 (zzz_prim_t) sleep_func, argv_1_0_0);
  zzz_c_define_function (core_posix_module, "execl",
			 (zzz_prim_t) execl_func, argv_2_0_0);
  zzz_c_define_function (core_posix_module, "execlp",
			 (zzz_prim_t) execlp_func, argv_2_0_0);
  zzz_c_define_function (core_posix_module, "execle",
			 (zzz_prim_t) execle_func, argv_3_0_0);
  zzz_c_define_function (core_posix_module, "nice",
			 (zzz_prim_t) nice_func, argv_1_0_0);
  zzz_c_define_function (core_posix_module, "sync",
			 (zzz_prim_t) sync_func, argv_0_0_0);
  zzz_c_define_function (core_posix_module, "uname",
			 (zzz_prim_t) uname_func, argv_0_0_0);
  zzz_c_define_function (core_posix_module, "utime",
			 (zzz_prim_t) utime_func, argv_1_1_0);
  zzz_c_define_function (core_posix_module, "tmpnam",
			 (zzz_prim_t) tmpnam_func, argv_0_0_0);
  zzz_c_define_function (core_posix_module, "tmpfile",
			 (zzz_prim_t) tmpfile_func, argv_0_0_0);
  zzz_c_define_function (core_posix_module, "umask",
			 (zzz_prim_t) umask_func, argv_0_1_0);
  zzz_c_define_function (core_posix_module, "strptime",
			 (zzz_prim_t) strptime_func, argv_2_0_0);
  zzz_c_define_function (core_posix_module, "strftime",
			 (zzz_prim_t) strftime_func, argv_2_0_0);
  zzz_c_define_function (core_posix_module, "gmtime",
			 (zzz_prim_t) gmtime_func, argv_1_0_0);
  zzz_c_define_function (core_posix_module, "localtime",
			 (zzz_prim_t) localtime_func, argv_1_0_0);
  zzz_c_define_function (core_posix_module, "current-time",
			 (zzz_prim_t) current_time_func, argv_0_0_0);
  zzz_c_define_function (core_posix_module, "directory-files",
			 (zzz_prim_t) directory_files_func, argv_1_0_0);

#if defined (HAVE_FCNTL) || defined (__MINGW32__)
  zzz_c_define_constant (core_posix_module, "F_DUPFD",
			 zzz_make_integer (F_DUPFD));
  zzz_c_define_constant (core_posix_module, "F_GETFD",
			 zzz_make_integer (F_GETFD));
  zzz_c_define_constant (core_posix_module, "F_SETFD",
			 zzz_make_integer (F_SETFD));
  zzz_c_define_constant (core_posix_module, "F_GETFL",
			 zzz_make_integer (F_GETFL));
  zzz_c_define_constant (core_posix_module, "F_SETFL",
			 zzz_make_integer (F_SETFL));
  zzz_c_define_constant (core_posix_module, "F_GETLK",
			 zzz_make_integer (F_GETLK));
  zzz_c_define_constant (core_posix_module, "F_SETLK",
			 zzz_make_integer (F_SETLK));
  zzz_c_define_constant (core_posix_module, "F_SETLKW",
			 zzz_make_integer (F_SETLKW));
  zzz_c_define_constant (core_posix_module, "F_GETOWN",
			 zzz_make_integer (F_GETOWN));
  zzz_c_define_constant (core_posix_module, "F_SETOWN",
			 zzz_make_integer (F_SETOWN));
#endif /* HAVE_FCNTL */
  zzz_c_define_function (core_posix_module, "fcntl",
			 (zzz_prim_t) fcntl_func, argv_2_1_0);
  zzz_c_define_function (core_posix_module, "fsync",
			 (zzz_prim_t) fsync_func, argv_1_0_0);
  zzz_c_define_function (core_posix_module, "copy-file",
			 (zzz_prim_t) copy_file, argv_2_0_0);

  /* Tagged type for holding directory streams.  */
  zzz_tagged_type_dir_stream = zzz_define_tagged_type
    (dir_stream_constructor, dir_stream_print, dir_stream_free, NULL, NULL);
  zzz_c_define_function (core_posix_module, "directory-stream?",
			 (zzz_prim_t) directory_stream_p,
		       argv_1_0_0);
  zzz_c_define_function (core_posix_module, "opendir",
			 (zzz_prim_t) opendir_func, argv_1_0_0);
  zzz_c_define_function (core_posix_module, "closedir",
			 (zzz_prim_t) closedir_func, argv_1_0_0);
  zzz_c_define_function (core_posix_module, "readdir",
			 (zzz_prim_t) readdir_func, argv_1_0_0);
  zzz_c_define_function (core_posix_module, "rewinddir",
			 (zzz_prim_t) rewinddir_func, argv_1_0_0);

  zzz_c_define_function (core_posix_module, "fileno",
			 (zzz_prim_t) fileno_func, argv_1_0_0);

  /* FIXME: Document us!  */
  zzz_c_define_function (core_posix_module, "getdrive",
			 (zzz_prim_t) getdrive_func, argv_0_0_0);
  zzz_c_define_function (core_posix_module, "chdrive",
			 (zzz_prim_t) chdrive_func, argv_1_0_0);

#include "posix-ext.c.x"

  /* Define the primitive generated from the interface specification
     in fnmatch.if.  */
#if HAVE_FNMATCH
# include "fnmatch.c.x"
#endif /* HAVE_FNMATCH */

#endif /* ENABLE_POSIX */

  return RESULT_SUCCESS;
}

#if ENABLE_POSIX

int zzz_config_have_posix = 1;

#else /* !ENABLE_POSIX */

int zzz_config_have_posix = 0;

#endif /* !ENABLE_POSIX */
