summaryrefslogtreecommitdiff
path: root/libguile
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2011-04-28 15:53:35 +0200
committerAndy Wingo <wingo@pobox.com>2011-04-28 15:53:35 +0200
commit1903eae4c9ab97b575dad4ab1f5cf05436d84ab3 (patch)
treedbb5a83c4dce6f6f10642b3d39ec76ee63dd77a5 /libguile
parent0c81a0c13ad39c381e4ff4d073e3158bcfd51a7a (diff)
parent91956a94fe6363cf69d574b56397962ec6ef4468 (diff)
downloadguile-1903eae4c9ab97b575dad4ab1f5cf05436d84ab3.tar.gz
Merge remote-tracking branch 'origin/stable-2.0'
Conflicts: GUILE-VERSION
Diffstat (limited to 'libguile')
-rw-r--r--libguile/Makefile.am5
-rw-r--r--libguile/filesys.c905
-rw-r--r--libguile/fports.c9
-rw-r--r--libguile/gc.c83
-rw-r--r--libguile/hashtab.c52
-rw-r--r--libguile/i18n.c35
-rw-r--r--libguile/init.c9
-rw-r--r--libguile/load.c42
-rw-r--r--libguile/numbers.c2
-rw-r--r--libguile/ports.c14
-rw-r--r--libguile/posix.c141
-rw-r--r--libguile/posix.h5
-rw-r--r--libguile/r6rs-ports.c20
-rw-r--r--libguile/script.c467
-rw-r--r--libguile/threads.c50
-rw-r--r--libguile/threads.h3
16 files changed, 771 insertions, 1071 deletions
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index ac27eb8fb..4790cd917 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -138,6 +138,7 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = \
expand.c \
extensions.c \
feature.c \
+ filesys.c \
fluids.c \
foreign.c \
fports.c \
@@ -242,6 +243,7 @@ DOT_X_FILES = \
expand.x \
extensions.x \
feature.x \
+ filesys.x \
fluids.x \
foreign.x \
fports.x \
@@ -342,6 +344,7 @@ DOT_DOC_FILES = \
expand.doc \
extensions.doc \
feature.doc \
+ filesys.doc \
fluids.doc \
foreign.doc \
fports.doc \
@@ -425,7 +428,7 @@ BUILT_SOURCES = cpp-E.c cpp-SIG.c libpath.h \
EXTRA_libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = _scm.h \
memmove.c strerror.c \
dynl.c regex-posix.c \
- filesys.c posix.c net_db.c socket.c \
+ posix.c net_db.c socket.c \
debug-malloc.c mkstemp.c \
win32-uname.c win32-dirent.c win32-socket.c \
locale-categories.h
diff --git a/libguile/filesys.c b/libguile/filesys.c
index 96752bcd7..b43536f0a 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -18,6 +18,10 @@
+/* This file contains POSIX file system access procedures. Procedures
+ essential to the compiler and run-time (`stat', `canonicalize-path',
+ etc.) are compiled even with `--disable-posix'. */
+
/* See stime.c for comments on why _POSIX_C_SOURCE is not always defined. */
#define _LARGEFILE64_SOURCE /* ask for stat64 etc */
@@ -158,6 +162,8 @@
+#ifdef HAVE_POSIX
+
/* {Permissions}
*/
@@ -203,64 +209,6 @@ SCM_DEFINE (scm_chown, "chown", 3, 0, 0,
#undef FUNC_NAME
#endif /* HAVE_CHOWN */
-
-SCM_DEFINE (scm_chmod, "chmod", 2, 0, 0,
- (SCM object, SCM mode),
- "Changes the permissions of the file referred to 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{fchmod} is used\n"
- "as the underlying system call).\n"
- "@var{mode} specifies\n"
- "the new permissions as a decimal number, e.g., @code{(chmod \"foo\" #o755)}.\n"
- "The return value is unspecified.")
-#define FUNC_NAME s_scm_chmod
-{
- int rv;
- int fdes;
-
- object = SCM_COERCE_OUTPORT (object);
-
- if (scm_is_integer (object) || SCM_OPFPORTP (object))
- {
- if (scm_is_integer (object))
- fdes = scm_to_int (object);
- else
- fdes = SCM_FPORT_FDES (object);
- SCM_SYSCALL (rv = fchmod (fdes, scm_to_int (mode)));
- }
- else
- {
- STRING_SYSCALL (object, c_object,
- rv = chmod (c_object, scm_to_int (mode)));
- }
- if (rv == -1)
- SCM_SYSERROR;
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_umask, "umask", 0, 1, 0,
- (SCM mode),
- "If @var{mode} is omitted, returns a decimal number representing the current\n"
- "file creation mask. Otherwise the file creation mask is set to\n"
- "@var{mode} and the previous value is returned.\n\n"
- "E.g., @code{(umask #o022)} sets the mask to octal 22, decimal 18.")
-#define FUNC_NAME s_scm_umask
-{
- mode_t mask;
- if (SCM_UNBNDP (mode))
- {
- mask = umask (0);
- umask (mask);
- }
- else
- {
- mask = umask (scm_to_uint (mode));
- }
- return scm_from_uint (mask);
-}
-#undef FUNC_NAME
-
SCM_DEFINE (scm_open_fdes, "open-fdes", 2, 1, 0,
@@ -386,6 +334,8 @@ SCM_DEFINE (scm_close_fdes, "close-fdes", 1, 0, 0,
}
#undef FUNC_NAME
+#endif /* HAVE_POSIX */
+
/* {Files}
*/
@@ -652,7 +602,34 @@ SCM_DEFINE (scm_stat, "stat", 1, 1, 0,
}
#undef FUNC_NAME
+#ifdef HAVE_LSTAT
+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"
+ "file it points to. @var{path} must be a string.")
+#define FUNC_NAME s_scm_lstat
+{
+ int rv;
+ struct stat_or_stat64 stat_temp;
+
+ STRING_SYSCALL (str, c_str, rv = lstat_or_lstat64 (c_str, &stat_temp));
+ if (rv != 0)
+ {
+ int en = errno;
+
+ SCM_SYSERROR_MSG ("~A: ~S",
+ scm_list_2 (scm_strerror (scm_from_int (en)), str),
+ en);
+ }
+ return scm_stat2scm (&stat_temp);
+}
+#undef FUNC_NAME
+#endif /* HAVE_LSTAT */
+
+#ifdef HAVE_POSIX
+
/* {Modifying Directories}
*/
@@ -677,280 +654,6 @@ SCM_DEFINE (scm_link, "link", 2, 0, 0,
#undef FUNC_NAME
#endif /* HAVE_LINK */
-#ifdef HAVE_RENAME
-#define my_rename rename
-#else
-static int
-my_rename (const char *oldname, const char *newname)
-{
- int rv;
-
- SCM_SYSCALL (rv = link (oldname, newname));
- if (rv == 0)
- {
- SCM_SYSCALL (rv = unlink (oldname));
- if (rv != 0)
- /* unlink failed. remove new name */
- SCM_SYSCALL (unlink (newname));
- }
- return rv;
-}
-#endif
-
-SCM_DEFINE (scm_rename, "rename-file", 2, 0, 0,
- (SCM oldname, SCM newname),
- "Renames the file specified by @var{oldname} to @var{newname}.\n"
- "The return value is unspecified.")
-#define FUNC_NAME s_scm_rename
-{
- int rv;
-
- STRING2_SYSCALL (oldname, c_oldname,
- newname, c_newname,
- rv = my_rename (c_oldname, c_newname));
- if (rv != 0)
- SCM_SYSERROR;
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_delete_file, "delete-file", 1, 0, 0,
- (SCM str),
- "Deletes (or \"unlinks\") the file specified by @var{path}.")
-#define FUNC_NAME s_scm_delete_file
-{
- int ans;
- STRING_SYSCALL (str, c_str, ans = unlink (c_str));
- if (ans != 0)
- SCM_SYSERROR;
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-#ifdef HAVE_MKDIR
-SCM_DEFINE (scm_mkdir, "mkdir", 1, 1, 0,
- (SCM path, SCM mode),
- "Create a new directory named by @var{path}. If @var{mode} is omitted\n"
- "then the permissions of the directory file are set using the current\n"
- "umask. Otherwise they are set to the decimal value specified with\n"
- "@var{mode}. The return value is unspecified.")
-#define FUNC_NAME s_scm_mkdir
-{
- int rv;
- mode_t mask;
-
- if (SCM_UNBNDP (mode))
- {
- mask = umask (0);
- umask (mask);
- STRING_SYSCALL (path, c_path, rv = mkdir (c_path, 0777 ^ mask));
- }
- else
- {
- STRING_SYSCALL (path, c_path, rv = mkdir (c_path, scm_to_uint (mode)));
- }
- if (rv != 0)
- SCM_SYSERROR;
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-#endif /* HAVE_MKDIR */
-
-#ifdef HAVE_RMDIR
-SCM_DEFINE (scm_rmdir, "rmdir", 1, 0, 0,
- (SCM path),
- "Remove the existing directory named by @var{path}. The directory must\n"
- "be empty for this to succeed. The return value is unspecified.")
-#define FUNC_NAME s_scm_rmdir
-{
- int val;
-
- STRING_SYSCALL (path, c_path, val = rmdir (c_path));
- if (val != 0)
- SCM_SYSERROR;
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-#endif
-
-
-
-/* {Examining Directories}
- */
-
-scm_t_bits scm_tc16_dir;
-
-
-SCM_DEFINE (scm_directory_stream_p, "directory-stream?", 1, 0, 0,
- (SCM obj),
- "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_from_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"
- "stream.")
-#define FUNC_NAME s_scm_opendir
-{
- DIR *ds;
- STRING_SYSCALL (dirname, c_dirname, ds = opendir (c_dirname));
- if (ds == NULL)
- SCM_SYSERROR;
- SCM_RETURN_NEWSMOB (scm_tc16_dir | (SCM_DIR_FLAG_OPEN<<16), ds);
-}
-#undef FUNC_NAME
-
-
-/* FIXME: The glibc manual has a portability note that readdir_r may not
- null-terminate its return string. The circumstances outlined for this
- are not clear, nor is it clear what should be done about it. Lets use
- NAMLEN and worry about what else should be done if/when someone can
- figure it out. */
-
-SCM_DEFINE (scm_readdir, "readdir", 1, 0, 0,
- (SCM port),
- "Return (as a string) the next directory entry from the directory stream\n"
- "@var{stream}. If there is no remaining entry to be read then the\n"
- "end of file object is returned.")
-#define FUNC_NAME s_scm_readdir
-{
- struct dirent_or_dirent64 *rdent;
-
- SCM_VALIDATE_DIR (1, port);
- if (!SCM_DIR_OPEN_P (port))
- SCM_MISC_ERROR ("Directory ~S is not open.", scm_list_1 (port));
-
-#if HAVE_READDIR_R
- /* As noted in the glibc manual, on various systems (such as Solaris) the
- d_name[] field is only 1 char and you're expected to size the dirent
- buffer for readdir_r based on NAME_MAX. The SCM_MAX expressions below
- effectively give either sizeof(d_name) or NAME_MAX+1, whichever is
- bigger.
-
- On solaris 10 there's no NAME_MAX constant, it's necessary to use
- pathconf(). We prefer NAME_MAX though, since it should be a constant
- and will therefore save a system call. We also prefer it since dirfd()
- is not available everywhere.
-
- An alternative to dirfd() would be to open() the directory and then use
- fdopendir(), if the latter is available. That'd let us hold the fd
- somewhere in the smob, or just the dirent size calculated once. */
- {
- struct dirent_or_dirent64 de; /* just for sizeof */
- DIR *ds = (DIR *) SCM_SMOB_DATA_1 (port);
-#ifdef NAME_MAX
- char buf [SCM_MAX (sizeof (de),
- sizeof (de) - sizeof (de.d_name) + NAME_MAX + 1)];
-#else
- char *buf;
- long name_max = fpathconf (dirfd (ds), _PC_NAME_MAX);
- if (name_max == -1)
- SCM_SYSERROR;
- buf = alloca (SCM_MAX (sizeof (de),
- sizeof (de) - sizeof (de.d_name) + name_max + 1));
-#endif
-
- errno = 0;
- SCM_SYSCALL (readdir_r_or_readdir64_r (ds, (struct dirent_or_dirent64 *) buf, &rdent));
- if (errno != 0)
- SCM_SYSERROR;
- if (! rdent)
- return SCM_EOF_VAL;
-
- return (rdent ? scm_from_locale_stringn (rdent->d_name, NAMLEN (rdent))
- : SCM_EOF_VAL);
- }
-#else
- {
- SCM ret;
- scm_dynwind_begin (0);
- scm_i_dynwind_pthread_mutex_lock (&scm_i_misc_mutex);
-
- errno = 0;
- SCM_SYSCALL (rdent = readdir_or_readdir64 ((DIR *) SCM_SMOB_DATA_1 (port)));
- if (errno != 0)
- SCM_SYSERROR;
-
- ret = (rdent ? scm_from_locale_stringn (rdent->d_name, NAMLEN (rdent))
- : SCM_EOF_VAL);
-
- scm_dynwind_end ();
- return ret;
- }
-#endif
-}
-#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_DIR (1, port);
- if (!SCM_DIR_OPEN_P (port))
- SCM_MISC_ERROR ("Directory ~S is not open.", scm_list_1 (port));
-
- rewinddir ((DIR *) SCM_SMOB_DATA_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
-{
- SCM_VALIDATE_DIR (1, port);
-
- if (SCM_DIR_OPEN_P (port))
- {
- int sts;
-
- SCM_SYSCALL (sts = closedir ((DIR *) SCM_SMOB_DATA_1 (port)));
- if (sts != 0)
- SCM_SYSERROR;
-
- SCM_SET_SMOB_DATA_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_UNUSED)
-{
- scm_puts ("#<", port);
- if (!SCM_DIR_OPEN_P (exp))
- scm_puts ("closed: ", port);
- scm_puts ("directory stream ", port);
- scm_uintprint (SCM_SMOB_DATA_1 (exp), 16, port);
- scm_putc ('>', port);
- return 1;
-}
-
-
-static size_t
-scm_dir_free (SCM p)
-{
- if (SCM_DIR_OPEN_P (p))
- closedir ((DIR *) SCM_SMOB_DATA_1 (p));
- return 0;
-}
-
/* {Navigating Directories}
*/
@@ -971,38 +674,6 @@ SCM_DEFINE (scm_chdir, "chdir", 1, 0, 0,
}
#undef FUNC_NAME
-#ifdef HAVE_GETCWD
-SCM_DEFINE (scm_getcwd, "getcwd", 0, 0, 0,
- (),
- "Return the name of the current working directory.")
-#define FUNC_NAME s_scm_getcwd
-{
- char *rv;
- size_t size = 100;
- char *wd;
- SCM result;
-
- wd = scm_malloc (size);
- while ((rv = getcwd (wd, size)) == 0 && errno == ERANGE)
- {
- free (wd);
- size *= 2;
- wd = scm_malloc (size);
- }
- if (rv == 0)
- {
- int save_errno = errno;
- free (wd);
- errno = save_errno;
- SCM_SYSERROR;
- }
- result = scm_from_locale_stringn (wd, strlen (wd));
- free (wd);
- return result;
-}
-#undef FUNC_NAME
-#endif /* HAVE_GETCWD */
-
#ifdef HAVE_SELECT
@@ -1427,31 +1098,6 @@ SCM_DEFINE (scm_readlink, "readlink", 1, 0, 0,
#undef FUNC_NAME
#endif /* HAVE_READLINK */
-#ifdef HAVE_LSTAT
-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"
- "file it points to. @var{path} must be a string.")
-#define FUNC_NAME s_scm_lstat
-{
- int rv;
- struct stat_or_stat64 stat_temp;
-
- STRING_SYSCALL (str, c_str, rv = lstat_or_lstat64 (c_str, &stat_temp));
- if (rv != 0)
- {
- int en = errno;
-
- SCM_SYSERROR_MSG ("~A: ~S",
- scm_list_2 (scm_strerror (scm_from_int (en)), str),
- en);
- }
- return scm_stat2scm (&stat_temp);
-}
-#undef FUNC_NAME
-#endif /* HAVE_LSTAT */
-
SCM_DEFINE (scm_copy_file, "copy-file", 2, 0, 0,
(SCM oldfile, SCM newfile),
"Copy the file specified by @var{path-from} to @var{path-to}.\n"
@@ -1509,6 +1155,300 @@ SCM_DEFINE (scm_copy_file, "copy-file", 2, 0, 0,
}
#undef FUNC_NAME
+#endif /* HAVE_POSIX */
+
+
+/* Essential procedures used in (system base compile). */
+
+#ifdef HAVE_GETCWD
+SCM_DEFINE (scm_getcwd, "getcwd", 0, 0, 0,
+ (),
+ "Return the name of the current working directory.")
+#define FUNC_NAME s_scm_getcwd
+{
+ char *rv;
+ size_t size = 100;
+ char *wd;
+ SCM result;
+
+ wd = scm_malloc (size);
+ while ((rv = getcwd (wd, size)) == 0 && errno == ERANGE)
+ {
+ free (wd);
+ size *= 2;
+ wd = scm_malloc (size);
+ }
+ if (rv == 0)
+ {
+ int save_errno = errno;
+ free (wd);
+ errno = save_errno;
+ SCM_SYSERROR;
+ }
+ result = scm_from_locale_stringn (wd, strlen (wd));
+ free (wd);
+ return result;
+}
+#undef FUNC_NAME
+#endif /* HAVE_GETCWD */
+
+#ifdef HAVE_MKDIR
+SCM_DEFINE (scm_mkdir, "mkdir", 1, 1, 0,
+ (SCM path, SCM mode),
+ "Create a new directory named by @var{path}. If @var{mode} is omitted\n"
+ "then the permissions of the directory file are set using the current\n"
+ "umask. Otherwise they are set to the decimal value specified with\n"
+ "@var{mode}. The return value is unspecified.")
+#define FUNC_NAME s_scm_mkdir
+{
+ int rv;
+ mode_t mask;
+
+ if (SCM_UNBNDP (mode))
+ {
+ mask = umask (0);
+ umask (mask);
+ STRING_SYSCALL (path, c_path, rv = mkdir (c_path, 0777 ^ mask));
+ }
+ else
+ {
+ STRING_SYSCALL (path, c_path, rv = mkdir (c_path, scm_to_uint (mode)));
+ }
+ if (rv != 0)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* HAVE_MKDIR */
+
+#ifdef HAVE_RMDIR
+SCM_DEFINE (scm_rmdir, "rmdir", 1, 0, 0,
+ (SCM path),
+ "Remove the existing directory named by @var{path}. The directory must\n"
+ "be empty for this to succeed. The return value is unspecified.")
+#define FUNC_NAME s_scm_rmdir
+{
+ int val;
+
+ STRING_SYSCALL (path, c_path, val = rmdir (c_path));
+ if (val != 0)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif
+
+#ifdef HAVE_RENAME
+#define my_rename rename
+#else
+static int
+my_rename (const char *oldname, const char *newname)
+{
+ int rv;
+
+ SCM_SYSCALL (rv = link (oldname, newname));
+ if (rv == 0)
+ {
+ SCM_SYSCALL (rv = unlink (oldname));
+ if (rv != 0)
+ /* unlink failed. remove new name */
+ SCM_SYSCALL (unlink (newname));
+ }
+ return rv;
+}
+#endif
+
+SCM_DEFINE (scm_rename, "rename-file", 2, 0, 0,
+ (SCM oldname, SCM newname),
+ "Renames the file specified by @var{oldname} to @var{newname}.\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_rename
+{
+ int rv;
+
+ STRING2_SYSCALL (oldname, c_oldname,
+ newname, c_newname,
+ rv = my_rename (c_oldname, c_newname));
+ if (rv != 0)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_delete_file, "delete-file", 1, 0, 0,
+ (SCM str),
+ "Deletes (or \"unlinks\") the file specified by @var{path}.")
+#define FUNC_NAME s_scm_delete_file
+{
+ int ans;
+ STRING_SYSCALL (str, c_str, ans = unlink (c_str));
+ if (ans != 0)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_access, "access?", 2, 0, 0,
+ (SCM path, SCM how),
+ "Test accessibility of a file under the real UID and GID of the\n"
+ "calling process. The return is @code{#t} if @var{path} exists\n"
+ "and the permissions requested by @var{how} are all allowed, or\n"
+ "@code{#f} if not.\n"
+ "\n"
+ "@var{how} is an integer which is one of the following values,\n"
+ "or a bitwise-OR (@code{logior}) of multiple values.\n"
+ "\n"
+ "@defvar R_OK\n"
+ "Test for read permission.\n"
+ "@end defvar\n"
+ "@defvar W_OK\n"
+ "Test for write permission.\n"
+ "@end defvar\n"
+ "@defvar X_OK\n"
+ "Test for execute permission.\n"
+ "@end defvar\n"
+ "@defvar F_OK\n"
+ "Test for existence of the file. This is implied by each of the\n"
+ "other tests, so there's no need to combine it with them.\n"
+ "@end defvar\n"
+ "\n"
+ "It's important to note that @code{access?} does not simply\n"
+ "indicate what will happen on attempting to read or write a\n"
+ "file. In normal circumstances it does, but in a set-UID or\n"
+ "set-GID program it doesn't because @code{access?} tests the\n"
+ "real ID, whereas an open or execute attempt uses the effective\n"
+ "ID.\n"
+ "\n"
+ "A program which will never run set-UID/GID can ignore the\n"
+ "difference between real and effective IDs, but for maximum\n"
+ "generality, especially in library functions, it's best not to\n"
+ "use @code{access?} to predict the result of an open or execute,\n"
+ "instead simply attempt that and catch any exception.\n"
+ "\n"
+ "The main use for @code{access?} is to let a set-UID/GID program\n"
+ "determine what the invoking user would have been allowed to do,\n"
+ "without the greater (or perhaps lesser) privileges afforded by\n"
+ "the effective ID. For more on this, see ``Testing File\n"
+ "Access'' in The GNU C Library Reference Manual.")
+#define FUNC_NAME s_scm_access
+{
+ int rv;
+ char *c_path;
+
+ c_path = scm_to_locale_string (path);
+ rv = access (c_path, scm_to_int (how));
+ free (c_path);
+
+ return scm_from_bool (!rv);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_chmod, "chmod", 2, 0, 0,
+ (SCM object, SCM mode),
+ "Changes the permissions of the file referred to 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{fchmod} is used\n"
+ "as the underlying system call).\n"
+ "@var{mode} specifies\n"
+ "the new permissions as a decimal number, e.g., @code{(chmod \"foo\" #o755)}.\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_chmod
+{
+ int rv;
+ int fdes;
+
+ object = SCM_COERCE_OUTPORT (object);
+
+ if (scm_is_integer (object) || SCM_OPFPORTP (object))
+ {
+ if (scm_is_integer (object))
+ fdes = scm_to_int (object);
+ else
+ fdes = SCM_FPORT_FDES (object);
+ SCM_SYSCALL (rv = fchmod (fdes, scm_to_int (mode)));
+ }
+ else
+ {
+ STRING_SYSCALL (object, c_object,
+ rv = chmod (c_object, scm_to_int (mode)));
+ }
+ if (rv == -1)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_umask, "umask", 0, 1, 0,
+ (SCM mode),
+ "If @var{mode} is omitted, returns a decimal number representing the current\n"
+ "file creation mask. Otherwise the file creation mask is set to\n"
+ "@var{mode} and the previous value is returned.\n\n"
+ "E.g., @code{(umask #o022)} sets the mask to octal 22, decimal 18.")
+#define FUNC_NAME s_scm_umask
+{
+ mode_t mask;
+ if (SCM_UNBNDP (mode))
+ {
+ mask = umask (0);
+ umask (mask);
+ }
+ else
+ {
+ mask = umask (scm_to_uint (mode));
+ }
+ return scm_from_uint (mask);
+}
+#undef FUNC_NAME
+
+#ifndef HAVE_MKSTEMP
+extern int mkstemp (char *);
+#endif
+
+SCM_DEFINE (scm_mkstemp, "mkstemp!", 1, 0, 0,
+ (SCM tmpl),
+ "Create a new unique file in the file system and return a new\n"
+ "buffered port open for reading and writing to the file.\n"
+ "\n"
+ "@var{tmpl} is a string specifying where the file should be\n"
+ "created: it must end with @samp{XXXXXX} and those @samp{X}s\n"
+ "will be changed in the string to return the name of the file.\n"
+ "(@code{port-filename} on the port also gives the name.)\n"
+ "\n"
+ "POSIX doesn't specify the permissions mode of the file, on GNU\n"
+ "and most systems it's @code{#o600}. An application can use\n"
+ "@code{chmod} to relax that if desired. For example\n"
+ "@code{#o666} less @code{umask}, which is usual for ordinary\n"
+ "file creation,\n"
+ "\n"
+ "@example\n"
+ "(let ((port (mkstemp! (string-copy \"/tmp/myfile-XXXXXX\"))))\n"
+ " (chmod port (logand #o666 (lognot (umask))))\n"
+ " ...)\n"
+ "@end example")
+#define FUNC_NAME s_scm_mkstemp
+{
+ char *c_tmpl;
+ int rv;
+
+ scm_dynwind_begin (0);
+
+ c_tmpl = scm_to_locale_string (tmpl);
+ scm_dynwind_free (c_tmpl);
+
+ SCM_SYSCALL (rv = mkstemp (c_tmpl));
+ if (rv == -1)
+ SCM_SYSERROR;
+
+ scm_substring_move_x (scm_from_locale_string (c_tmpl),
+ SCM_INUM0, scm_string_length (tmpl),
+ tmpl, SCM_INUM0);
+
+ scm_dynwind_end ();
+ return scm_fdes_to_port (rv, "w+", tmpl);
+}
+#undef FUNC_NAME
+
/* Filename manipulation */
@@ -1697,18 +1637,192 @@ scm_i_relativize_path (SCM path, SCM in_path)
return SCM_BOOL_F;
}
+
+/* Examining directories. These procedures are used by `check-guile'
+ and thus compiled unconditionally. */
+
+scm_t_bits scm_tc16_dir;
+
+
+SCM_DEFINE (scm_directory_stream_p, "directory-stream?", 1, 0, 0,
+ (SCM obj),
+ "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_from_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"
+ "stream.")
+#define FUNC_NAME s_scm_opendir
+{
+ DIR *ds;
+ STRING_SYSCALL (dirname, c_dirname, ds = opendir (c_dirname));
+ if (ds == NULL)
+ SCM_SYSERROR;
+ SCM_RETURN_NEWSMOB (scm_tc16_dir | (SCM_DIR_FLAG_OPEN<<16), ds);
+}
+#undef FUNC_NAME
+
+
+/* FIXME: The glibc manual has a portability note that readdir_r may not
+ null-terminate its return string. The circumstances outlined for this
+ are not clear, nor is it clear what should be done about it. Lets use
+ NAMLEN and worry about what else should be done if/when someone can
+ figure it out. */
+
+SCM_DEFINE (scm_readdir, "readdir", 1, 0, 0,
+ (SCM port),
+ "Return (as a string) the next directory entry from the directory stream\n"
+ "@var{stream}. If there is no remaining entry to be read then the\n"
+ "end of file object is returned.")
+#define FUNC_NAME s_scm_readdir
+{
+ struct dirent_or_dirent64 *rdent;
+
+ SCM_VALIDATE_DIR (1, port);
+ if (!SCM_DIR_OPEN_P (port))
+ SCM_MISC_ERROR ("Directory ~S is not open.", scm_list_1 (port));
+
+#if HAVE_READDIR_R
+ /* As noted in the glibc manual, on various systems (such as Solaris) the
+ d_name[] field is only 1 char and you're expected to size the dirent
+ buffer for readdir_r based on NAME_MAX. The SCM_MAX expressions below
+ effectively give either sizeof(d_name) or NAME_MAX+1, whichever is
+ bigger.
+
+ On solaris 10 there's no NAME_MAX constant, it's necessary to use
+ pathconf(). We prefer NAME_MAX though, since it should be a constant
+ and will therefore save a system call. We also prefer it since dirfd()
+ is not available everywhere.
+
+ An alternative to dirfd() would be to open() the directory and then use
+ fdopendir(), if the latter is available. That'd let us hold the fd
+ somewhere in the smob, or just the dirent size calculated once. */
+ {
+ struct dirent_or_dirent64 de; /* just for sizeof */
+ DIR *ds = (DIR *) SCM_SMOB_DATA_1 (port);
+#ifdef NAME_MAX
+ char buf [SCM_MAX (sizeof (de),
+ sizeof (de) - sizeof (de.d_name) + NAME_MAX + 1)];
+#else
+ char *buf;
+ long name_max = fpathconf (dirfd (ds), _PC_NAME_MAX);
+ if (name_max == -1)
+ SCM_SYSERROR;
+ buf = alloca (SCM_MAX (sizeof (de),
+ sizeof (de) - sizeof (de.d_name) + name_max + 1));
+#endif
+
+ errno = 0;
+ SCM_SYSCALL (readdir_r_or_readdir64_r (ds, (struct dirent_or_dirent64 *) buf, &rdent));
+ if (errno != 0)
+ SCM_SYSERROR;
+ if (! rdent)
+ return SCM_EOF_VAL;
+
+ return (rdent ? scm_from_locale_stringn (rdent->d_name, NAMLEN (rdent))
+ : SCM_EOF_VAL);
+ }
+#else
+ {
+ SCM ret;
+ scm_dynwind_begin (0);
+ scm_i_dynwind_pthread_mutex_lock (&scm_i_misc_mutex);
+
+ errno = 0;
+ SCM_SYSCALL (rdent = readdir_or_readdir64 ((DIR *) SCM_SMOB_DATA_1 (port)));
+ if (errno != 0)
+ SCM_SYSERROR;
+
+ ret = (rdent ? scm_from_locale_stringn (rdent->d_name, NAMLEN (rdent))
+ : SCM_EOF_VAL);
+
+ scm_dynwind_end ();
+ return ret;
+ }
+#endif
+}
+#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_DIR (1, port);
+ if (!SCM_DIR_OPEN_P (port))
+ SCM_MISC_ERROR ("Directory ~S is not open.", scm_list_1 (port));
+
+ rewinddir ((DIR *) SCM_SMOB_DATA_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
+{
+ SCM_VALIDATE_DIR (1, port);
+
+ if (SCM_DIR_OPEN_P (port))
+ {
+ int sts;
+
+ SCM_SYSCALL (sts = closedir ((DIR *) SCM_SMOB_DATA_1 (port)));
+ if (sts != 0)
+ SCM_SYSERROR;
+
+ SCM_SET_SMOB_DATA_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_UNUSED)
+{
+ scm_puts ("#<", port);
+ if (!SCM_DIR_OPEN_P (exp))
+ scm_puts ("closed: ", port);
+ scm_puts ("directory stream ", port);
+ scm_uintprint (SCM_SMOB_DATA_1 (exp), 16, port);
+ scm_putc ('>', port);
+ return 1;
+}
+
+
+static size_t
+scm_dir_free (SCM p)
+{
+ if (SCM_DIR_OPEN_P (p))
+ closedir ((DIR *) SCM_SMOB_DATA_1 (p));
+ return 0;
+}
void
scm_init_filesys ()
{
+#ifdef HAVE_POSIX
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_from_locale_string (".");
-
#ifdef O_RDONLY
scm_c_define ("O_RDONLY", scm_from_int (O_RDONLY));
#endif
@@ -1770,6 +1884,15 @@ scm_init_filesys ()
#ifdef FD_CLOEXEC
scm_c_define ("FD_CLOEXEC", scm_from_int (FD_CLOEXEC));
#endif
+#endif /* HAVE_POSIX */
+
+ /* `access' symbols. */
+ scm_c_define ("R_OK", scm_from_int (R_OK));
+ scm_c_define ("W_OK", scm_from_int (W_OK));
+ scm_c_define ("X_OK", scm_from_int (X_OK));
+ scm_c_define ("F_OK", scm_from_int (F_OK));
+
+ scm_dot_string = scm_from_locale_string (".");
#include "libguile/filesys.x"
}
diff --git a/libguile/fports.c b/libguile/fports.c
index fdc8f467b..0b84d4413 100644
--- a/libguile/fports.c
+++ b/libguile/fports.c
@@ -1,5 +1,6 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
- *
+/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
+ * 2004, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+ *
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
* as published by the Free Software Foundation; either version 3 of
@@ -637,8 +638,8 @@ fport_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port);
scm_putc (' ', port);
fdes = (SCM_FSTREAM (exp))->fdes;
-
-#ifdef HAVE_TTYNAME
+
+#if (defined HAVE_TTYNAME) && (defined HAVE_POSIX)
if (isatty (fdes))
scm_display (scm_ttyname (exp), port);
else
diff --git a/libguile/gc.c b/libguile/gc.c
index 8816a61a6..7d2724c5f 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -57,6 +57,9 @@ extern unsigned long * __libc_ia64_register_backing_store_base;
#include "libguile/bdw-gc.h"
+/* For GC_set_start_callback. */
+#include <gc/gc_mark.h>
+
#ifdef GUILE_DEBUG_MALLOC
#include "libguile/debug-malloc.h"
#endif
@@ -195,6 +198,13 @@ scm_t_c_hook scm_after_sweep_c_hook;
scm_t_c_hook scm_after_gc_c_hook;
+static void
+run_before_gc_c_hook (void)
+{
+ scm_c_hook_run (&scm_before_gc_c_hook, NULL);
+}
+
+
/* GC Statistics Keeping
*/
unsigned long scm_gc_ports_collected = 0;
@@ -352,6 +362,9 @@ SCM_DEFINE (scm_gc, "gc", 0, 0, 0,
void
scm_i_gc (const char *what)
{
+#ifndef HAVE_GC_SET_START_CALLBACK
+ run_before_gc_c_hook ();
+#endif
GC_gcollect ();
}
@@ -544,23 +557,6 @@ scm_gc_unregister_roots (SCM *b, unsigned long n)
scm_gc_unregister_root (p);
}
-static void
-scm_c_register_gc_callback (void *key, void (*func) (void *, void *),
- void *data)
-{
- if (!key)
- key = GC_MALLOC_ATOMIC (sizeof (void*));
-
- GC_REGISTER_FINALIZER_NO_ORDER (key, func, data, NULL, NULL);
-}
-
-static void
-system_gc_callback (void *key, void *data)
-{
- scm_c_register_gc_callback (key, system_gc_callback, data);
- scm_c_hook_run (&scm_after_gc_c_hook, NULL);
-}
-
@@ -616,8 +612,6 @@ scm_storage_prehistory ()
scm_c_hook_init (&scm_before_sweep_c_hook, 0, SCM_C_HOOK_NORMAL);
scm_c_hook_init (&scm_after_sweep_c_hook, 0, SCM_C_HOOK_NORMAL);
scm_c_hook_init (&scm_after_gc_c_hook, 0, SCM_C_HOOK_NORMAL);
-
- scm_c_register_gc_callback (NULL, system_gc_callback, NULL);
}
scm_i_pthread_mutex_t scm_i_gc_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
@@ -646,29 +640,31 @@ scm_init_gc_protect_object ()
SCM scm_after_gc_hook;
-static SCM gc_async;
+static SCM after_gc_async_cell;
-/* The function gc_async_thunk causes the execution of the after-gc-hook. It
- * is run after the gc, as soon as the asynchronous events are handled by the
- * evaluator.
+/* The function after_gc_async_thunk causes the execution of the
+ * after-gc-hook. It is run after the gc, as soon as the asynchronous
+ * events are handled by the evaluator.
*/
static SCM
-gc_async_thunk (void)
+after_gc_async_thunk (void)
{
+ /* Fun, no? Hook-run *and* run-hook? */
+ scm_c_hook_run (&scm_after_gc_c_hook, NULL);
scm_c_run_hook (scm_after_gc_hook, SCM_EOL);
return SCM_UNSPECIFIED;
}
-/* The function mark_gc_async is run by the scm_after_gc_c_hook at the end of
- * the garbage collection. The only purpose of this function is to mark the
- * gc_async (which will eventually lead to the execution of the
- * gc_async_thunk).
+/* The function queue_after_gc_hook is run by the scm_before_gc_c_hook
+ * at the end of the garbage collection. The only purpose of this
+ * function is to mark the after_gc_async (which will eventually lead to
+ * the execution of the after_gc_async_thunk).
*/
static void *
-mark_gc_async (void * hook_data SCM_UNUSED,
- void *fn_data SCM_UNUSED,
- void *data SCM_UNUSED)
+queue_after_gc_hook (void * hook_data SCM_UNUSED,
+ void *fn_data SCM_UNUSED,
+ void *data SCM_UNUSED)
{
/* If cell access debugging is enabled, the user may choose to perform
* additional garbage collections after an arbitrary number of cell
@@ -697,10 +693,17 @@ mark_gc_async (void * hook_data SCM_UNUSED,
#if (SCM_DEBUG_CELL_ACCESSES == 1)
if (scm_debug_cells_gc_interval == 0)
- scm_system_async_mark (gc_async);
-#else
- scm_system_async_mark (gc_async);
#endif
+ {
+ scm_i_thread *t = SCM_I_CURRENT_THREAD;
+
+ if (scm_is_false (SCM_CDR (after_gc_async_cell)))
+ {
+ SCM_SETCDR (after_gc_async_cell, t->active_asyncs);
+ t->active_asyncs = after_gc_async_cell;
+ t->pending_asyncs = 1;
+ }
+ }
return NULL;
}
@@ -793,9 +796,17 @@ scm_init_gc ()
scm_after_gc_hook = scm_make_hook (SCM_INUM0);
scm_c_define ("after-gc-hook", scm_after_gc_hook);
- gc_async = scm_c_make_gsubr ("%gc-thunk", 0, 0, 0, gc_async_thunk);
+ /* When the async is to run, the cdr of the gc_async pair gets set to
+ the asyncs queue of the current thread. */
+ after_gc_async_cell = scm_cons (scm_c_make_gsubr ("%after-gc-thunk", 0, 0, 0,
+ after_gc_async_thunk),
+ SCM_BOOL_F);
+
+ scm_c_hook_add (&scm_before_gc_c_hook, queue_after_gc_hook, NULL, 0);
- scm_c_hook_add (&scm_after_gc_c_hook, mark_gc_async, NULL, 0);
+#ifdef HAVE_GC_SET_START_CALLBACK
+ GC_set_start_callback (run_before_gc_c_hook);
+#endif
#include "libguile/gc.x"
}
diff --git a/libguile/hashtab.c b/libguile/hashtab.c
index a76c03812..48660d75c 100644
--- a/libguile/hashtab.c
+++ b/libguile/hashtab.c
@@ -418,32 +418,54 @@ SCM_DEFINE (scm_make_hash_table, "make-hash-table", 0, 1, 0,
}
#undef FUNC_NAME
-static void
-weak_gc_callback (void *ptr, void *data)
+/* The before-gc C hook only runs if GC_set_start_callback is available,
+ so if not, fall back on a finalizer-based implementation. */
+static int
+weak_gc_callback (void **weak)
{
- void **weak = ptr;
- void *val = *weak;
+ void *val = weak[0];
+ void (*callback) (SCM) = weak[1];
- if (val)
- {
- void (*callback) (SCM) = data;
+ if (!val)
+ return 0;
+
+ callback (PTR2SCM (val));
- GC_REGISTER_FINALIZER_NO_ORDER (ptr, weak_gc_callback, data, NULL, NULL);
-
- callback (PTR2SCM (val));
- }
+ return 1;
}
+#ifdef HAVE_GC_SET_START_CALLBACK
+static void*
+weak_gc_hook (void *hook_data, void *fn_data, void *data)
+{
+ if (!weak_gc_callback (fn_data))
+ scm_c_hook_remove (&scm_before_gc_c_hook, weak_gc_hook, fn_data);
+
+ return NULL;
+}
+#else
+static void
+weak_gc_finalizer (void *ptr, void *data)
+{
+ if (weak_gc_callback (ptr))
+ GC_REGISTER_FINALIZER_NO_ORDER (ptr, weak_gc_finalizer, data, NULL, NULL);
+}
+#endif
+
static void
scm_c_register_weak_gc_callback (SCM obj, void (*callback) (SCM))
{
- void **weak = GC_MALLOC_ATOMIC (sizeof (void**));
+ void **weak = GC_MALLOC_ATOMIC (sizeof (void*) * 2);
- *weak = SCM2PTR (obj);
+ weak[0] = SCM2PTR (obj);
+ weak[1] = (void*)callback;
GC_GENERAL_REGISTER_DISAPPEARING_LINK (weak, SCM2PTR (obj));
- GC_REGISTER_FINALIZER_NO_ORDER (weak, weak_gc_callback, (void*)callback,
- NULL, NULL);
+#ifdef HAVE_GC_SET_START_CALLBACK
+ scm_c_hook_add (&scm_before_gc_c_hook, weak_gc_hook, weak, 0);
+#else
+ GC_REGISTER_FINALIZER_NO_ORDER (weak, weak_gc_finalizer, NULL, NULL, NULL);
+#endif
}
SCM_DEFINE (scm_make_weak_key_hash_table, "make-weak-key-hash-table", 0, 1, 0,
diff --git a/libguile/i18n.c b/libguile/i18n.c
index fc651fd7e..6ee159b73 100644
--- a/libguile/i18n.c
+++ b/libguile/i18n.c
@@ -82,6 +82,25 @@ setlocale (int category, const char *name)
/* Helper stringification macro. */
#define SCM_I18N_STRINGIFY(_name) # _name
+/* Acquiring and releasing the locale lock. */
+
+static inline void
+lock_locale_mutex (void)
+{
+#ifdef HAVE_POSIX
+ scm_i_pthread_mutex_lock (&scm_i_locale_mutex);
+#else
+#endif
+}
+
+static inline void
+unlock_locale_mutex (void)
+{
+#ifdef HAVE_POSIX
+ scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);
+#else
+#endif
+}
/* Locale objects, string and character collation, and other locale-dependent
@@ -421,7 +440,7 @@ leave_locale_section (const scm_t_locale_settings *settings)
/* Restore the previous locale settings. */
(void)restore_locale_settings (settings);
- scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);
+ unlock_locale_mutex ();
}
/* Enter a locked locale section. */
@@ -431,12 +450,12 @@ enter_locale_section (scm_t_locale locale,
{
int err;
- scm_i_pthread_mutex_lock (&scm_i_locale_mutex);
+ lock_locale_mutex ();
err = get_current_locale_settings (prev_locale);
if (err)
{
- scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);
+ unlock_locale_mutex ();
return err;
}
@@ -483,7 +502,7 @@ get_current_locale (SCM *result)
c_locale = scm_gc_malloc (sizeof (* c_locale), "locale");
- scm_i_pthread_mutex_lock (&scm_i_locale_mutex);
+ lock_locale_mutex ();
c_locale->category_mask = LC_ALL_MASK;
c_locale->base_locale = SCM_UNDEFINED;
@@ -498,7 +517,7 @@ get_current_locale (SCM *result)
else
err = EINVAL;
- scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);
+ unlock_locale_mutex ();
if (err)
scm_gc_free (c_locale, sizeof (* c_locale), "locale");
@@ -1490,7 +1509,7 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0,
http://opengroup.org/onlinepubs/007908799/xsh/nl_langinfo.html for
details. */
- scm_i_pthread_mutex_lock (&scm_i_locale_mutex);
+ lock_locale_mutex ();
if (c_locale != NULL)
{
#ifdef USE_GNU_LOCALE_API
@@ -1506,7 +1525,7 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0,
lsec_err = get_current_locale_settings (&lsec_prev_locale);
if (lsec_err)
- scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);
+ unlock_locale_mutex ();
else
{
lsec_err = install_locale (c_locale);
@@ -1540,7 +1559,7 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0,
}
c_result = strdup (c_result);
- scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);
+ unlock_locale_mutex ();
if (c_result == NULL)
result = SCM_BOOL_F;
diff --git a/libguile/init.c b/libguile/init.c
index 8b3b8cd33..94de5c90a 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -381,13 +381,6 @@ scm_i_init_guile (void *base)
if (scm_initialized_p)
return;
- if (sizeof (mpz_t) > (3 * sizeof (scm_t_bits)))
- {
- fprintf (stderr,
- "GMP's mpz_t must fit into a double_cell,"
- "but doesn't seem to here.\n");
- }
-
scm_storage_prehistory ();
scm_threads_prehistory (base); /* requires storage_prehistory */
scm_weaks_prehistory (); /* requires storage_prehistory */
@@ -455,8 +448,8 @@ scm_i_init_guile (void *base)
scm_init_numbers ();
scm_init_options ();
scm_init_pairs ();
-#ifdef HAVE_POSIX
scm_init_filesys (); /* Requires smob_prehistory */
+#ifdef HAVE_POSIX
scm_init_posix ();
#endif
#ifdef HAVE_REGCOMP
diff --git a/libguile/load.c b/libguile/load.c
index c2380b94e..b0137a11b 100644
--- a/libguile/load.c
+++ b/libguile/load.c
@@ -210,6 +210,9 @@ static SCM *scm_loc_load_compiled_extensions;
/* Whether we should try to auto-compile. */
static SCM *scm_loc_load_should_auto_compile;
+/* Whether to treat all auto-compiled files as stale. */
+static SCM *scm_loc_fresh_auto_compile;
+
/* The fallback path for auto-compilation */
static SCM *scm_loc_compile_fallback_path;
@@ -824,6 +827,7 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
if (scm_is_false (compiled_filename)
&& scm_is_true (full_filename)
&& scm_is_true (*scm_loc_compile_fallback_path)
+ && scm_is_false (*scm_loc_fresh_auto_compile)
&& scm_is_pair (*scm_loc_load_compiled_extensions)
&& scm_is_string (scm_car (*scm_loc_load_compiled_extensions)))
{
@@ -857,6 +861,7 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
if (!compiled_is_fallback
&& scm_is_true (*scm_loc_compile_fallback_path)
+ && scm_is_false (*scm_loc_fresh_auto_compile)
&& scm_is_pair (*scm_loc_load_compiled_extensions)
&& scm_is_string (scm_car (*scm_loc_load_compiled_extensions)))
{
@@ -933,6 +938,21 @@ init_build_info ()
SCM val = scm_from_locale_string (info[i].value);
*loc = scm_acons (key, val, *loc);
}
+#ifdef PACKAGE_PACKAGER
+ *loc = scm_acons (scm_from_latin1_symbol ("packager"),
+ scm_from_latin1_string (PACKAGE_PACKAGER),
+ *loc);
+#endif
+#ifdef PACKAGE_PACKAGER_VERSION
+ *loc = scm_acons (scm_from_latin1_symbol ("packager-version"),
+ scm_from_latin1_string (PACKAGE_PACKAGER_VERSION),
+ *loc);
+#endif
+#ifdef PACKAGE_PACKAGER_BUG_REPORTS
+ *loc = scm_acons (scm_from_latin1_symbol ("packager-bug-reports"),
+ scm_from_latin1_string (PACKAGE_PACKAGER_BUG_REPORTS),
+ *loc);
+#endif
}
@@ -956,6 +976,8 @@ scm_init_load ()
= SCM_VARIABLE_LOC (scm_c_define ("%compile-fallback-path", SCM_BOOL_F));
scm_loc_load_should_auto_compile
= SCM_VARIABLE_LOC (scm_c_define ("%load-should-auto-compile", SCM_BOOL_F));
+ scm_loc_fresh_auto_compile
+ = SCM_VARIABLE_LOC (scm_c_define ("%fresh-auto-compile", SCM_BOOL_F));
the_reader = scm_make_fluid ();
scm_fluid_set_x (the_reader, SCM_BOOL_F);
@@ -973,8 +995,24 @@ scm_init_load ()
void
scm_init_load_should_auto_compile ()
{
- *scm_loc_load_should_auto_compile =
- scm_from_bool (scm_getenv_int ("GUILE_AUTO_COMPILE", 1));
+ char *auto_compile = getenv ("GUILE_AUTO_COMPILE");
+
+ if (auto_compile && strcmp (auto_compile, "0") == 0)
+ {
+ *scm_loc_load_should_auto_compile = SCM_BOOL_F;
+ *scm_loc_fresh_auto_compile = SCM_BOOL_F;
+ }
+ /* Allow "freshen" also. */
+ else if (auto_compile && strncmp (auto_compile, "fresh", 5) == 0)
+ {
+ *scm_loc_load_should_auto_compile = SCM_BOOL_T;
+ *scm_loc_fresh_auto_compile = SCM_BOOL_T;
+ }
+ else
+ {
+ *scm_loc_load_should_auto_compile = SCM_BOOL_T;
+ *scm_loc_fresh_auto_compile = SCM_BOOL_F;
+ }
}
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 74753812b..fe510a195 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -45,6 +45,8 @@
# include <config.h>
#endif
+#include <verify.h>
+
#include <math.h>
#include <string.h>
#include <unicase.h>
diff --git a/libguile/ports.c b/libguile/ports.c
index 6e0ae6c8b..b5ad95ec7 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -1174,6 +1174,10 @@ get_codepoint (SCM port, scm_t_wchar *codepoint,
output_size = sizeof (utf8_buf) - output_left;
}
+ if (SCM_UNLIKELY (output_size == 0))
+ /* An unterminated sequence. */
+ err = EILSEQ;
+
if (SCM_UNLIKELY (err != 0))
{
/* Reset the `iconv' state. */
@@ -1190,11 +1194,11 @@ get_codepoint (SCM port, scm_t_wchar *codepoint,
input encoding errors.) */
}
else
- /* Convert the UTF8_BUF sequence to a Unicode code point. */
- *codepoint = utf8_to_codepoint (utf8_buf, output_size);
-
- if (SCM_LIKELY (err == 0))
- update_port_lf (*codepoint, port);
+ {
+ /* Convert the UTF8_BUF sequence to a Unicode code point. */
+ *codepoint = utf8_to_codepoint (utf8_buf, output_size);
+ update_port_lf (*codepoint, port);
+ }
*len = bytes_consumed;
diff --git a/libguile/posix.c b/libguile/posix.c
index a5c72624c..15b38e79c 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -27,6 +27,10 @@
#include <errno.h>
#include <uniconv.h>
+#ifdef HAVE_SCHED_H
+# include <sched.h>
+#endif
+
#include "libguile/_scm.h"
#include "libguile/dynwind.h"
#include "libguile/fports.h"
@@ -138,7 +142,6 @@ extern char *ttyname();
#endif
#include <sys/file.h> /* from Gnulib */
-#include <nproc.h>
/* Some Unix systems don't define these. CPP hair is dangerous, but
this seems safe enough... */
@@ -1325,54 +1328,6 @@ SCM_DEFINE (scm_tmpnam, "tmpnam", 0, 0, 0,
#endif
-#ifndef HAVE_MKSTEMP
-extern int mkstemp (char *);
-#endif
-
-SCM_DEFINE (scm_mkstemp, "mkstemp!", 1, 0, 0,
- (SCM tmpl),
- "Create a new unique file in the file system and return a new\n"
- "buffered port open for reading and writing to the file.\n"
- "\n"
- "@var{tmpl} is a string specifying where the file should be\n"
- "created: it must end with @samp{XXXXXX} and those @samp{X}s\n"
- "will be changed in the string to return the name of the file.\n"
- "(@code{port-filename} on the port also gives the name.)\n"
- "\n"
- "POSIX doesn't specify the permissions mode of the file, on GNU\n"
- "and most systems it's @code{#o600}. An application can use\n"
- "@code{chmod} to relax that if desired. For example\n"
- "@code{#o666} less @code{umask}, which is usual for ordinary\n"
- "file creation,\n"
- "\n"
- "@example\n"
- "(let ((port (mkstemp! (string-copy \"/tmp/myfile-XXXXXX\"))))\n"
- " (chmod port (logand #o666 (lognot (umask))))\n"
- " ...)\n"
- "@end example")
-#define FUNC_NAME s_scm_mkstemp
-{
- char *c_tmpl;
- int rv;
-
- scm_dynwind_begin (0);
-
- c_tmpl = scm_to_locale_string (tmpl);
- scm_dynwind_free (c_tmpl);
-
- SCM_SYSCALL (rv = mkstemp (c_tmpl));
- if (rv == -1)
- SCM_SYSERROR;
-
- scm_substring_move_x (scm_from_locale_string (c_tmpl),
- SCM_INUM0, scm_string_length (tmpl),
- tmpl, SCM_INUM0);
-
- scm_dynwind_end ();
- return scm_fdes_to_port (rv, "w+", tmpl);
-}
-#undef FUNC_NAME
-
SCM_DEFINE (scm_tmpfile, "tmpfile", 0, 0, 0,
(void),
"Return an input/output port to a unique temporary file\n"
@@ -1485,58 +1440,6 @@ SCM_DEFINE (scm_utime, "utime", 1, 5, 0,
}
#undef FUNC_NAME
-SCM_DEFINE (scm_access, "access?", 2, 0, 0,
- (SCM path, SCM how),
- "Test accessibility of a file under the real UID and GID of the\n"
- "calling process. The return is @code{#t} if @var{path} exists\n"
- "and the permissions requested by @var{how} are all allowed, or\n"
- "@code{#f} if not.\n"
- "\n"
- "@var{how} is an integer which is one of the following values,\n"
- "or a bitwise-OR (@code{logior}) of multiple values.\n"
- "\n"
- "@defvar R_OK\n"
- "Test for read permission.\n"
- "@end defvar\n"
- "@defvar W_OK\n"
- "Test for write permission.\n"
- "@end defvar\n"
- "@defvar X_OK\n"
- "Test for execute permission.\n"
- "@end defvar\n"
- "@defvar F_OK\n"
- "Test for existence of the file. This is implied by each of the\n"
- "other tests, so there's no need to combine it with them.\n"
- "@end defvar\n"
- "\n"
- "It's important to note that @code{access?} does not simply\n"
- "indicate what will happen on attempting to read or write a\n"
- "file. In normal circumstances it does, but in a set-UID or\n"
- "set-GID program it doesn't because @code{access?} tests the\n"
- "real ID, whereas an open or execute attempt uses the effective\n"
- "ID.\n"
- "\n"
- "A program which will never run set-UID/GID can ignore the\n"
- "difference between real and effective IDs, but for maximum\n"
- "generality, especially in library functions, it's best not to\n"
- "use @code{access?} to predict the result of an open or execute,\n"
- "instead simply attempt that and catch any exception.\n"
- "\n"
- "The main use for @code{access?} is to let a set-UID/GID program\n"
- "determine what the invoking user would have been allowed to do,\n"
- "without the greater (or perhaps lesser) privileges afforded by\n"
- "the effective ID. For more on this, see ``Testing File\n"
- "Access'' in The GNU C Library Reference Manual.")
-#define FUNC_NAME s_scm_access
-{
- int rv;
-
- WITH_STRING (path, c_path,
- rv = access (c_path, scm_to_int (how)));
- return scm_from_bool (!rv);
-}
-#undef FUNC_NAME
-
SCM_DEFINE (scm_getpid, "getpid", 0, 0, 0,
(),
"Return an integer representing the current process ID.")
@@ -1991,36 +1894,6 @@ SCM_DEFINE (scm_setaffinity, "setaffinity", 2, 0, 0,
#endif /* HAVE_SCHED_SETAFFINITY */
-SCM_DEFINE (scm_total_processor_count, "total-processor-count", 0, 0, 0,
- (void),
- "Return the total number of processors of the machine, which\n"
- "is guaranteed to be at least 1. A ``processor'' here is a\n"
- "thread execution unit, which can be either:\n\n"
- "@itemize\n"
- "@item an execution core in a (possibly multi-core) chip, in a\n"
- " (possibly multi- chip) module, in a single computer, or\n"
- "@item a thread execution unit inside a core in the case of\n"
- " @dfn{hyper-threaded} CPUs.\n"
- "@end itemize\n\n"
- "Which of the two definitions is used, is unspecified.\n")
-#define FUNC_NAME s_scm_total_processor_count
-{
- return scm_from_ulong (num_processors (NPROC_ALL));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_current_processor_count, "current-processor-count", 0, 0, 0,
- (void),
- "Like @code{total-processor-count}, but return the number of\n"
- "processors available to the current process. See\n"
- "@code{setaffinity} and @code{getaffinity} for more\n"
- "information.\n")
-#define FUNC_NAME s_scm_current_processor_count
-{
- return scm_from_ulong (num_processors (NPROC_CURRENT));
-}
-#undef FUNC_NAME
-
#if HAVE_GETPASS
SCM_DEFINE (scm_getpass, "getpass", 1, 0, 0,
@@ -2218,12 +2091,6 @@ scm_init_posix ()
scm_c_define ("WUNTRACED", scm_from_int (WUNTRACED));
#endif
- /* access() symbols. */
- scm_c_define ("R_OK", scm_from_int (R_OK));
- scm_c_define ("W_OK", scm_from_int (W_OK));
- scm_c_define ("X_OK", scm_from_int (X_OK));
- scm_c_define ("F_OK", scm_from_int (F_OK));
-
#ifdef LC_COLLATE
scm_c_define ("LC_COLLATE", scm_from_int (LC_COLLATE));
#endif
diff --git a/libguile/posix.h b/libguile/posix.h
index e2e19ddd2..92f8b3514 100644
--- a/libguile/posix.h
+++ b/libguile/posix.h
@@ -3,7 +3,8 @@
#ifndef SCM_POSIX_H
#define SCM_POSIX_H
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2003, 2006, 2008,
+ * 2009, 2010, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -91,8 +92,6 @@ SCM_API SCM scm_sethostname (SCM name);
SCM_API SCM scm_gethostname (void);
SCM_API SCM scm_getaffinity (SCM pid);
SCM_API SCM scm_setaffinity (SCM pid, SCM cpu_set);
-SCM_API SCM scm_total_processor_count (void);
-SCM_API SCM scm_current_processor_count (void);
SCM_INTERNAL void scm_init_posix (void);
SCM_INTERNAL scm_i_pthread_mutex_t scm_i_locale_mutex;
diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c
index 7473db94b..b9d52829f 100644
--- a/libguile/r6rs-ports.c
+++ b/libguile/r6rs-ports.c
@@ -87,6 +87,10 @@ make_bip (SCM bv)
scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
port = scm_new_port_table_entry (bytevector_input_port_type);
+ c_port = SCM_PTAB_ENTRY (port);
+
+ /* Match the expectation of `binary-port?'. */
+ c_port->encoding = NULL;
/* Prevent BV from being GC'd. */
SCM_SETSTREAM (port, SCM_UNPACK (bv));
@@ -95,7 +99,6 @@ make_bip (SCM bv)
c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
c_len = SCM_BYTEVECTOR_LENGTH (bv);
- c_port = SCM_PTAB_ENTRY (port);
c_port->read_pos = c_port->read_buf = (unsigned char *) c_bv;
c_port->read_end = (unsigned char *) c_bv + c_len;
c_port->read_buf_size = c_len;
@@ -312,12 +315,15 @@ make_cbip (SCM read_proc, SCM get_position_proc,
scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
port = scm_new_port_table_entry (custom_binary_input_port_type);
+ c_port = SCM_PTAB_ENTRY (port);
+
+ /* Match the expectation of `binary-port?'. */
+ c_port->encoding = NULL;
/* Attach it the method vector. */
SCM_SETSTREAM (port, SCM_UNPACK (method_vector));
/* Have the port directly access the buffer (bytevector). */
- c_port = SCM_PTAB_ENTRY (port);
c_port->read_pos = c_port->read_buf = (unsigned char *) c_bv;
c_port->read_end = (unsigned char *) c_bv;
c_port->read_buf_size = c_len;
@@ -827,11 +833,14 @@ make_bop (void)
scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
port = scm_new_port_table_entry (bytevector_output_port_type);
+ c_port = SCM_PTAB_ENTRY (port);
+
+ /* Match the expectation of `binary-port?'. */
+ c_port->encoding = NULL;
buf = (scm_t_bop_buffer *) scm_gc_malloc (sizeof (* buf), SCM_GC_BOP);
bop_buffer_init (buf);
- c_port = SCM_PTAB_ENTRY (port);
c_port->write_buf = c_port->write_pos = c_port->write_end = NULL;
c_port->write_buf_size = 0;
@@ -983,12 +992,15 @@ make_cbop (SCM write_proc, SCM get_position_proc,
scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
port = scm_new_port_table_entry (custom_binary_output_port_type);
+ c_port = SCM_PTAB_ENTRY (port);
+
+ /* Match the expectation of `binary-port?'. */
+ c_port->encoding = NULL;
/* Attach it the method vector. */
SCM_SETSTREAM (port, SCM_UNPACK (method_vector));
/* Have the port directly access the buffer (bytevector). */
- c_port = SCM_PTAB_ENTRY (port);
c_port->write_buf = c_port->write_pos = c_port->write_end = NULL;
c_port->write_buf_size = c_port->read_buf_size = 0;
diff --git a/libguile/script.c b/libguile/script.c
index bff7142e8..83dcdd5b9 100644
--- a/libguile/script.c
+++ b/libguile/script.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1994, 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1994-1998, 2000-2011 Free Software Foundation, Inc.
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
* as published by the Free Software Foundation; either version 3 of
@@ -27,8 +27,6 @@
#include <errno.h>
#include <ctype.h>
-#include <version-etc.h>
-
#include "libguile/_scm.h"
#include "libguile/eval.h"
#include "libguile/feature.h"
@@ -357,464 +355,31 @@ char *scm_usage_name = 0;
void
scm_shell_usage (int fatal, char *message)
{
- FILE *fp = (fatal ? stderr : stdout);
-
- if (message)
- fprintf (fp, "%s\n", message);
-
- fprintf (fp,
- "Usage: %s [OPTION]... [FILE]...\n"
- "Evaluate Scheme code, interactively or from a script.\n"
- "\n"
- " [-s] FILE load Scheme source code from FILE, and exit\n"
- " -c EXPR evalute Scheme expression EXPR, and exit\n"
- " -- stop scanning arguments; run interactively\n\n"
- "The above switches stop argument processing, and pass all\n"
- "remaining arguments as the value of (command-line).\n"
- "If FILE begins with `-' the -s switch is mandatory.\n"
- "\n"
- " -L DIRECTORY add DIRECTORY to the front of the module load path\n"
- " -x EXTENSION add EXTENSION to the front of the load extensions\n"
- " -l FILE load Scheme source code from FILE\n"
- " -e FUNCTION after reading script, apply FUNCTION to\n"
- " command line arguments\n"
- " -ds do -s script at this point\n"
- " --debug start with debugging evaluator and backtraces\n"
- " --no-debug start with normal evaluator\n"
- " Default is to enable debugging for interactive\n"
- " use, but not for `-s' and `-c'.\n"
- " --auto-compile compile source files automatically\n"
- " --no-auto-compile disable automatic source file compilation\n"
- " Default is to enable auto-compilation of source\n"
- " files.\n"
- " --listen[=P] Listen on a local port or a path for REPL clients.\n"
- " If P is not given, the default is local port 37146.\n"
- " -q inhibit loading of user init file\n"
- " --use-srfi=LS load SRFI modules for the SRFIs in LS,\n"
- " which is a list of numbers like \"2,13,14\"\n"
- " -h, --help display this help and exit\n"
- " -v, --version display version information and exit\n"
- " \\ read arguments from following script lines\n",
- scm_usage_name);
-
- emit_bug_reporting_address ();
-
- if (fatal)
- exit (fatal);
+ scm_call_3 (scm_c_private_ref ("ice-9 command-line",
+ "shell-usage"),
+ (scm_usage_name
+ ? scm_from_locale_string (scm_usage_name)
+ : scm_from_latin1_string ("guile")),
+ scm_from_bool (fatal),
+ (message
+ ? scm_from_locale_string (message)
+ : SCM_BOOL_F));
}
-/* Some symbols used by the command-line compiler. */
-SCM_SYMBOL (sym_load, "load");
-SCM_SYMBOL (sym_eval_string, "eval-string");
-SCM_SYMBOL (sym_command_line, "command-line");
-SCM_SYMBOL (sym_begin, "begin");
-SCM_SYMBOL (sym_load_user_init, "load-user-init");
-SCM_SYMBOL (sym_ice_9, "ice-9");
-SCM_SYMBOL (sym_top_repl, "top-repl");
-SCM_SYMBOL (sym_quit, "quit");
-SCM_SYMBOL (sym_use_srfis, "use-srfis");
-SCM_SYMBOL (sym_load_path, "%load-path");
-SCM_SYMBOL (sym_load_extensions, "%load-extensions");
-SCM_SYMBOL (sym_set_x, "set!");
-SCM_SYMBOL (sym_sys_load_should_auto_compile, "%load-should-auto-compile");
-SCM_SYMBOL (sym_cons, "cons");
-SCM_SYMBOL (sym_at, "@");
-SCM_SYMBOL (sym_atat, "@@");
-SCM_SYMBOL (sym_main, "main");
-
/* Given an array of command-line switches, return a Scheme expression
to carry out the actions specified by the switches.
-
- If you told me this should have been written in Scheme, I'd
- probably agree. I'd say I didn't feel comfortable doing that in
- the present system. You'd say, well, fix the system so you are
- comfortable doing that. I'd agree again. *shrug*
*/
-static char guile[] = "guile";
-
-static int
-all_symbols (SCM list)
-{
- while (scm_is_pair (list))
- {
- if (!scm_is_symbol (SCM_CAR (list)))
- return 0;
- list = SCM_CDR (list);
- }
- return 1;
-}
-
SCM
scm_compile_shell_switches (int argc, char **argv)
{
- SCM tail = SCM_EOL; /* We accumulate the list backwards,
- and then reverse! it before we
- return it. */
- SCM do_script = SCM_EOL; /* The element of the list containing
- the "load" command, in case we get
- the "-ds" switch. */
- SCM entry_point = SCM_EOL; /* for -e switch */
- SCM user_load_path = SCM_EOL; /* for -L switch */
- SCM user_extensions = SCM_EOL;/* for -x switch */
- int interactive = 1; /* Should we go interactive when done? */
- int inhibit_user_init = 0; /* Don't load user init file */
- int turn_on_debugging = 0;
- int dont_turn_on_debugging = 0;
-
- int i;
- char *argv0 = guile;
-
- if (argc > 0)
- {
- argv0 = argv[0];
- scm_usage_name = strrchr (argv[0], '/');
- if (! scm_usage_name)
- scm_usage_name = argv[0];
- else
- scm_usage_name++;
- }
- if (! scm_usage_name)
- scm_usage_name = guile;
-
- for (i = 1; i < argc; i++)
- {
- if ((! strcmp (argv[i], "-s")) || (argv[i][0] != '-')) /* load script */
- {
- if ((argv[i][0] == '-') && (++i >= argc))
- scm_shell_usage (1, "missing argument to `-s' switch");
-
- /* If we specified the -ds option, do_script points to the
- cdr of an expression like (load #f); we replace the car
- (i.e., the #f) with the script name. */
- if (!scm_is_null (do_script))
- {
- SCM_SETCAR (do_script, scm_from_locale_string (argv[i]));
- do_script = SCM_EOL;
- }
- else
- /* Construct an application of LOAD to the script name. */
- tail = scm_cons (scm_cons2 (sym_load,
- scm_from_locale_string (argv[i]),
- SCM_EOL),
- tail);
- argv0 = argv[i];
- i++;
- interactive = 0;
- break;
- }
-
- else if (! strcmp (argv[i], "-c")) /* evaluate expr */
- {
- if (++i >= argc)
- scm_shell_usage (1, "missing argument to `-c' switch");
- tail = scm_cons (scm_cons2 (sym_eval_string,
- scm_from_locale_string (argv[i]),
- SCM_EOL),
- tail);
- i++;
- interactive = 0;
- break;
- }
-
- else if (! strcmp (argv[i], "--")) /* end args; go interactive */
- {
- i++;
- break;
- }
-
- else if (! strcmp (argv[i], "-l")) /* load a file */
- {
- if (++i < argc)
- tail = scm_cons (scm_cons2 (sym_load,
- scm_from_locale_string (argv[i]),
- SCM_EOL),
- tail);
- else
- scm_shell_usage (1, "missing argument to `-l' switch");
- }
-
- else if (! strcmp (argv[i], "-L")) /* add to %load-path */
- {
- if (++i < argc)
- user_load_path =
- scm_cons (scm_list_3 (sym_set_x,
- sym_load_path,
- scm_list_3 (sym_cons,
- scm_from_locale_string (argv[i]),
- sym_load_path)),
- user_load_path);
- else
- scm_shell_usage (1, "missing argument to `-L' switch");
- }
-
- else if (! strcmp (argv[i], "-x")) /* add to %load-extensions */
- {
- if (++i < argc)
- user_extensions =
- scm_cons (scm_list_3 (sym_set_x,
- sym_load_extensions,
- scm_list_3 (sym_cons,
- scm_from_locale_string (argv[i]),
- sym_load_extensions)),
- user_extensions);
- else
- scm_shell_usage (1, "missing argument to `-x' switch");
- }
-
- else if (! strcmp (argv[i], "-e")) /* entry point */
- {
- if (++i < argc)
- {
- SCM port
- = scm_open_input_string (scm_from_locale_string (argv[i]));
- SCM arg1 = scm_read (port);
- SCM arg2 = scm_read (port);
-
- /* Recognize syntax of certain versions of Guile 1.4 and
- transform to (@ MODULE-NAME FUNC).
- */
- if (scm_is_false (scm_eof_object_p (arg2)))
- entry_point = scm_list_3 (sym_at, arg1, arg2);
- else if (scm_is_pair (arg1)
- && !(scm_is_eq (SCM_CAR (arg1), sym_at)
- || scm_is_eq (SCM_CAR (arg1), sym_atat))
- && all_symbols (arg1))
- entry_point = scm_list_3 (sym_at, arg1, sym_main);
- else
- entry_point = arg1;
- }
- else
- scm_shell_usage (1, "missing argument to `-e' switch");
- }
-
- else if (! strcmp (argv[i], "-ds")) /* do script here */
- {
- /* We put a dummy "load" expression, and let the -s put the
- filename in. */
- if (!scm_is_null (do_script))
- scm_shell_usage (1, "the -ds switch may only be specified once");
- do_script = scm_cons (SCM_BOOL_F, SCM_EOL);
- tail = scm_cons (scm_cons (sym_load, do_script),
- tail);
- }
-
- else if (! strcmp (argv[i], "--debug"))
- {
- turn_on_debugging = 1;
- dont_turn_on_debugging = 0;
- }
-
- else if (! strcmp (argv[i], "--no-debug"))
- {
- dont_turn_on_debugging = 1;
- turn_on_debugging = 0;
- }
-
- /* Do auto-compile on/off now, because the form itself might need this
- decision. */
- else if (! strcmp (argv[i], "--auto-compile"))
- scm_variable_set_x (scm_c_lookup ("%load-should-auto-compile"),
- SCM_BOOL_T);
-
- else if (! strcmp (argv[i], "--no-auto-compile"))
- scm_variable_set_x (scm_c_lookup ("%load-should-auto-compile"),
- SCM_BOOL_F);
-
- else if (! strcmp (argv[i], "-q")) /* don't load user init */
- inhibit_user_init = 1;
-
- else if (! strncmp (argv[i], "--use-srfi=", 11)) /* load SRFIs */
- {
- SCM srfis = SCM_EOL; /* List of requested SRFIs. */
- char * p = argv[i] + 11;
- while (*p)
- {
- long num;
- char * end;
-
- num = strtol (p, &end, 10);
- if (end - p > 0)
- {
- srfis = scm_cons (scm_from_long (num), srfis);
- if (*end)
- {
- if (*end == ',')
- p = end + 1;
- else
- scm_shell_usage (1, "invalid SRFI specification");
- }
- else
- break;
- }
- else
- scm_shell_usage (1, "invalid SRFI specification");
- }
- if (scm_ilength (srfis) <= 0)
- scm_shell_usage (1, "invalid SRFI specification");
- srfis = scm_reverse_x (srfis, SCM_UNDEFINED);
- tail = scm_cons (scm_list_2 (sym_use_srfis,
- scm_list_2 (scm_sym_quote, srfis)),
- tail);
- }
-
- else if (! strncmp (argv[i], "--listen", 8) /* start a repl server */
- && (argv[i][8] == '\0' || argv[i][8] == '='))
- {
- const char default_template[] =
- "(@@ (system repl server) (spawn-server))";
- const char port_template[] =
- "(@@ (system repl server)"
- " (spawn-server (make-tcp-server-socket #:port ~a)))";
- const char path_template[] =
- "(@@ (system repl server)"
- " (spawn-server (make-unix-domain-server-socket #:path ~s)))";
-
- SCM form_str = SCM_BOOL_F;
- char * p = argv[i] + 8;
-
- if (*p == '=')
- {
- p++;
- if (*p > '0' && *p <= '9')
- {
- /* --listen=PORT */
- SCM port = scm_string_to_number (scm_from_locale_string (p),
- SCM_UNDEFINED);
-
- if (scm_is_false (port))
- scm_shell_usage (1, "invalid port for --listen");
-
- form_str =
- scm_simple_format (SCM_BOOL_F,
- scm_from_locale_string (port_template),
- scm_list_1 (port));
- }
- else if (*p == '/')
- {
- /* --listen=/PATH/TO/SOCKET */
- SCM path = scm_from_locale_string (p);
-
- form_str =
- scm_simple_format (SCM_BOOL_F,
- scm_from_locale_string (path_template),
- scm_list_1 (path));
- }
- else
- {
- /* unknown --listen arg */
- scm_shell_usage (1, "unknown argument to --listen");
- }
- }
- else
- form_str = scm_from_locale_string (default_template);
-
- tail = scm_cons (scm_read (scm_open_input_string (form_str)), tail);
- }
-
- else if (! strcmp (argv[i], "-h")
- || ! strcmp (argv[i], "--help"))
- {
- scm_shell_usage (0, 0);
- exit (EXIT_SUCCESS);
- }
-
- else if (! strcmp (argv[i], "-v")
- || ! strcmp (argv[i], "--version"))
- {
- /* Print version number. */
- version_etc (stdout, scm_usage_name, PACKAGE_NAME, PACKAGE_VERSION,
- /* XXX: Use gettext for the string below. */
- "the Guile developers", NULL);
- exit (EXIT_SUCCESS);
- }
-
- else
- {
- fprintf (stderr, "%s: Unrecognized switch `%s'\n",
- scm_usage_name, argv[i]);
- scm_shell_usage (1, 0);
- }
- }
-
- /* Check to make sure the -ds got a -s. */
- if (!scm_is_null (do_script))
- scm_shell_usage (1, "the `-ds' switch requires the use of `-s' as well");
-
- /* Make any remaining arguments available to the
- script/command/whatever. */
- scm_set_program_arguments (argc ? argc - i : 0, argv + i, argv0);
-
- /* Handle the `-e' switch, if it was specified. */
- if (!scm_is_null (entry_point))
- tail = scm_cons (scm_cons2 (entry_point,
- scm_cons (sym_command_line, SCM_EOL),
- SCM_EOL),
- tail);
-
- /* If we didn't end with a -c or a -s, start the repl. */
- if (interactive)
- {
- tail = scm_cons (scm_list_1 (scm_list_3
- (sym_at,
- scm_list_2 (sym_ice_9, sym_top_repl),
- sym_top_repl)),
- tail);
- }
- else
- {
- /* After doing all the other actions prescribed by the command line,
- quit. */
- tail = scm_cons (scm_cons (sym_quit, SCM_EOL),
- tail);
- }
-
- /* After the following line, actions will be added to the front. */
- tail = scm_reverse_x (tail, SCM_UNDEFINED);
-
- /* add the user-specified load path here, so it won't be in effect
- during the loading of the user's customization file. */
- if(!scm_is_null(user_load_path))
- {
- tail = scm_append_x( scm_cons2(user_load_path, tail, SCM_EOL) );
- }
-
- if (!scm_is_null (user_extensions))
- tail = scm_append_x (scm_cons2 (user_extensions, tail, SCM_EOL));
-
- /* If we didn't end with a -c or a -s and didn't supply a -q, load
- the user's customization file. */
- if (interactive && !inhibit_user_init)
- {
- tail = scm_cons (scm_cons (sym_load_user_init, SCM_EOL), tail);
- }
-
- /* If debugging was requested, or we are interactive and debugging
- was not explicitly turned off, use the debug engine. */
- if (turn_on_debugging || (interactive && !dont_turn_on_debugging))
- {
- scm_c_set_default_vm_engine_x (SCM_VM_DEBUG_ENGINE);
- scm_c_set_vm_engine_x (scm_the_vm (), SCM_VM_DEBUG_ENGINE);
- }
-
- {
- SCM val = scm_cons (sym_begin, tail);
-
- /* Wrap the expression in a prompt. */
- val = scm_list_2 (scm_list_3 (scm_sym_at,
- scm_list_2 (scm_from_latin1_symbol ("ice-9"),
- scm_from_latin1_symbol ("control")),
- scm_from_latin1_symbol ("%")),
- val);
-
-#if 0
- scm_write (val, SCM_UNDEFINED);
- scm_newline (SCM_UNDEFINED);
-#endif
-
- return val;
- }
+ return scm_call_2 (scm_c_public_ref ("ice-9 command-line",
+ "compile-shell-switches"),
+ scm_makfromstrs (argc, argv),
+ (scm_usage_name
+ ? scm_from_locale_string (scm_usage_name)
+ : scm_from_latin1_string ("guile")));
}
diff --git a/libguile/threads.c b/libguile/threads.c
index 14bda1d2f..f49696b1d 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -39,6 +39,7 @@
#endif
#include <assert.h>
+#include <nproc.h>
#include "libguile/validate.h"
#include "libguile/root.h"
@@ -613,6 +614,10 @@ do_thread_exit (void *v)
{
scm_i_thread *t = (scm_i_thread *) v;
+ /* Ensure the signal handling thread has been launched, because we might be
+ shutting it down. This needs to be done in Guile mode. */
+ scm_i_ensure_signal_delivery_thread ();
+
if (!scm_is_false (t->cleanup_handler))
{
SCM ptr = t->cleanup_handler;
@@ -661,7 +666,9 @@ static void *
do_thread_exit_trampoline (struct GC_stack_base *sb, void *v)
{
/* Won't hurt if we are already registered. */
+#if SCM_USE_PTHREAD_THREADS
GC_register_my_thread (sb);
+#endif
return scm_with_guile (do_thread_exit, v);
}
@@ -685,10 +692,6 @@ on_thread_exit (void *v)
case but it doesn't hurt to be consistent. */
scm_i_pthread_setspecific (scm_i_thread_key, t);
- /* Ensure the signal handling thread has been launched, because we might be
- shutting it down. */
- scm_i_ensure_signal_delivery_thread ();
-
/* Scheme-level thread finalizers and other cleanup needs to happen in
guile mode. */
GC_call_with_stack_base (do_thread_exit_trampoline, t);
@@ -720,7 +723,7 @@ on_thread_exit (void *v)
scm_i_pthread_setspecific (scm_i_thread_key, NULL);
-#if !SCM_USE_NULL_THREADS
+#if SCM_USE_PTHREAD_THREADS
GC_unregister_my_thread ();
#endif
}
@@ -774,7 +777,7 @@ scm_i_init_thread_for_guile (struct GC_stack_base *base, SCM parent)
*/
scm_i_init_guile (base);
-#ifdef HAVE_GC_ALLOW_REGISTER_THREADS
+#if defined (HAVE_GC_ALLOW_REGISTER_THREADS) && SCM_USE_PTHREAD_THREADS
/* Allow other threads to come in later. */
GC_allow_register_threads ();
#endif
@@ -789,7 +792,9 @@ scm_i_init_thread_for_guile (struct GC_stack_base *base, SCM parent)
scm_i_pthread_mutex_unlock (&scm_i_init_mutex);
/* Register this thread with libgc. */
+#if SCM_USE_PTHREAD_THREADS
GC_register_my_thread (base);
+#endif
guilify_self_1 (base);
guilify_self_2 (parent);
@@ -2006,6 +2011,39 @@ scm_c_thread_exited_p (SCM thread)
}
#undef FUNC_NAME
+SCM_DEFINE (scm_total_processor_count, "total-processor-count", 0, 0, 0,
+ (void),
+ "Return the total number of processors of the machine, which\n"
+ "is guaranteed to be at least 1. A ``processor'' here is a\n"
+ "thread execution unit, which can be either:\n\n"
+ "@itemize\n"
+ "@item an execution core in a (possibly multi-core) chip, in a\n"
+ " (possibly multi- chip) module, in a single computer, or\n"
+ "@item a thread execution unit inside a core in the case of\n"
+ " @dfn{hyper-threaded} CPUs.\n"
+ "@end itemize\n\n"
+ "Which of the two definitions is used, is unspecified.\n")
+#define FUNC_NAME s_scm_total_processor_count
+{
+ return scm_from_ulong (num_processors (NPROC_ALL));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_current_processor_count, "current-processor-count", 0, 0, 0,
+ (void),
+ "Like @code{total-processor-count}, but return the number of\n"
+ "processors available to the current process. See\n"
+ "@code{setaffinity} and @code{getaffinity} for more\n"
+ "information.\n")
+#define FUNC_NAME s_scm_current_processor_count
+{
+ return scm_from_ulong (num_processors (NPROC_CURRENT));
+}
+#undef FUNC_NAME
+
+
+
+
static scm_i_pthread_cond_t wake_up_cond;
static int threads_initialized_p = 0;
diff --git a/libguile/threads.h b/libguile/threads.h
index 9e44684e1..609262a19 100644
--- a/libguile/threads.h
+++ b/libguile/threads.h
@@ -230,6 +230,9 @@ SCM_API int scm_pthread_cond_timedwait (pthread_cond_t *cond,
SCM_API unsigned int scm_std_sleep (unsigned int);
SCM_API unsigned long scm_std_usleep (unsigned long);
+SCM_API SCM scm_total_processor_count (void);
+SCM_API SCM scm_current_processor_count (void);
+
#endif /* SCM_THREADS_H */
/*