-/* Copyright (C) 1996, 1997 Free Software Foundation, Inc.
+/* Copyright (C) 1996, 1997, 1998, 1999 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
*
* You should have received a copy of the GNU General Public License
* along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
*
* As a special exception, the Free Software Foundation gives permission
* for additional uses of the text contained in its release of GUILE.
*
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
+ * If you do not wish that, delete this exception notice. */
\f
#include <stdio.h>
#include "_scm.h"
#include "smob.h"
#include "feature.h"
#include "fports.h"
+#include "iselect.h"
#include "filesys.h"
+
\f
+#ifdef HAVE_IO_H
+#include <io.h>
+#endif
+
#ifdef TIME_WITH_SYS_TIME
# include <sys/time.h>
# include <time.h>
#include <pwd.h>
-#ifdef FD_SET
-
-#define SELECT_TYPE fd_set
-#define SELECT_SET_SIZE FD_SETSIZE
-
-#else /* no FD_SET */
-
-/* Define the macros to access a single-int bitmap of descriptors. */
-#define SELECT_SET_SIZE 32
-#define SELECT_TYPE int
-#define FD_SET(n, p) (*(p) |= (1 << (n)))
-#define FD_CLR(n, p) (*(p) &= ~(1 << (n)))
-#define FD_ISSET(n, p) (*(p) & (1 << (n)))
-#define FD_ZERO(p) (*(p) = 0)
-
-#endif /* no FD_SET */
-
#if HAVE_DIRENT_H
# include <dirent.h>
# define NAMLEN(dirent) strlen((dirent)->d_name)
SCM_PROC (s_chown, "chown", 3, 0, 0, scm_chown);
SCM
-scm_chown (path, owner, group)
- SCM path;
+scm_chown (object, owner, group)
+ SCM object;
SCM owner;
SCM group;
{
- int val;
+ int rv;
+ int fdes;
+
+ object = SCM_COERCE_OUTPORT (object);
- SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, SCM_ARG1, s_chown);
- if (SCM_SUBSTRP (path))
- path = scm_makfromstr (SCM_ROCHARS (path), SCM_ROLENGTH (path), 0);
SCM_ASSERT (SCM_INUMP (owner), owner, SCM_ARG2, s_chown);
SCM_ASSERT (SCM_INUMP (group), group, SCM_ARG3, s_chown);
- SCM_SYSCALL (val = chown (SCM_ROCHARS (path),
- SCM_INUM (owner), SCM_INUM (group)));
- if (val != 0)
+ if (SCM_INUMP (object) || (SCM_NIMP (object) && SCM_OPFPORTP (object)))
+ {
+ if (SCM_INUMP (object))
+ fdes = SCM_INUM (object);
+ else
+ fdes = SCM_FPORT_FDES (object);
+ SCM_SYSCALL (rv = fchown (fdes, SCM_INUM (owner), SCM_INUM (group)));
+ }
+ else
+ {
+ SCM_ASSERT (SCM_NIMP (object) && SCM_ROSTRINGP (object),
+ object, SCM_ARG1, s_chown);
+ SCM_COERCE_SUBSTR (object);
+ SCM_SYSCALL (rv = chown (SCM_ROCHARS (object),
+ SCM_INUM (owner), SCM_INUM (group)));
+ }
+ if (rv == -1)
scm_syserror (s_chown);
return SCM_UNSPECIFIED;
}
SCM_PROC (s_chmod, "chmod", 2, 0, 0, scm_chmod);
SCM
-scm_chmod (port_or_path, mode)
- SCM port_or_path;
+scm_chmod (object, mode)
+ SCM object;
SCM mode;
{
int rv;
+ int fdes;
+
+ object = SCM_COERCE_OUTPORT (object);
+
SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG2, s_chmod);
- SCM_ASSERT (SCM_NIMP (port_or_path), port_or_path, SCM_ARG1, s_chmod);
- if (SCM_STRINGP (port_or_path))
- SCM_SYSCALL (rv = chmod (SCM_CHARS (port_or_path), SCM_INUM (mode)));
+ if (SCM_INUMP (object) || (SCM_NIMP (object) && SCM_OPFPORTP (object)))
+ {
+ if (SCM_INUMP (object))
+ fdes = SCM_INUM (object);
+ else
+ fdes = SCM_FPORT_FDES (object);
+ SCM_SYSCALL (rv = fchmod (fdes, SCM_INUM (mode)));
+ }
else
{
- SCM_ASSERT (SCM_OPFPORTP (port_or_path), port_or_path, SCM_ARG1, s_chmod);
- rv = fileno ((FILE *)SCM_STREAM (port_or_path));
- if (rv != -1)
- SCM_SYSCALL (rv = fchmod (rv, SCM_INUM (mode)));
+ SCM_ASSERT (SCM_NIMP (object) && SCM_ROSTRINGP (object),
+ object, SCM_ARG1, s_chmod);
+ SCM_COERCE_SUBSTR (object);
+ SCM_SYSCALL (rv = chmod (SCM_ROCHARS (object), SCM_INUM (mode)));
}
- if (rv != 0)
+ if (rv == -1)
scm_syserror (s_chmod);
return SCM_UNSPECIFIED;
}
\f
-SCM_PROC (s_open, "open", 2, 1, 0, scm_open);
-
+SCM_PROC (s_open_fdes, "open-fdes", 2, 1, 0, scm_open_fdes);
SCM
-scm_open (path, flags, mode)
- SCM path;
- SCM flags;
- SCM mode;
+scm_open_fdes (SCM path, SCM flags, SCM mode)
{
int fd;
- SCM newpt;
- FILE *f;
- char *port_mode;
int iflags;
+ int imode;
- SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, SCM_ARG1, s_open);
- iflags = scm_num2long (flags, (char *) SCM_ARG2, s_open);
-
- if (SCM_SUBSTRP (path))
- path = scm_makfromstr (SCM_ROCHARS (path), SCM_ROLENGTH (path), 0);
+ SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, SCM_ARG1,
+ s_open_fdes);
+ SCM_COERCE_SUBSTR (path);
+ iflags = scm_num2long (flags, (char *) SCM_ARG2, s_open_fdes);
- SCM_DEFER_INTS;
if (SCM_UNBNDP (mode))
- SCM_SYSCALL (fd = open (SCM_ROCHARS (path), iflags));
+ imode = 0666;
else
{
- SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG3, s_open);
- SCM_SYSCALL (fd = open (SCM_ROCHARS (path), iflags, SCM_INUM (mode)));
+ SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG3, s_open_fdes);
+ imode = SCM_INUM (mode);
}
+ SCM_SYSCALL (fd = open (SCM_ROCHARS (path), iflags, imode));
if (fd == -1)
- scm_syserror (s_open);
- SCM_NEWCELL (newpt);
+ scm_syserror (s_open_fdes);
+ return SCM_MAKINUM (fd);
+}
+
+SCM_PROC (s_open, "open", 2, 1, 0, scm_open);
+SCM
+scm_open (SCM path, SCM flags, SCM mode)
+{
+ SCM newpt;
+ char *port_mode;
+ int fd;
+ int iflags;
+
+ fd = SCM_INUM (scm_open_fdes (path, flags, mode));
+ iflags = scm_num2long (flags, (char *) SCM_ARG2, s_open_fdes);
if (iflags & O_RDWR)
- port_mode = "r+";
+ {
+ if (iflags & O_APPEND)
+ port_mode = "a+";
+ else if (iflags & O_CREAT)
+ port_mode = "w+";
+ else
+ port_mode = "r+";
+ }
else {
- if (iflags & O_WRONLY)
+ if (iflags & O_APPEND)
+ port_mode = "a";
+ else if (iflags & O_WRONLY)
port_mode = "w";
else
port_mode = "r";
}
- f = fdopen (fd, port_mode);
- if (!f)
- {
- SCM_SYSCALL (close (fd));
- scm_syserror (s_open);
- }
- {
- struct scm_port_table * pt;
-
- pt = scm_add_to_port_table (newpt);
- SCM_SETPTAB_ENTRY (newpt, pt);
- SCM_SETCAR (newpt, scm_tc16_fport | scm_mode_bits (port_mode));
- /* if (SCM_BUF0 & SCM_CAR (newpt))
- scm_setbuf0 (newpt); */
- SCM_SETSTREAM (newpt, (SCM)f);
- SCM_PTAB_ENTRY (newpt)->file_name = path;
- }
- SCM_ALLOW_INTS;
-
+ newpt = scm_fdes_to_port (fd, port_mode, path);
return newpt;
}
+SCM_PROC (s_close, "close", 1, 0, 0, scm_close);
+SCM
+scm_close (SCM fd_or_port)
+{
+ int rv;
+ int fd;
+
+ fd_or_port = SCM_COERCE_OUTPORT (fd_or_port);
+
+ if (SCM_NIMP (fd_or_port) && SCM_PORTP (fd_or_port))
+ return scm_close_port (fd_or_port);
+ SCM_ASSERT (SCM_INUMP (fd_or_port), fd_or_port, SCM_ARG1, s_close);
+ fd = SCM_INUM (fd_or_port);
+ scm_evict_ports (fd); /* see scsh manual. */
+ SCM_SYSCALL (rv = close (fd));
+ /* following scsh, closing an already closed file descriptor is
+ not an error. */
+ if (rv < 0 && errno != EBADF)
+ scm_syserror (s_close);
+ return (rv < 0) ? SCM_BOOL_F : SCM_BOOL_T;
+}
+
\f
/* {Files}
*/
scm_stat2scm (stat_temp)
struct stat *stat_temp;
{
- SCM ans = scm_make_vector (SCM_MAKINUM (15), SCM_UNSPECIFIED, SCM_BOOL_F);
+ SCM ans = scm_make_vector (SCM_MAKINUM (15), SCM_UNSPECIFIED);
SCM *ve = SCM_VELTS (ans);
ve[0] = scm_ulong2num ((unsigned long) stat_temp->st_dev);
SCM_PROC (s_stat, "stat", 1, 0, 0, scm_stat);
SCM
-scm_stat (file)
- SCM file;
+scm_stat (object)
+ SCM object;
{
- int rv = 1;
+ int rv;
+ int fdes;
struct stat stat_temp;
- if (SCM_INUMP (file))
- SCM_SYSCALL (rv = fstat (SCM_INUM (file), &stat_temp));
+ if (SCM_INUMP (object))
+ SCM_SYSCALL (rv = fstat (SCM_INUM (object), &stat_temp));
else
{
- SCM_ASSERT (SCM_NIMP (file), file, SCM_ARG1, s_stat);
- if (SCM_FPORTP (file))
- SCM_SYSCALL (rv = fstat (fileno ((FILE *) SCM_STREAM (file)),
- &stat_temp));
+ SCM_ASSERT (SCM_NIMP (object), object, SCM_ARG1, s_stat);
+ if (SCM_ROSTRINGP (object))
+ {
+ SCM_COERCE_SUBSTR (object);
+ SCM_SYSCALL (rv = stat (SCM_ROCHARS (object), &stat_temp));
+ }
else
{
- SCM_ASSERT (SCM_ROSTRINGP (file), file, SCM_ARG1, s_stat);
- if (SCM_SUBSTRP (file))
- file = scm_makfromstr (SCM_ROCHARS (file),
- SCM_ROLENGTH (file),
- 0);
- SCM_SYSCALL (rv = stat (SCM_CHARS (file), &stat_temp));
+ object = SCM_COERCE_OUTPORT (object);
+ SCM_ASSERT (SCM_OPFPORTP (object), object, SCM_ARG1, s_stat);
+ fdes = SCM_FPORT_FDES (object);
+ SCM_SYSCALL (rv = fstat (fdes, &stat_temp));
}
}
- if (rv != 0)
+ if (rv == -1)
{
int en = errno;
scm_syserror_msg (s_stat, "%s: %S",
scm_listify (scm_makfrom0str (strerror (errno)),
- file,
+ object,
SCM_UNDEFINED),
en);
}
return scm_stat2scm (&stat_temp);
}
-
\f
/* {Modifying Directories}
*/
{
int val;
- SCM_ASSERT (SCM_NIMP (oldpath) && SCM_ROSTRINGP (oldpath), oldpath, SCM_ARG1, s_link);
+ SCM_ASSERT (SCM_NIMP (oldpath) && SCM_ROSTRINGP (oldpath), oldpath,
+ SCM_ARG1, s_link);
if (SCM_SUBSTRP (oldpath))
- oldpath = scm_makfromstr (SCM_ROCHARS (oldpath), SCM_ROLENGTH (oldpath), 0);
- SCM_ASSERT (SCM_NIMP (newpath) && SCM_ROSTRINGP (newpath), newpath, SCM_ARG2, s_link);
+ oldpath = scm_makfromstr (SCM_ROCHARS (oldpath),
+ SCM_ROLENGTH (oldpath), 0);
+ SCM_ASSERT (SCM_NIMP (newpath) && SCM_ROSTRINGP (newpath), newpath,
+ SCM_ARG2, s_link);
if (SCM_SUBSTRP (newpath))
- newpath = scm_makfromstr (SCM_ROCHARS (newpath), SCM_ROLENGTH (newpath), 0);
+ newpath = scm_makfromstr (SCM_ROCHARS (newpath),
+ SCM_ROLENGTH (newpath), 0);
SCM_SYSCALL (val = link (SCM_ROCHARS (oldpath), SCM_ROCHARS (newpath)));
if (val != 0)
scm_syserror (s_link);
SCM newname;
{
int rv;
- SCM_ASSERT (SCM_NIMP (oldname) && SCM_STRINGP (oldname), oldname, SCM_ARG1, s_rename);
- SCM_ASSERT (SCM_NIMP (newname) && SCM_STRINGP (newname), newname, SCM_ARG2, s_rename);
+ SCM_ASSERT (SCM_NIMP (oldname) && SCM_ROSTRINGP (oldname), oldname, SCM_ARG1,
+ s_rename);
+ SCM_ASSERT (SCM_NIMP (newname) && SCM_ROSTRINGP (newname), newname, SCM_ARG2,
+ s_rename);
+ SCM_COERCE_SUBSTR (oldname);
+ SCM_COERCE_SUBSTR (newname);
#ifdef HAVE_RENAME
- SCM_SYSCALL (rv = rename (SCM_CHARS (oldname), SCM_CHARS (newname)));
- if (rv != 0)
- scm_syserror (s_rename);
- return SCM_UNSPECIFIED;
+ SCM_SYSCALL (rv = rename (SCM_ROCHARS (oldname), SCM_ROCHARS (newname)));
#else
- SCM_DEFER_INTS;
- SCM_SYSCALL (rv = link (SCM_CHARS (oldname), SCM_CHARS (newname)));
+ SCM_SYSCALL (rv = link (SCM_ROCHARS (oldname), SCM_ROCHARS (newname)));
if (rv == 0)
{
- SCM_SYSCALL (rv = unlink (SCM_CHARS (oldname)));;
+ SCM_SYSCALL (rv = unlink (SCM_ROCHARS (oldname)));;
if (rv != 0)
/* unlink failed. remove new name */
- SCM_SYSCALL (unlink (SCM_CHARS (newname)));
+ SCM_SYSCALL (unlink (SCM_ROCHARS (newname)));
}
- SCM_ALLOW_INTS;
+#endif
if (rv != 0)
scm_syserror (s_rename);
return SCM_UNSPECIFIED;
-#endif
}
SCM str;
{
int ans;
- SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_delete_file);
- SCM_SYSCALL (ans = unlink (SCM_CHARS (str)));
+ SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1,
+ s_delete_file);
+ SCM_COERCE_SUBSTR (str);
+ SCM_SYSCALL (ans = unlink (SCM_ROCHARS (str)));
if (ans != 0)
scm_syserror (s_delete_file);
return SCM_UNSPECIFIED;
}
-
SCM_PROC (s_mkdir, "mkdir", 1, 1, 0, scm_mkdir);
SCM
#ifdef HAVE_MKDIR
int rv;
mode_t mask;
- SCM_ASSERT (SCM_NIMP (path) && SCM_STRINGP (path), path, SCM_ARG1, s_mkdir);
+ SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, SCM_ARG1,
+ s_mkdir);
+ SCM_COERCE_SUBSTR (path);
if (SCM_UNBNDP (mode))
{
mask = umask (0);
umask (mask);
- SCM_SYSCALL (rv = mkdir (SCM_CHARS (path), 0777 ^ mask));
+ SCM_SYSCALL (rv = mkdir (SCM_ROCHARS (path), 0777 ^ mask));
}
else
{
SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG2, s_mkdir);
- SCM_SYSCALL (rv = mkdir (SCM_CHARS (path), SCM_INUM (mode)));
+ SCM_SYSCALL (rv = mkdir (SCM_ROCHARS (path), SCM_INUM (mode)));
}
if (rv != 0)
scm_syserror (s_mkdir);
#ifdef HAVE_RMDIR
int val;
- SCM_ASSERT (SCM_NIMP (path) && SCM_STRINGP (path), path, SCM_ARG1, s_rmdir);
- SCM_SYSCALL (val = rmdir (SCM_CHARS (path)));
+ SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, SCM_ARG1,
+ s_rmdir);
+ SCM_COERCE_SUBSTR (path);
+ SCM_SYSCALL (val = rmdir (SCM_ROCHARS (path)));
if (val != 0)
scm_syserror (s_rmdir);
return SCM_UNSPECIFIED;
SCM dirname;
{
DIR *ds;
- SCM dir;
- SCM_ASSERT (SCM_NIMP (dirname) && SCM_STRINGP (dirname), dirname, SCM_ARG1, s_opendir);
- SCM_NEWCELL (dir);
- SCM_DEFER_INTS;
- SCM_SYSCALL (ds = opendir (SCM_CHARS (dirname)));
+ SCM_ASSERT (SCM_NIMP (dirname) && SCM_ROSTRINGP (dirname), dirname, SCM_ARG1,
+ s_opendir);
+ SCM_COERCE_SUBSTR (dirname);
+ SCM_SYSCALL (ds = opendir (SCM_ROCHARS (dirname)));
if (ds == NULL)
scm_syserror (s_opendir);
- SCM_SETCAR (dir, scm_tc16_dir | SCM_OPN);
- SCM_SETCDR (dir, ds);
- SCM_ALLOW_INTS;
- return dir;
+ SCM_RETURN_NEWSMOB (scm_tc16_dir | SCM_OPN, ds);
}
SCM port;
{
struct dirent *rdent;
- SCM_DEFER_INTS;
SCM_ASSERT (SCM_NIMP (port) && SCM_OPDIRP (port), port, SCM_ARG1, s_readdir);
errno = 0;
SCM_SYSCALL (rdent = readdir ((DIR *) SCM_CDR (port)));
- SCM_ALLOW_INTS;
if (errno != 0)
scm_syserror (s_readdir);
return (rdent ? scm_makfromstr (rdent->d_name, NAMLEN (rdent), 0)
int sts;
SCM_ASSERT (SCM_NIMP (port) && SCM_DIRP (port), port, SCM_ARG1, s_closedir);
- SCM_DEFER_INTS;
if (SCM_CLOSEDP (port))
{
- SCM_ALLOW_INTS;
return SCM_UNSPECIFIED;
}
SCM_SYSCALL (sts = closedir ((DIR *) SCM_CDR (port)));
if (sts != 0)
scm_syserror (s_closedir);
SCM_SETCAR (port, scm_tc16_dir);
- SCM_ALLOW_INTS;
return SCM_UNSPECIFIED;
}
static int scm_dir_print SCM_P ((SCM sexp, SCM port, scm_print_state *pstate));
static int
-scm_dir_print (sexp, port, pstate)
- SCM sexp;
- SCM port;
- scm_print_state *pstate;
+scm_dir_print (SCM exp, SCM port, scm_print_state *pstate)
{
- scm_prinport (sexp, port, "directory");
+ scm_puts ("#<", port);
+ if (SCM_CLOSEDP (exp))
+ scm_puts ("closed: ", port);
+ scm_puts ("directory ", port);
+ scm_intprint (SCM_CDR (exp), 16, port);
+ scm_putc ('>', port);
return 1;
}
return 0;
}
-static scm_smobfuns dir_smob = {scm_mark0, scm_dir_free, scm_dir_print, 0};
-
\f
/* {Navigating Directories}
*/
{
int ans;
- SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_chdir);
- SCM_SYSCALL (ans = chdir (SCM_CHARS (str)));
+ SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_chdir);
+ SCM_COERCE_SUBSTR (str);
+ SCM_SYSCALL (ans = chdir (SCM_ROCHARS (str)));
if (ans != 0)
scm_syserror (s_chdir);
return SCM_UNSPECIFIED;
char *wd;
SCM result;
- SCM_DEFER_INTS;
wd = scm_must_malloc (size, s_getcwd);
while ((rv = getcwd (wd, size)) == 0 && errno == ERANGE)
{
scm_syserror (s_getcwd);
result = scm_makfromstr (wd, strlen (wd), 0);
scm_must_free (wd);
- SCM_ALLOW_INTS;
return result;
#else
scm_sysmissing (s_getcwd);
\f
+SCM_PROC (s_select, "select", 3, 2, 0, scm_select);
+
-static void fill_select_type SCM_P ((SELECT_TYPE * set, SCM list));
+static int
+set_element (SELECT_TYPE *set, SCM element, int arg)
+{
+ int fd;
+ element = SCM_COERCE_OUTPORT (element);
+ if (SCM_NIMP (element) && SCM_OPFPORTP (element))
+ fd = SCM_FPORT_FDES (element);
+ else {
+ SCM_ASSERT (SCM_INUMP (element), element, arg, s_select);
+ fd = SCM_INUM (element);
+ }
+ FD_SET (fd, set);
+ return fd;
+}
-static void
-fill_select_type (set, list)
- SELECT_TYPE * set;
- SCM list;
+static int
+fill_select_type (SELECT_TYPE *set, SCM list, int arg)
{
- while (list != SCM_EOL)
+ int max_fd = 0, fd;
+ if (SCM_NIMP (list) && SCM_VECTORP (list))
{
- if ( SCM_NIMP (SCM_CAR (list))
- && (scm_tc16_fport == SCM_TYP16 (SCM_CAR (list)))
- && SCM_OPPORTP (SCM_CAR (list)))
- FD_SET (fileno ((FILE *)SCM_STREAM (SCM_CAR (list))), set);
- else if (SCM_INUMP (SCM_CAR (list)))
- FD_SET (SCM_INUM (SCM_CAR (list)), set);
- list = SCM_CDR (list);
+ int len = SCM_LENGTH (list);
+ SCM *ve = SCM_VELTS (list);
+
+ while (len > 0)
+ {
+ fd = set_element (set, ve[len - 1], arg);
+ if (fd > max_fd)
+ max_fd = fd;
+ len--;
+ }
+ }
+ else
+ {
+ while (list != SCM_EOL)
+ {
+ fd = set_element (set, SCM_CAR (list), arg);
+ if (fd > max_fd)
+ max_fd = fd;
+ list = SCM_CDR (list);
+ }
}
-}
+ return max_fd;
+}
-static SCM retrieve_select_type SCM_P ((SELECT_TYPE * set, SCM list));
+static SCM
+get_element (SELECT_TYPE *set, SCM element, SCM list)
+{
+ element = SCM_COERCE_OUTPORT (element);
+ if (SCM_NIMP (element) && SCM_OPFPORTP (element))
+ {
+ if (FD_ISSET (SCM_FPORT_FDES (element), set))
+ list = scm_cons (element, list);
+ }
+ else if (SCM_INUMP (element))
+ {
+ if (FD_ISSET (SCM_INUM (element), set))
+ list = scm_cons (element, list);
+ }
+ return list;
+}
static SCM
-retrieve_select_type (set, list)
- SELECT_TYPE * set;
- SCM list;
+retrieve_select_type (SELECT_TYPE *set, SCM list)
{
- SCM answer;
- answer = SCM_EOL;
- while (list != SCM_EOL)
+ SCM answer_list = SCM_EOL;
+
+ if (SCM_NIMP (list) && SCM_VECTORP (list))
{
- if ( SCM_NIMP (SCM_CAR (list))
- && (scm_tc16_fport == SCM_TYP16 (SCM_CAR (list)))
- && SCM_OPPORTP (SCM_CAR (list)))
+ int len = SCM_LENGTH (list);
+ SCM *ve = SCM_VELTS (list);
+
+ while (len > 0)
{
- if (FD_ISSET (fileno ((FILE *)SCM_STREAM (SCM_CAR (list))), set))
- answer = scm_cons (SCM_CAR (list), answer);
+ answer_list = get_element (set, ve[len - 1], answer_list);
+ len--;
}
- else if (SCM_INUMP (SCM_CAR (list)))
+ return scm_vector (answer_list);
+ }
+ else
+ {
+ /* list is a list. */
+ while (list != SCM_EOL)
{
- if (FD_ISSET (SCM_INUM (SCM_CAR (list)), set))
- answer = scm_cons (SCM_CAR (list), answer);
+ answer_list = get_element (set, SCM_CAR (list), answer_list);
+ list = SCM_CDR (list);
}
- list = SCM_CDR (list);
+ return answer_list;
}
- return answer;
}
-/* {Checking for events}
- */
-
-SCM_PROC (s_select, "select", 3, 2, 0, scm_select);
-
SCM
-scm_select (reads, writes, excepts, secs, msecs)
+scm_select (reads, writes, excepts, secs, usecs)
SCM reads;
SCM writes;
SCM excepts;
SCM secs;
- SCM msecs;
+ SCM usecs;
{
#ifdef HAVE_SELECT
struct timeval timeout;
SELECT_TYPE read_set;
SELECT_TYPE write_set;
SELECT_TYPE except_set;
+ int max_fd, fd;
int sreturn;
- SCM_ASSERT (-1 < scm_ilength (reads), reads, SCM_ARG1, s_select);
- SCM_ASSERT (-1 < scm_ilength (writes), reads, SCM_ARG1, s_select);
- SCM_ASSERT (-1 < scm_ilength (excepts), reads, SCM_ARG1, s_select);
+#define assert_set(x, arg) \
+ SCM_ASSERT (scm_ilength (x) > -1 || (SCM_NIMP (x) && SCM_VECTORP (x)), \
+ x, arg, s_select)
+ assert_set (reads, SCM_ARG1);
+ assert_set (writes, SCM_ARG2);
+ assert_set (excepts, SCM_ARG3);
+#undef assert_set
FD_ZERO (&read_set);
FD_ZERO (&write_set);
FD_ZERO (&except_set);
- fill_select_type (&read_set, reads);
- fill_select_type (&write_set, writes);
- fill_select_type (&except_set, excepts);
+ max_fd = fill_select_type (&read_set, reads, SCM_ARG1);
+ fd = fill_select_type (&write_set, writes, SCM_ARG2);
+ if (fd > max_fd)
+ max_fd = fd;
+ fd = fill_select_type (&except_set, excepts, SCM_ARG3);
+ if (fd > max_fd)
+ max_fd = fd;
- if (SCM_UNBNDP (secs))
+ if (SCM_UNBNDP (secs) || SCM_FALSEP (secs))
time_p = 0;
else
{
- SCM_ASSERT (SCM_INUMP (secs), secs, SCM_ARG4, s_select);
- if (SCM_UNBNDP (msecs))
- msecs = SCM_INUM0;
+ if (SCM_INUMP (secs))
+ {
+ timeout.tv_sec = SCM_INUM (secs);
+ if (SCM_UNBNDP (usecs))
+ timeout.tv_usec = 0;
+ else
+ {
+ SCM_ASSERT (SCM_INUMP (usecs), usecs, SCM_ARG5, s_select);
+
+ timeout.tv_usec = SCM_INUM (usecs);
+ }
+ }
else
- SCM_ASSERT (SCM_INUMP (msecs), msecs, SCM_ARG5, s_select);
-
- timeout.tv_sec = SCM_INUM (secs);
- timeout.tv_usec = 1000 * SCM_INUM (msecs);
+ {
+ double fl = scm_num2dbl (secs, s_select);
+
+ if (!SCM_UNBNDP (usecs))
+ scm_wrong_type_arg (s_select, 4, secs);
+ if (fl > LONG_MAX)
+ scm_out_of_range (s_select, secs);
+ timeout.tv_sec = (long) fl;
+ timeout.tv_usec = (long) ((fl - timeout.tv_sec) * 1000000);
+ }
time_p = &timeout;
}
- SCM_DEFER_INTS;
- sreturn = select (SELECT_SET_SIZE,
+#ifdef GUILE_ISELECT
+ sreturn = scm_internal_select (max_fd + 1,
+ &read_set, &write_set, &except_set, time_p);
+#else
+ sreturn = select (max_fd + 1,
&read_set, &write_set, &except_set, time_p);
+#endif
if (sreturn < 0)
scm_syserror (s_select);
- SCM_ALLOW_INTS;
return scm_listify (retrieve_select_type (&read_set, reads),
retrieve_select_type (&write_set, writes),
retrieve_select_type (&except_set, excepts),
#endif
}
-/* Check if FILE has characters waiting to be read. */
-
-#ifdef __IBMC__
-# define MSDOS
-#endif
-#ifdef MSDOS
-# ifndef GO32
-# include <io.h>
-# include <conio.h>
-
-int
-scm_input_waiting_p (f, caller)
- FILE *f;
- char *caller;
-{
- if (feof (f))
- return 1;
- if (fileno (f) == fileno (stdin) && (isatty (fileno (stdin))))
- return kbhit ();
- return -1;
-}
-
-# endif
-#else
-# ifdef _DCC
-# include <ioctl.h>
-# else
-# ifndef AMIGA
-# ifndef vms
-# ifdef MWC
-# include <sys/io.h>
-# else
-# ifndef THINK_C
-# ifndef ARM_ULIB
-# include <sys/ioctl.h>
-# endif
-# endif
-# endif
-# endif
-# endif
-# endif
-
-int
-scm_input_waiting_p (f, caller)
- FILE *f;
- char *caller;
-{
- /* Can we return an end-of-file character? */
- if (feof (f))
- return 1;
-
- /* Do we have characters in the stdio buffer? */
-# ifdef FILE_CNT_FIELD
- if (f->FILE_CNT_FIELD > 0)
- return 1;
-# else
-# ifdef FILE_CNT_GPTR
- if (f->_gptr != f->_egptr)
- return 1;
-# else
-# ifdef FILE_CNT_READPTR
- if (f->_IO_read_end != f->_IO_read_ptr)
- return 1;
-# else
- Configure.in could not guess the name of the correct field in a FILE *.
- This function needs to be ported to your system.
- It should return zero iff no characters are waiting to be read.;
-# endif
-# endif
-# endif
-
- /* Is the file prepared to deliver input? */
-# ifdef HAVE_SELECT
- {
- struct timeval timeout;
- SELECT_TYPE read_set;
- SELECT_TYPE write_set;
- SELECT_TYPE except_set;
- int fno = fileno ((FILE *)f);
-
- FD_ZERO (&read_set);
- FD_ZERO (&write_set);
- FD_ZERO (&except_set);
-
- FD_SET (fno, &read_set);
-
- timeout.tv_sec = 0;
- timeout.tv_usec = 0;
-
- SCM_DEFER_INTS;
- if (select (SELECT_SET_SIZE,
- &read_set, &write_set, &except_set, &timeout)
- < 0)
- scm_syserror (caller);
- SCM_ALLOW_INTS;
- return FD_ISSET (fno, &read_set);
- }
-# else
-# ifdef FIONREAD
- {
- long remir;
- ioctl(fileno(f), FIONREAD, &remir);
- return remir;
- }
-# else
- scm_misc_error ("char-ready?", "Not fully implemented on this platform",
- SCM_EOL);
-# endif
-# endif
-}
-#endif
-
\f
-SCM_PROC (s_fcntl, "fcntl", 3, 0, 0, scm_fcntl);
-
+SCM_PROC (s_fcntl, "fcntl", 2, 0, 1, scm_fcntl);
SCM
-scm_fcntl (port, cmd, value)
- SCM port;
- SCM cmd;
- SCM value;
+scm_fcntl (SCM object, SCM cmd, SCM value)
{
int rv;
+ int fdes;
+ int ivalue;
- SCM_ASSERT (SCM_OPFPORTP (port), port, SCM_ARG1, s_fcntl);
- SCM_ASSERT (SCM_INUMP (cmd), cmd, SCM_ARG2, s_fcntl);
- SCM_ASSERT (SCM_INUMP (value), value, SCM_ARG3, s_fcntl);
+ object = SCM_COERCE_OUTPORT (object);
- rv = fileno ((FILE *)SCM_STREAM (port));
- if (rv != -1)
- SCM_SYSCALL (rv = fcntl (rv, SCM_INUM (cmd), SCM_INUM (value)));
+ SCM_ASSERT (SCM_INUMP (cmd), cmd, SCM_ARG2, s_fcntl);
+ if (SCM_NIMP (object) && SCM_OPFPORTP (object))
+ fdes = SCM_FPORT_FDES (object);
+ else
+ {
+ SCM_ASSERT (SCM_INUMP (object), object, SCM_ARG1, s_fcntl);
+ fdes = SCM_INUM (object);
+ }
+ if (SCM_NULLP (value))
+ ivalue = 0;
+ else
+ {
+ SCM_ASSERT (SCM_INUMP (SCM_CAR (value)), value, SCM_ARG3, s_fcntl);
+ ivalue = SCM_INUM (SCM_CAR (value));
+ }
+ SCM_SYSCALL (rv = fcntl (fdes, SCM_INUM (cmd), ivalue));
if (rv == -1)
scm_syserror (s_fcntl);
return SCM_MAKINUM (rv);
}
-\f
-/* {Symbolic Links}
- */
+
+SCM_PROC (s_fsync, "fsync", 1, 0, 0, scm_fsync);
+SCM
+scm_fsync (SCM object)
+{
+ int fdes;
+
+ object = SCM_COERCE_OUTPORT (object);
+
+ if (SCM_NIMP (object) && SCM_OPFPORTP (object))
+ {
+ scm_flush (object);
+ fdes = SCM_FPORT_FDES (object);
+ }
+ else
+ {
+ SCM_ASSERT (SCM_INUMP (object), object, SCM_ARG1, s_fsync);
+ fdes = SCM_INUM (object);
+ }
+ if (fsync (fdes) == -1)
+ scm_syserror (s_fsync);
+ return SCM_UNSPECIFIED;
+}
SCM_PROC (s_symlink, "symlink", 2, 0, 0, scm_symlink);
#ifdef HAVE_SYMLINK
int val;
- SCM_ASSERT(SCM_NIMP(oldpath) && SCM_STRINGP(oldpath), oldpath, SCM_ARG1, s_symlink);
- SCM_ASSERT(SCM_NIMP(newpath) && SCM_STRINGP(newpath), newpath, SCM_ARG2, s_symlink);
- SCM_SYSCALL (val = symlink(SCM_CHARS(oldpath), SCM_CHARS(newpath)));
+ SCM_ASSERT (SCM_NIMP (oldpath) && SCM_ROSTRINGP (oldpath), oldpath, SCM_ARG1,
+ s_symlink);
+ SCM_ASSERT (SCM_NIMP (newpath) && SCM_ROSTRINGP (newpath), newpath, SCM_ARG2,
+ s_symlink);
+ SCM_COERCE_SUBSTR (oldpath);
+ SCM_COERCE_SUBSTR (newpath);
+ SCM_SYSCALL (val = symlink(SCM_ROCHARS(oldpath), SCM_ROCHARS(newpath)));
if (val != 0)
scm_syserror (s_symlink);
return SCM_UNSPECIFIED;
SCM path;
{
#ifdef HAVE_READLINK
- scm_sizet rv;
- scm_sizet size = 100;
+ int rv;
+ int size = 100;
char *buf;
SCM result;
- SCM_ASSERT (SCM_NIMP (path) && SCM_STRINGP (path), path, (char *) SCM_ARG1, s_readlink);
- SCM_DEFER_INTS;
+ SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, (char *) SCM_ARG1,
+ s_readlink);
+ SCM_COERCE_SUBSTR (path);
buf = scm_must_malloc (size, s_readlink);
- while ((rv = readlink (SCM_CHARS (path), buf, (scm_sizet) size)) == size)
+ while ((rv = readlink (SCM_ROCHARS (path), buf, size)) == size)
{
scm_must_free (buf);
size *= 2;
scm_syserror (s_readlink);
result = scm_makfromstr (buf, rv, 0);
scm_must_free (buf);
- SCM_ALLOW_INTS;
return result;
#else
scm_sysmissing (s_readlink);
int rv;
struct stat stat_temp;
- SCM_ASSERT(SCM_NIMP(str) && SCM_STRINGP(str), str, (char *)SCM_ARG1, s_lstat);
- SCM_SYSCALL(rv = lstat(SCM_CHARS(str), &stat_temp));
+ SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, (char *) SCM_ARG1,
+ s_lstat);
+ SCM_COERCE_SUBSTR (str);
+ SCM_SYSCALL(rv = lstat(SCM_ROCHARS(str), &stat_temp));
if (rv != 0)
{
int en = errno;
{
int oldfd, newfd;
int n;
- char buf[BUFSIZ]; /* this space could be shared. */
+ char buf[BUFSIZ];
struct stat oldstat;
SCM_ASSERT (SCM_NIMP (oldfile) && SCM_ROSTRINGP (oldfile), oldfile, SCM_ARG1, s_copy_file);
newfile = scm_makfromstr (SCM_ROCHARS (newfile), SCM_ROLENGTH (newfile), 0);
if (stat (SCM_ROCHARS (oldfile), &oldstat) == -1)
scm_syserror (s_copy_file);
- SCM_DEFER_INTS;
oldfd = open (SCM_ROCHARS (oldfile), O_RDONLY);
if (oldfd == -1)
scm_syserror (s_copy_file);
close (oldfd);
if (close (newfd) == -1)
scm_syserror (s_copy_file);
- SCM_ALLOW_INTS;
return SCM_UNSPECIFIED;
}
\f
+/* Filename manipulation */
+
+SCM scm_dot_string;
+
+SCM_PROC (s_dirname, "dirname", 1, 0, 0, scm_dirname);
+
+SCM
+scm_dirname (SCM filename)
+{
+ char *s;
+ int i, len;
+ SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename),
+ filename,
+ SCM_ARG1,
+ s_dirname);
+ s = SCM_ROCHARS (filename);
+ len = SCM_LENGTH (filename);
+ i = len - 1;
+ while (i >= 0 && s[i] == '/') --i;
+ while (i >= 0 && s[i] != '/') --i;
+ while (i >= 0 && s[i] == '/') --i;
+ if (i < 0)
+ {
+ if (len > 0 && s[0] == '/')
+ return scm_make_shared_substring (filename, SCM_INUM0, SCM_MAKINUM (1));
+ else
+ return scm_dot_string;
+ }
+ else
+ return scm_make_shared_substring (filename, SCM_INUM0, SCM_MAKINUM (i + 1));
+}
+
+SCM_PROC (s_basename, "basename", 1, 1, 0, scm_basename);
+
+SCM
+scm_basename (SCM filename, SCM suffix)
+{
+ char *f, *s = 0;
+ int i, j, len, end;
+ SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename),
+ filename,
+ SCM_ARG1,
+ s_basename);
+ SCM_ASSERT (SCM_UNBNDP (suffix)
+ || (SCM_NIMP (suffix) && SCM_ROSTRINGP (suffix)),
+ suffix,
+ SCM_ARG2,
+ s_basename);
+ f = SCM_ROCHARS (filename);
+ if (SCM_UNBNDP (suffix))
+ j = -1;
+ else
+ {
+ s = SCM_ROCHARS (suffix);
+ j = SCM_LENGTH (suffix) - 1;
+ }
+ len = SCM_LENGTH (filename);
+ i = len - 1;
+ while (i >= 0 && f[i] == '/') --i;
+ end = i;
+ while (i >= 0 && j >= 0 && f[i] == s[j]) --i, --j;
+ if (j == -1)
+ end = i;
+ while (i >= 0 && f[i] != '/') --i;
+ if (i == end)
+ {
+ if (len > 0 && f[0] == '/')
+ return scm_make_shared_substring (filename, SCM_INUM0, SCM_MAKINUM (1));
+ else
+ return scm_dot_string;
+ }
+ else
+ return scm_make_shared_substring (filename,
+ SCM_MAKINUM (i + 1),
+ SCM_MAKINUM (end + 1));
+}
+
+
+
+\f
void
scm_init_filesys ()
{
scm_add_feature ("i/o-extensions");
- scm_tc16_dir = scm_newsmob (&dir_smob);
+ scm_tc16_dir = scm_make_smob_type_mfpe ("directory", 0,
+ NULL, scm_dir_free,scm_dir_print, NULL);
+ scm_dot_string = scm_permanent_object (scm_makfrom0str ("."));
+
#ifdef O_RDONLY
scm_sysintern ("O_RDONLY", scm_long2num (O_RDONLY));
#endif
#ifdef O_APPEND
scm_sysintern ("O_APPEND", scm_long2num (O_APPEND));
#endif
-#ifdef O_NONBLO
+#ifdef O_NONBLOCK
scm_sysintern ("O_NONBLOCK", scm_long2num (O_NONBLOCK));
#endif
#ifdef O_NDELAY
HCoop / bpt / guile.git / blobdiff