X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/c2ca44933f8b2b43ec3efa541a6824537c45a560..9bc6fb0a7d91ae9a6c57cedb76022043db413ba5:/libguile/filesys.c diff --git a/libguile/filesys.c b/libguile/filesys.c index e8e62b1d5..15593b4e8 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1996, 1997, 1998, 1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1996,1997,1998,1999,2000,2001 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -39,11 +39,11 @@ * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ #include +#include + #include "libguile/_scm.h" #include "libguile/smob.h" #include "libguile/feature.h" @@ -51,6 +51,7 @@ #include "libguile/iselect.h" #include "libguile/strings.h" #include "libguile/vectors.h" +#include "libguile/lang.h" #include "libguile/validate.h" #include "libguile/filesys.h" @@ -60,6 +61,10 @@ #include #endif +#ifdef HAVE_DIRECT_H +#include +#endif + #ifdef TIME_WITH_SYS_TIME # include # include @@ -91,10 +96,15 @@ #include #include +#ifdef HAVE_PWD_H #include +#endif -#if HAVE_DIRENT_H +#if defined (__MINGW32__) || defined (_MSC_VER) || defined (__BORLANDC__) +# include "win32-dirent.h" +# define NAMLEN(dirent) strlen((dirent)->d_name) +#elif HAVE_DIRENT_H # include # define NAMLEN(dirent) strlen((dirent)->d_name) #else @@ -115,6 +125,71 @@ #if defined (S_IFSOCK) && ! defined (S_ISSOCK) #define S_ISSOCK(mode) (((mode) & S_IFMT) == S_IFSOCK) #endif + +/* The MinGW gcc does not define the S_ISSOCK macro. Any other native Windows + compiler like BorlandC or MSVC has none of these macros defined. */ +#ifdef __MINGW32__ + +# ifdef _S_IFIFO +# undef _S_IFIFO +# endif +# ifdef _S_IFCHR +# undef _S_IFCHR +# endif +# ifdef _S_IFBLK +# undef _S_IFBLK +# endif +# ifdef _S_IFDIR +# undef _S_IFDIR +# endif +# ifdef _S_IFREG +# undef _S_IFREG +# endif +# ifdef _S_IFSOCK +# undef _S_IFSOCK +# endif + +# define _S_IFIFO 0x1000 /* FIFO */ +# define _S_IFCHR 0x2000 /* Character */ +# define _S_IFBLK 0x3000 /* Block */ +# define _S_IFDIR 0x4000 /* Directory */ +# define _S_IFREG 0x8000 /* Regular */ +# define _S_IFSOCK 0xC000 /* Socket */ + +# ifdef S_ISBLK +# undef S_ISBLK +# endif +# ifdef S_ISFIFO +# undef S_ISFIFO +# endif +# ifdef S_ISCHR +# undef S_ISCHR +# endif +# ifdef S_ISDIR +# undef S_ISDIR +# endif +# ifdef S_ISREG +# undef S_ISREG +# endif +# ifdef S_ISSOCK +# undef S_ISSOCK +# endif + +# define S_ISBLK(mode) (((mode) & _S_IFMT) == _S_IFBLK) +# define S_ISFIFO(mode) (((mode) & _S_IFMT) == _S_IFIFO) +# define S_ISCHR(mode) (((mode) & _S_IFMT) == _S_IFCHR) +# define S_ISDIR(mode) (((mode) & _S_IFMT) == _S_IFDIR) +# define S_ISREG(mode) (((mode) & _S_IFMT) == _S_IFREG) +# define S_ISSOCK(mode) (((mode) & _S_IFMT) == _S_IFSOCK) + +#endif /* __MINGW32__ */ + +/* Some more definitions for the native Windows port. */ +#ifdef __MINGW32__ +# define mkdir(path, mode) mkdir (path) +# define fsync(fd) _commit (fd) +# define fchmod(fd, mode) (-1) +#endif /* __MINGW32__ */ @@ -123,6 +198,7 @@ /* {Permissions} */ +#ifdef HAVE_CHOWN SCM_DEFINE (scm_chown, "chown", 3, 0, 0, (SCM object, SCM owner, SCM group), "Change the ownership and group of the file referred to by @var{object} to\n" @@ -156,7 +232,6 @@ SCM_DEFINE (scm_chown, "chown", 3, 0, 0, #endif { SCM_VALIDATE_STRING (1, object); - SCM_STRING_COERCE_0TERMINATION_X (object); SCM_SYSCALL (rv = chown (SCM_STRING_CHARS (object), SCM_INUM (owner), SCM_INUM (group))); } @@ -165,6 +240,7 @@ SCM_DEFINE (scm_chown, "chown", 3, 0, 0, return SCM_UNSPECIFIED; } #undef FUNC_NAME +#endif /* HAVE_CHOWN */ SCM_DEFINE (scm_chmod, "chmod", 2, 0, 0, @@ -195,7 +271,6 @@ SCM_DEFINE (scm_chmod, "chmod", 2, 0, 0, else { SCM_VALIDATE_STRING (1, object); - SCM_STRING_COERCE_0TERMINATION_X (object); SCM_SYSCALL (rv = chmod (SCM_STRING_CHARS (object), SCM_INUM (mode))); } if (rv == -1) @@ -231,8 +306,8 @@ SCM_DEFINE (scm_umask, "umask", 0, 1, 0, SCM_DEFINE (scm_open_fdes, "open-fdes", 2, 1, 0, (SCM path, SCM flags, SCM mode), - "Similar to @code{open} but returns a file descriptor instead of a\n" - "port.") + "Similar to @code{open} but return a file descriptor instead of\n" + "a port.") #define FUNC_NAME s_scm_open_fdes { int fd; @@ -240,9 +315,8 @@ SCM_DEFINE (scm_open_fdes, "open-fdes", 2, 1, 0, int imode; SCM_VALIDATE_STRING (1, path); - SCM_STRING_COERCE_0TERMINATION_X (path); - iflags = SCM_NUM2LONG(2,flags); - imode = SCM_NUM2LONG_DEF(3,mode,0666); + iflags = SCM_NUM2INT (2, flags); + imode = SCM_NUM2INT_DEF (3, mode, 0666); SCM_SYSCALL (fd = open (SCM_STRING_CHARS (path), iflags, imode)); if (fd == -1) SCM_SYSERROR; @@ -263,7 +337,7 @@ SCM_DEFINE (scm_open, "open", 2, 1, 0, "Open the file read-only.\n" "@end defvar\n" "@defvar O_WRONLY\n" - "Open the file write-only. \n" + "Open the file write-only.\n" "@end defvar\n" "@defvar O_RDWR\n" "Open the file read/write.\n" @@ -284,7 +358,7 @@ SCM_DEFINE (scm_open, "open", 2, 1, 0, int iflags; fd = SCM_INUM (scm_open_fdes (path, flags, mode)); - iflags = SCM_NUM2LONG (2,flags); + iflags = SCM_NUM2INT (2, flags); if (iflags & O_RDWR) { if (iflags & O_APPEND) @@ -309,7 +383,7 @@ SCM_DEFINE (scm_open, "open", 2, 1, 0, SCM_DEFINE (scm_close, "close", 1, 0, 0, (SCM fd_or_port), - "Similar to close-port (@pxref{Generic Port Operations, close-port}),\n" + "Similar to close-port (@pxref{Closing, close-port}),\n" "but also works on file descriptors. A side\n" "effect of closing a file descriptor is that any ports using that file\n" "descriptor are moved to a different file descriptor and have\n" @@ -331,7 +405,7 @@ SCM_DEFINE (scm_close, "close", 1, 0, 0, not an error. */ if (rv < 0 && errno != EBADF) SCM_SYSERROR; - return SCM_NEGATE_BOOL(rv < 0); + return SCM_BOOL (rv >= 0); } #undef FUNC_NAME @@ -373,7 +447,7 @@ SCM_SYMBOL (scm_sym_unknown, "unknown"); static SCM scm_stat2scm (struct stat *stat_temp) { - SCM ans = scm_make_vector (SCM_MAKINUM (15), SCM_UNSPECIFIED); + SCM ans = scm_c_make_vector (15, SCM_UNSPECIFIED); SCM *ve = SCM_VELTS (ans); ve[0] = scm_ulong2num ((unsigned long) stat_temp->st_dev); @@ -382,7 +456,7 @@ scm_stat2scm (struct stat *stat_temp) ve[3] = scm_ulong2num ((unsigned long) stat_temp->st_nlink); ve[4] = scm_ulong2num ((unsigned long) stat_temp->st_uid); ve[5] = scm_ulong2num ((unsigned long) stat_temp->st_gid); -#ifdef HAVE_ST_RDEV +#ifdef HAVE_STRUCT_STAT_ST_RDEV ve[6] = scm_ulong2num ((unsigned long) stat_temp->st_rdev); #else ve[6] = SCM_BOOL_F; @@ -391,12 +465,12 @@ scm_stat2scm (struct stat *stat_temp) ve[8] = scm_ulong2num ((unsigned long) stat_temp->st_atime); ve[9] = scm_ulong2num ((unsigned long) stat_temp->st_mtime); ve[10] = scm_ulong2num ((unsigned long) stat_temp->st_ctime); -#ifdef HAVE_ST_BLKSIZE +#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE ve[11] = scm_ulong2num ((unsigned long) stat_temp->st_blksize); #else ve[11] = scm_ulong2num (4096L); #endif -#ifdef HAVE_ST_BLOCKS +#ifdef HAVE_STRUCT_STAT_ST_BLOCKS ve[12] = scm_ulong2num ((unsigned long) stat_temp->st_blocks); #else ve[12] = SCM_BOOL_F; @@ -462,25 +536,53 @@ scm_stat2scm (struct stat *stat_temp) return ans; } +#ifdef __MINGW32__ +/* + * Try getting the appropiate stat buffer for a given file descriptor + * under Windows. It differentiates between file, pipe and socket + * descriptors. + */ +static int fstat_Win32 (int fdes, struct stat *buf) +{ + int error, optlen = sizeof (int); + + memset (buf, 0, sizeof (struct stat)); + + /* Is this a socket ? */ + if (getsockopt (fdes, SOL_SOCKET, SO_ERROR, (void *) &error, &optlen) >= 0) + { + buf->st_mode = _S_IFSOCK | _S_IREAD | _S_IWRITE | _S_IEXEC; + buf->st_nlink = 1; + buf->st_atime = buf->st_ctime = buf->st_mtime = time (NULL); + return 0; + } + /* Maybe a regular file or pipe ? */ + return fstat (fdes, buf); +} +#endif /* __MINGW32__ */ + SCM_DEFINE (scm_stat, "stat", 1, 0, 0, (SCM object), - "Returns an object containing various information\n" - "about the file determined by @var{obj}.\n" - "@var{obj} can be a string containing a file name or a port or integer file\n" - "descriptor which is open on a file (in which case @code{fstat} is used\n" - "as the underlying system call).\n\n" - "The object returned by @code{stat} can be passed as a single parameter\n" - "to the following procedures, all of which return integers:\n\n" + "Return an object containing various information about the file\n" + "determined by @var{obj}. @var{obj} can be a string containing\n" + "a file name or a port or integer file descriptor which is open\n" + "on a file (in which case @code{fstat} is used as the underlying\n" + "system call).\n" + "\n" + "The object returned by @code{stat} can be passed as a single\n" + "parameter to the following procedures, all of which return\n" + "integers:\n" + "\n" "@table @code\n" "@item stat:dev\n" "The device containing the file.\n" "@item stat:ino\n" - "The file serial number, which distinguishes this file from all other\n" - "files on the same device.\n" + "The file serial number, which distinguishes this file from all\n" + "other files on the same device.\n" "@item stat:mode\n" - "The mode of the file. This includes file type information\n" - "and the file permission bits. See @code{stat:type} and @code{stat:perms}\n" - "below.\n" + "The mode of the file. This includes file type information and\n" + "the file permission bits. See @code{stat:type} and\n" + "@code{stat:perms} below.\n" "@item stat:nlink\n" "The number of hard links to the file.\n" "@item stat:uid\n" @@ -499,18 +601,21 @@ SCM_DEFINE (scm_stat, "stat", 1, 0, 0, "@item stat:ctime\n" "The last modification time for the attributes of the file.\n" "@item stat:blksize\n" - "The optimal block size for reading or writing the file, in bytes.\n" + "The optimal block size for reading or writing the file, in\n" + "bytes.\n" "@item stat:blocks\n" - "The amount of disk space that the file occupies measured in units of\n" - "512 byte blocks.\n" - "@end table\n\n" + "The amount of disk space that the file occupies measured in\n" + "units of 512 byte blocks.\n" + "@end table\n" + "\n" "In addition, the following procedures return the information\n" - "from stat:mode in a more convenient form:\n\n" + "from stat:mode in a more convenient form:\n" + "\n" "@table @code\n" "@item stat:type\n" "A symbol representing the type of file. Possible values are\n" - "regular, directory, symlink, block-special, char-special,\n" - "fifo, socket and unknown\n" + "regular, directory, symlink, block-special, char-special, fifo,\n" + "socket and unknown\n" "@item stat:perms\n" "An integer representing the access permission bits.\n" "@end table") @@ -521,31 +626,46 @@ SCM_DEFINE (scm_stat, "stat", 1, 0, 0, struct stat stat_temp; if (SCM_INUMP (object)) - SCM_SYSCALL (rv = fstat (SCM_INUM (object), &stat_temp)); + { +#ifdef __MINGW32__ + SCM_SYSCALL (rv = fstat_Win32 (SCM_INUM (object), &stat_temp)); +#else + SCM_SYSCALL (rv = fstat (SCM_INUM (object), &stat_temp)); +#endif + } + else if (SCM_STRINGP (object)) + { +#ifdef __MINGW32__ + char *p, *file = strdup (SCM_STRING_CHARS (object)); + p = file + strlen (file) - 1; + while (p > file && (*p == '/' || *p == '\\')) + *p-- = '\0'; + SCM_SYSCALL (rv = stat (file, &stat_temp)); + free (file); +#else + SCM_SYSCALL (rv = stat (SCM_STRING_CHARS (object), &stat_temp)); +#endif + } else { - SCM_VALIDATE_NIM (1,object); - if (SCM_STRINGP (object)) - { - SCM_STRING_COERCE_0TERMINATION_X (object); - SCM_SYSCALL (rv = stat (SCM_STRING_CHARS (object), &stat_temp)); - } - else - { - object = SCM_COERCE_OUTPORT (object); - SCM_VALIDATE_OPFPORT(1,object); - fdes = SCM_FPORT_FDES (object); - SCM_SYSCALL (rv = fstat (fdes, &stat_temp)); - } + object = SCM_COERCE_OUTPORT (object); + SCM_VALIDATE_OPFPORT (1, object); + fdes = SCM_FPORT_FDES (object); +#ifdef __MINGW32__ + SCM_SYSCALL (rv = fstat_Win32 (fdes, &stat_temp)); +#else + SCM_SYSCALL (rv = fstat (fdes, &stat_temp)); +#endif } + if (rv == -1) { int en = errno; SCM_SYSERROR_MSG ("~A: ~S", - scm_listify (scm_makfrom0str (strerror (errno)), - object, - SCM_UNDEFINED), en); + scm_list_2 (scm_makfrom0str (strerror (errno)), + object), + en); } return scm_stat2scm (&stat_temp); } @@ -555,39 +675,39 @@ SCM_DEFINE (scm_stat, "stat", 1, 0, 0, /* {Modifying Directories} */ +#ifdef HAVE_LINK SCM_DEFINE (scm_link, "link", 2, 0, 0, (SCM oldpath, SCM newpath), - "Creates a new name @var{path-to} in the file system for the file\n" - "named by @var{path-from}. If @var{path-from} is a symbolic link, the\n" - "link may or may not be followed depending on the system.") + "Creates a new name @var{newpath} in the file system for the\n" + "file named by @var{oldpath}. If @var{oldpath} is a symbolic\n" + "link, the link may or may not be followed depending on the\n" + "system.") #define FUNC_NAME s_scm_link { int val; SCM_VALIDATE_STRING (1, oldpath); - SCM_STRING_COERCE_0TERMINATION_X (oldpath); SCM_VALIDATE_STRING (2, newpath); - SCM_STRING_COERCE_0TERMINATION_X (newpath); - SCM_SYSCALL (val = link (SCM_STRING_CHARS (oldpath), SCM_STRING_CHARS (newpath))); + SCM_SYSCALL (val = link (SCM_STRING_CHARS (oldpath), + SCM_STRING_CHARS (newpath))); if (val != 0) SCM_SYSERROR; return SCM_UNSPECIFIED; } #undef FUNC_NAME +#endif /* HAVE_LINK */ SCM_DEFINE (scm_rename, "rename-file", 2, 0, 0, (SCM oldname, SCM newname), - "Renames the file specified by @var{path-from} to @var{path-to}.\n" + "Renames the file specified by @var{oldname} to @var{newname}.\n" "The return value is unspecified.") #define FUNC_NAME s_scm_rename { int rv; SCM_VALIDATE_STRING (1, oldname); SCM_VALIDATE_STRING (2, newname); - SCM_STRING_COERCE_0TERMINATION_X (oldname); - SCM_STRING_COERCE_0TERMINATION_X (newname); #ifdef HAVE_RENAME SCM_SYSCALL (rv = rename (SCM_STRING_CHARS (oldname), SCM_STRING_CHARS (newname))); #else @@ -614,7 +734,6 @@ SCM_DEFINE (scm_delete_file, "delete-file", 1, 0, 0, { int ans; SCM_VALIDATE_STRING (1, str); - SCM_STRING_COERCE_0TERMINATION_X (str); SCM_SYSCALL (ans = unlink (SCM_STRING_CHARS (str))); if (ans != 0) SCM_SYSERROR; @@ -634,7 +753,6 @@ SCM_DEFINE (scm_mkdir, "mkdir", 1, 1, 0, int rv; mode_t mask; SCM_VALIDATE_STRING (1, path); - SCM_STRING_COERCE_0TERMINATION_X (path); if (SCM_UNBNDP (mode)) { mask = umask (0); @@ -663,7 +781,6 @@ SCM_DEFINE (scm_rmdir, "rmdir", 1, 0, 0, int val; SCM_VALIDATE_STRING (1, path); - SCM_STRING_COERCE_0TERMINATION_X (path); SCM_SYSCALL (val = rmdir (SCM_STRING_CHARS (path))); if (val != 0) SCM_SYSERROR; @@ -673,21 +790,24 @@ SCM_DEFINE (scm_rmdir, "rmdir", 1, 0, 0, #endif + /* {Examining Directories} */ -long scm_tc16_dir; +scm_t_bits scm_tc16_dir; + SCM_DEFINE (scm_directory_stream_p, "directory-stream?", 1, 0, 0, (SCM obj), - "Returns a boolean indicating whether @var{object} is a directory stream\n" - "as returned by @code{opendir}.") + "Return a boolean indicating whether @var{object} is a directory\n" + "stream as returned by @code{opendir}.") #define FUNC_NAME s_scm_directory_stream_p { - return SCM_BOOL(SCM_DIRP (obj)); + return SCM_BOOL (SCM_DIRP (obj)); } #undef FUNC_NAME + SCM_DEFINE (scm_opendir, "opendir", 1, 0, 0, (SCM dirname), "Open the directory specified by @var{path} and return a directory\n" @@ -696,11 +816,10 @@ SCM_DEFINE (scm_opendir, "opendir", 1, 0, 0, { DIR *ds; SCM_VALIDATE_STRING (1, dirname); - SCM_STRING_COERCE_0TERMINATION_X (dirname); SCM_SYSCALL (ds = opendir (SCM_STRING_CHARS (dirname))); if (ds == NULL) SCM_SYSERROR; - SCM_RETURN_NEWSMOB (scm_tc16_dir | SCM_OPN, ds); + SCM_RETURN_NEWSMOB (scm_tc16_dir | SCM_DIR_FLAG_OPEN, ds); } #undef FUNC_NAME @@ -713,61 +832,68 @@ SCM_DEFINE (scm_readdir, "readdir", 1, 0, 0, #define FUNC_NAME s_scm_readdir { struct dirent *rdent; - SCM_VALIDATE_OPDIR (1,port); + + SCM_VALIDATE_DIR (1, port); + if (!SCM_DIR_OPEN_P (port)) + SCM_MISC_ERROR ("Directory ~S is not open.", scm_list_1 (port)); + errno = 0; SCM_SYSCALL (rdent = readdir ((DIR *) SCM_CELL_WORD_1 (port))); if (errno != 0) SCM_SYSERROR; - return (rdent ? scm_makfromstr (rdent->d_name, NAMLEN (rdent), 0) + + return (rdent ? scm_mem2string (rdent->d_name, NAMLEN (rdent)) : SCM_EOF_VAL); } #undef FUNC_NAME - SCM_DEFINE (scm_rewinddir, "rewinddir", 1, 0, 0, (SCM port), "Reset the directory port @var{stream} so that the next call to\n" "@code{readdir} will return the first directory entry.") #define FUNC_NAME s_scm_rewinddir { - SCM_VALIDATE_OPDIR (1,port); + SCM_VALIDATE_DIR (1, port); + if (!SCM_DIR_OPEN_P (port)) + SCM_MISC_ERROR ("Directory ~S is not open.", scm_list_1 (port)); + rewinddir ((DIR *) SCM_CELL_WORD_1 (port)); + return SCM_UNSPECIFIED; } #undef FUNC_NAME - SCM_DEFINE (scm_closedir, "closedir", 1, 0, 0, (SCM port), "Close the directory stream @var{stream}.\n" "The return value is unspecified.") #define FUNC_NAME s_scm_closedir { - int sts; + SCM_VALIDATE_DIR (1, port); - SCM_VALIDATE_DIR (1,port); - if (SCM_CLOSEDP (port)) + if (SCM_DIR_OPEN_P (port)) { - return SCM_UNSPECIFIED; + int sts; + + SCM_SYSCALL (sts = closedir ((DIR *) SCM_CELL_WORD_1 (port))); + if (sts != 0) + SCM_SYSERROR; + + SCM_SET_CELL_WORD_0 (port, scm_tc16_dir); } - SCM_SYSCALL (sts = closedir ((DIR *) SCM_CELL_WORD_1 (port))); - if (sts != 0) - SCM_SYSERROR; - SCM_SET_CELL_WORD_0 (port, scm_tc16_dir); + return SCM_UNSPECIFIED; } #undef FUNC_NAME - - static int -scm_dir_print (SCM exp, SCM port, scm_print_state *pstate) +scm_dir_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) { scm_puts ("#<", port); - if (SCM_CLOSEDP (exp)) + if (!SCM_DIR_OPEN_P (exp)) scm_puts ("closed: ", port); scm_puts ("directory stream ", port); scm_intprint (SCM_CELL_WORD_1 (exp), 16, port); @@ -776,10 +902,10 @@ scm_dir_print (SCM exp, SCM port, scm_print_state *pstate) } -static scm_sizet +static size_t scm_dir_free (SCM p) { - if (SCM_OPENP (p)) + if (SCM_DIR_OPEN_P (p)) closedir ((DIR *) SCM_CELL_WORD_1 (p)); return 0; } @@ -798,7 +924,6 @@ SCM_DEFINE (scm_chdir, "chdir", 1, 0, 0, int ans; SCM_VALIDATE_STRING (1, str); - SCM_STRING_COERCE_0TERMINATION_X (str); SCM_SYSCALL (ans = chdir (SCM_STRING_CHARS (str))); if (ans != 0) SCM_SYSERROR; @@ -809,25 +934,25 @@ SCM_DEFINE (scm_chdir, "chdir", 1, 0, 0, #ifdef HAVE_GETCWD SCM_DEFINE (scm_getcwd, "getcwd", 0, 0, 0, (), - "Returns the name of the current working directory.") + "Return the name of the current working directory.") #define FUNC_NAME s_scm_getcwd { char *rv; - scm_sizet size = 100; + size_t size = 100; char *wd; SCM result; - wd = scm_must_malloc (size, FUNC_NAME); + wd = scm_malloc (size); while ((rv = getcwd (wd, size)) == 0 && errno == ERANGE) { - scm_must_free (wd); + free (wd); size *= 2; - wd = scm_must_malloc (size, FUNC_NAME); + wd = scm_malloc (size); } if (rv == 0) SCM_SYSERROR; - result = scm_makfromstr (wd, strlen (wd), 0); - scm_must_free (wd); + result = scm_mem2string (wd, strlen (wd)); + free (wd); return result; } #undef FUNC_NAME @@ -860,7 +985,7 @@ set_element (SELECT_TYPE *set, SCM *ports_ready, SCM element, int pos) if (pos == SCM_ARG1) { /* check whether port has buffered input. */ - scm_port *pt = SCM_PTAB_ENTRY (element); + scm_t_port *pt = SCM_PTAB_ENTRY (element); if (pt->read_pos < pt->read_end) use_buf = 1; @@ -868,7 +993,7 @@ set_element (SELECT_TYPE *set, SCM *ports_ready, SCM element, int pos) else if (pos == SCM_ARG2) { /* check whether port's output buffer has room. */ - scm_port *pt = SCM_PTAB_ENTRY (element); + scm_t_port *pt = SCM_PTAB_ENTRY (element); /* > 1 since writing the last byte in the buffer causes flush. */ if (pt->write_end - pt->write_pos > 1) @@ -908,7 +1033,7 @@ fill_select_type (SELECT_TYPE *set, SCM *ports_ready, SCM list_or_vec, int pos) } else { - while (!SCM_NULLP (list_or_vec)) + while (!SCM_NULL_OR_NIL_P (list_or_vec)) { int fd = set_element (set, ports_ready, SCM_CAR (list_or_vec), pos); @@ -968,7 +1093,7 @@ retrieve_select_type (SELECT_TYPE *set, SCM ports_ready, SCM list_or_vec) else { /* list_or_vec must be a list. */ - while (!SCM_NULLP (list_or_vec)) + while (!SCM_NULL_OR_NIL_P (list_or_vec)) { answer_list = get_element (set, SCM_CAR (list_or_vec), answer_list); list_or_vec = SCM_CDR (list_or_vec); @@ -1005,8 +1130,7 @@ SCM_DEFINE (scm_select, "select", 3, 2, 0, "The @var{usecs} argument is not supported.\n" "Multiple values are returned instead of a list.\n" "Duplicates in the input vectors appear only once in output.\n" - "An additional @code{select!} interface is provided.\n" - ) + "An additional @code{select!} interface is provided.") #define FUNC_NAME s_scm_select { struct timeval timeout; @@ -1118,18 +1242,16 @@ SCM_DEFINE (scm_select, "select", 3, 2, 0, if (rv < 0) SCM_SYSERROR; } - return scm_listify (retrieve_select_type (&read_set, read_ports_ready, - reads), - retrieve_select_type (&write_set, write_ports_ready, - writes), - retrieve_select_type (&except_set, SCM_EOL, excepts), - SCM_UNDEFINED); + return scm_list_3 (retrieve_select_type (&read_set, read_ports_ready, reads), + retrieve_select_type (&write_set, write_ports_ready, writes), + retrieve_select_type (&except_set, SCM_EOL, excepts)); } #undef FUNC_NAME #endif /* HAVE_SELECT */ +#ifdef HAVE_FCNTL SCM_DEFINE (scm_fcntl, "fcntl", 2, 1, 0, (SCM object, SCM cmd, SCM value), "Apply @var{command} to the specified file descriptor or the underlying\n" @@ -1184,6 +1306,7 @@ SCM_DEFINE (scm_fcntl, "fcntl", 2, 1, 0, return SCM_MAKINUM (rv); } #undef FUNC_NAME +#endif /* HAVE_FCNTL */ SCM_DEFINE (scm_fsync, "fsync", 1, 0, 0, (SCM object), @@ -1224,8 +1347,6 @@ SCM_DEFINE (scm_symlink, "symlink", 2, 0, 0, SCM_VALIDATE_STRING (1, oldpath); SCM_VALIDATE_STRING (2, newpath); - SCM_STRING_COERCE_0TERMINATION_X (oldpath); - SCM_STRING_COERCE_0TERMINATION_X (newpath); SCM_SYSCALL (val = symlink (SCM_STRING_CHARS (oldpath), SCM_STRING_CHARS (newpath))); if (val != 0) SCM_SYSERROR; @@ -1237,9 +1358,8 @@ SCM_DEFINE (scm_symlink, "symlink", 2, 0, 0, #ifdef HAVE_READLINK SCM_DEFINE (scm_readlink, "readlink", 1, 0, 0, (SCM path), - "Returns the value of the symbolic link named by\n" - "@var{path} (a string), i.e., the\n" - "file that the link points to.") + "Return the value of the symbolic link named by @var{path} (a\n" + "string), i.e., the file that the link points to.") #define FUNC_NAME s_scm_readlink { int rv; @@ -1247,18 +1367,17 @@ SCM_DEFINE (scm_readlink, "readlink", 1, 0, 0, char *buf; SCM result; SCM_VALIDATE_STRING (1, path); - SCM_STRING_COERCE_0TERMINATION_X (path); - buf = scm_must_malloc (size, FUNC_NAME); + buf = scm_malloc (size); while ((rv = readlink (SCM_STRING_CHARS (path), buf, size)) == size) { - scm_must_free (buf); + free (buf); size *= 2; - buf = scm_must_malloc (size, FUNC_NAME); + buf = scm_malloc (size); } if (rv == -1) SCM_SYSERROR; - result = scm_makfromstr (buf, rv, 0); - scm_must_free (buf); + result = scm_mem2string (buf, rv); + free (buf); return result; } #undef FUNC_NAME @@ -1268,7 +1387,7 @@ SCM_DEFINE (scm_readlink, "readlink", 1, 0, 0, SCM_DEFINE (scm_lstat, "lstat", 1, 0, 0, (SCM str), "Similar to @code{stat}, but does not follow symbolic links, i.e.,\n" - "it will return information about a symbolic link itself, not the \n" + "it will return information about a symbolic link itself, not the\n" "file it points to. @var{path} must be a string.") #define FUNC_NAME s_scm_lstat { @@ -1276,16 +1395,14 @@ SCM_DEFINE (scm_lstat, "lstat", 1, 0, 0, struct stat stat_temp; SCM_VALIDATE_STRING (1, str); - SCM_STRING_COERCE_0TERMINATION_X (str); SCM_SYSCALL (rv = lstat (SCM_STRING_CHARS (str), &stat_temp)); if (rv != 0) { int en = errno; SCM_SYSERROR_MSG ("~A: ~S", - scm_listify (scm_makfrom0str (strerror (errno)), - str, - SCM_UNDEFINED), en); + scm_list_2 (scm_makfrom0str (strerror (errno)), str), + en); } return scm_stat2scm(&stat_temp); } @@ -1304,9 +1421,7 @@ SCM_DEFINE (scm_copy_file, "copy-file", 2, 0, 0, struct stat oldstat; SCM_VALIDATE_STRING (1, oldfile); - SCM_STRING_COERCE_0TERMINATION_X (oldfile); SCM_VALIDATE_STRING (2, newfile); - SCM_STRING_COERCE_0TERMINATION_X (newfile); if (stat (SCM_STRING_CHARS (oldfile), &oldstat) == -1) SCM_SYSERROR; oldfd = open (SCM_STRING_CHARS (oldfile), O_RDONLY); @@ -1340,7 +1455,9 @@ SCM scm_dot_string; SCM_DEFINE (scm_dirname, "dirname", 1, 0, 0, (SCM filename), - "") + "Return the directory name component of the file name\n" + "@var{filename}. If @var{filename} does not contain a directory\n" + "component, @code{.} is returned.") #define FUNC_NAME s_scm_dirname { char *s; @@ -1349,16 +1466,26 @@ SCM_DEFINE (scm_dirname, "dirname", 1, 0, 0, SCM_VALIDATE_STRING (1,filename); - s = SCM_ROCHARS (filename); + s = SCM_STRING_CHARS (filename); len = SCM_STRING_LENGTH (filename); i = len - 1; +#ifdef __MINGW32__ + while (i >= 0 && (s[i] == '/' || s[i] == '\\')) --i; + while (i >= 0 && (s[i] != '/' && s[i] != '\\')) --i; + while (i >= 0 && (s[i] == '/' || s[i] == '\\')) --i; +#else while (i >= 0 && s[i] == '/') --i; while (i >= 0 && s[i] != '/') --i; while (i >= 0 && s[i] == '/') --i; +#endif /* ndef __MINGW32__ */ if (i < 0) { +#ifdef __MINGW32__ + if (len > 0 && (s[0] == '/' || s[0] == '\\')) +#else if (len > 0 && s[0] == '/') +#endif /* ndef __MINGW32__ */ return scm_substring (filename, SCM_INUM0, SCM_MAKINUM (1)); else return scm_dot_string; @@ -1370,14 +1497,17 @@ SCM_DEFINE (scm_dirname, "dirname", 1, 0, 0, SCM_DEFINE (scm_basename, "basename", 1, 1, 0, (SCM filename, SCM suffix), - "") + "Return the base name of the file name @var{filename}. The\n" + "base name is the file name without any directory components.\n" + "If @var{suffix} is privided, and is equal to the end of\n" + "@var{basename}, it is removed also.") #define FUNC_NAME s_scm_basename { char *f, *s = 0; int i, j, len, end; SCM_VALIDATE_STRING (1,filename); - f = SCM_ROCHARS (filename); + f = SCM_STRING_CHARS (filename); len = SCM_STRING_LENGTH (filename); if (SCM_UNBNDP (suffix)) @@ -1385,19 +1515,31 @@ SCM_DEFINE (scm_basename, "basename", 1, 1, 0, else { SCM_VALIDATE_STRING (2, suffix); - s = SCM_ROCHARS (suffix); + s = SCM_STRING_CHARS (suffix); j = SCM_STRING_LENGTH (suffix) - 1; } i = len - 1; +#ifdef __MINGW32__ + while (i >= 0 && (f[i] == '/' || f[i] == '\\')) --i; +#else while (i >= 0 && f[i] == '/') --i; +#endif /* ndef __MINGW32__ */ end = i; while (i >= 0 && j >= 0 && f[i] == s[j]) --i, --j; if (j == -1) end = i; +#ifdef __MINGW32__ + while (i >= 0 && (f[i] != '/' || f[i] != '\\')) --i; +#else while (i >= 0 && f[i] != '/') --i; +#endif /* ndef __MINGW32__ */ if (i == end) { +#ifdef __MINGW32__ + if (len > 0 && (f[0] == '/' || f[i] == '\\')) +#else if (len > 0 && f[0] == '/') +#endif /* ndef __MINGW32__ */ return scm_substring (filename, SCM_INUM0, SCM_MAKINUM (1)); else return scm_dot_string; @@ -1414,71 +1556,74 @@ SCM_DEFINE (scm_basename, "basename", 1, 1, 0, void scm_init_filesys () { - scm_tc16_dir = scm_make_smob_type_mfpe ("directory", 0, - NULL, scm_dir_free,scm_dir_print, NULL); + scm_tc16_dir = scm_make_smob_type ("directory", 0); + scm_set_smob_free (scm_tc16_dir, scm_dir_free); + scm_set_smob_print (scm_tc16_dir, scm_dir_print); scm_dot_string = scm_permanent_object (scm_makfrom0str (".")); #ifdef O_RDONLY -scm_sysintern ("O_RDONLY", scm_long2num (O_RDONLY)); + scm_c_define ("O_RDONLY", scm_long2num (O_RDONLY)); #endif #ifdef O_WRONLY -scm_sysintern ("O_WRONLY", scm_long2num (O_WRONLY)); + scm_c_define ("O_WRONLY", scm_long2num (O_WRONLY)); #endif #ifdef O_RDWR -scm_sysintern ("O_RDWR", scm_long2num (O_RDWR)); + scm_c_define ("O_RDWR", scm_long2num (O_RDWR)); #endif #ifdef O_CREAT -scm_sysintern ("O_CREAT", scm_long2num (O_CREAT)); + scm_c_define ("O_CREAT", scm_long2num (O_CREAT)); #endif #ifdef O_EXCL -scm_sysintern ("O_EXCL", scm_long2num (O_EXCL)); + scm_c_define ("O_EXCL", scm_long2num (O_EXCL)); #endif #ifdef O_NOCTTY -scm_sysintern ("O_NOCTTY", scm_long2num (O_NOCTTY)); + scm_c_define ("O_NOCTTY", scm_long2num (O_NOCTTY)); #endif #ifdef O_TRUNC -scm_sysintern ("O_TRUNC", scm_long2num (O_TRUNC)); + scm_c_define ("O_TRUNC", scm_long2num (O_TRUNC)); #endif #ifdef O_APPEND -scm_sysintern ("O_APPEND", scm_long2num (O_APPEND)); + scm_c_define ("O_APPEND", scm_long2num (O_APPEND)); #endif #ifdef O_NONBLOCK -scm_sysintern ("O_NONBLOCK", scm_long2num (O_NONBLOCK)); + scm_c_define ("O_NONBLOCK", scm_long2num (O_NONBLOCK)); #endif #ifdef O_NDELAY -scm_sysintern ("O_NDELAY", scm_long2num (O_NDELAY)); + scm_c_define ("O_NDELAY", scm_long2num (O_NDELAY)); #endif #ifdef O_SYNC -scm_sysintern ("O_SYNC", scm_long2num (O_SYNC)); + scm_c_define ("O_SYNC", scm_long2num (O_SYNC)); #endif #ifdef F_DUPFD -scm_sysintern ("F_DUPFD", scm_long2num (F_DUPFD)); + scm_c_define ("F_DUPFD", scm_long2num (F_DUPFD)); #endif #ifdef F_GETFD -scm_sysintern ("F_GETFD", scm_long2num (F_GETFD)); + scm_c_define ("F_GETFD", scm_long2num (F_GETFD)); #endif #ifdef F_SETFD -scm_sysintern ("F_SETFD", scm_long2num (F_SETFD)); + scm_c_define ("F_SETFD", scm_long2num (F_SETFD)); #endif #ifdef F_GETFL -scm_sysintern ("F_GETFL", scm_long2num (F_GETFL)); + scm_c_define ("F_GETFL", scm_long2num (F_GETFL)); #endif #ifdef F_SETFL -scm_sysintern ("F_SETFL", scm_long2num (F_SETFL)); + scm_c_define ("F_SETFL", scm_long2num (F_SETFL)); #endif #ifdef F_GETOWN -scm_sysintern ("F_GETOWN", scm_long2num (F_GETOWN)); + scm_c_define ("F_GETOWN", scm_long2num (F_GETOWN)); #endif #ifdef F_SETOWN -scm_sysintern ("F_SETOWN", scm_long2num (F_SETOWN)); + scm_c_define ("F_SETOWN", scm_long2num (F_SETOWN)); #endif #ifdef FD_CLOEXEC -scm_sysintern ("FD_CLOEXEC", scm_long2num (FD_CLOEXEC)); + scm_c_define ("FD_CLOEXEC", scm_long2num (FD_CLOEXEC)); #endif +#ifndef SCM_MAGIC_SNARFER #include "libguile/filesys.x" +#endif } /*