diff options
author | Andy Wingo <wingo@pobox.com> | 2011-04-28 15:53:35 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2011-04-28 15:53:35 +0200 |
commit | 1903eae4c9ab97b575dad4ab1f5cf05436d84ab3 (patch) | |
tree | dbb5a83c4dce6f6f10642b3d39ec76ee63dd77a5 /libguile | |
parent | 0c81a0c13ad39c381e4ff4d073e3158bcfd51a7a (diff) | |
parent | 91956a94fe6363cf69d574b56397962ec6ef4468 (diff) | |
download | guile-1903eae4c9ab97b575dad4ab1f5cf05436d84ab3.tar.gz |
Merge remote-tracking branch 'origin/stable-2.0'
Conflicts:
GUILE-VERSION
Diffstat (limited to 'libguile')
-rw-r--r-- | libguile/Makefile.am | 5 | ||||
-rw-r--r-- | libguile/filesys.c | 905 | ||||
-rw-r--r-- | libguile/fports.c | 9 | ||||
-rw-r--r-- | libguile/gc.c | 83 | ||||
-rw-r--r-- | libguile/hashtab.c | 52 | ||||
-rw-r--r-- | libguile/i18n.c | 35 | ||||
-rw-r--r-- | libguile/init.c | 9 | ||||
-rw-r--r-- | libguile/load.c | 42 | ||||
-rw-r--r-- | libguile/numbers.c | 2 | ||||
-rw-r--r-- | libguile/ports.c | 14 | ||||
-rw-r--r-- | libguile/posix.c | 141 | ||||
-rw-r--r-- | libguile/posix.h | 5 | ||||
-rw-r--r-- | libguile/r6rs-ports.c | 20 | ||||
-rw-r--r-- | libguile/script.c | 467 | ||||
-rw-r--r-- | libguile/threads.c | 50 | ||||
-rw-r--r-- | libguile/threads.h | 3 |
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 */ /* |