-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2004, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2004, 2006, 2008,
+ * 2009, 2010, 2011, 2012, 2013, 2014 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
#include <stdio.h>
#include "libguile/_scm.h"
-#include "libguile/private-gc.h" /* scm_getenv_int */
#include "libguile/libpath.h"
#include "libguile/fports.h"
#include "libguile/read.h"
#include <sys/types.h>
#include <sys/stat.h>
-
-#ifdef HAVE_UNISTD_H
#include <unistd.h>
-#endif /* HAVE_UNISTD_H */
#ifdef HAVE_PWD_H
#include <pwd.h>
#define FUNC_NAME s_scm_primitive_load
{
SCM hook = *scm_loc_load_hook;
- char *encoding;
+ SCM ret = SCM_UNSPECIFIED;
+
SCM_VALIDATE_STRING (1, filename);
if (scm_is_true (hook) && scm_is_false (scm_procedure_p (hook)))
SCM_MISC_ERROR ("value of %load-hook is neither a procedure nor #f",
if (!scm_is_false (hook))
scm_call_1 (hook, filename);
- { /* scope */
- SCM port = scm_open_file (filename, scm_from_locale_string ("r"));
+ {
+ SCM port;
+
+ port = scm_open_file_with_encoding (filename,
+ scm_from_latin1_string ("r"),
+ SCM_BOOL_T, /* guess_encoding */
+ scm_from_latin1_string ("UTF-8"));
+
scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
scm_i_dynwind_current_load_port (port);
- encoding = scm_i_scan_for_encoding (port);
- if (encoding)
- scm_i_set_port_encoding_x (port, encoding);
- else
- /* The file has no encoding declared. We'll presume UTF-8, like
- compile-file does. */
- scm_i_set_port_encoding_x (port, "UTF-8");
-
while (1)
{
SCM reader, form;
if (SCM_EOF_OBJECT_P (form))
break;
- scm_primitive_eval_x (form);
+ ret = scm_primitive_eval_x (form);
}
scm_dynwind_end ();
scm_close_port (port);
}
- return SCM_UNSPECIFIED;
+ return ret;
}
#undef FUNC_NAME
#undef FUNC_NAME
#endif /* SCM_GLOBAL_SITE_DIR */
+#ifdef SCM_SITE_CCACHE_DIR
+SCM_DEFINE (scm_sys_site_ccache_dir, "%site-ccache-dir", 0,0,0,
+ (),
+ "Return the directory where users should install compiled\n"
+ "@code{.go} files for use with this version of Guile.\n\n"
+ "E.g., may return \"/usr/lib/guile/" SCM_EFFECTIVE_VERSION "/site-ccache\".")
+#define FUNC_NAME s_scm_sys_site_ccache_dir
+{
+ return scm_from_locale_string (SCM_SITE_CCACHE_DIR);
+}
+#undef FUNC_NAME
+#endif /* SCM_SITE_CCACHE_DIR */
+
\f
/* Initializing the load path, and searching it. */
/* The fallback path for auto-compilation */
static SCM *scm_loc_compile_fallback_path;
+/* Ellipsis: "..." */
+static SCM scm_ellipsis;
+
SCM_DEFINE (scm_parse_path, "parse-path", 1, 1, 0,
(SCM path, SCM tail),
"Parse @var{path}, which is expected to be a colon-separated\n"
}
#undef FUNC_NAME
+SCM_DEFINE (scm_parse_path_with_ellipsis, "parse-path-with-ellipsis", 2, 0, 0,
+ (SCM path, SCM base),
+ "Parse @var{path}, which is expected to be a colon-separated\n"
+ "string, into a list and return the resulting list with\n"
+ "@var{base} (a list) spliced in place of the @code{...} path\n"
+ "component, if present, or else @var{base} is added to the end.\n"
+ "If @var{path} is @code{#f}, @var{base} is returned.")
+#define FUNC_NAME s_scm_parse_path_with_ellipsis
+{
+ SCM lst = scm_parse_path (path, SCM_EOL);
+ SCM walk = lst;
+ SCM *prev = &lst;
+
+ while (!scm_is_null (walk) &&
+ scm_is_false (scm_equal_p (scm_car (walk), scm_ellipsis)))
+ {
+ prev = SCM_CDRLOC (walk);
+ walk = *prev;
+ }
+ *prev = scm_is_null (walk)
+ ? base
+ : scm_append (scm_list_2 (base, scm_cdr (walk)));
+ return lst;
+}
+#undef FUNC_NAME
+
+/* On Posix hosts, just return PATH unaltered. On Windows,
+ destructively replace all backslashes in PATH with Unix-style
+ forward slashes, so that Scheme code always gets d:/foo/bar style
+ file names. This avoids multiple subtle problems with comparing
+ file names as strings, and with redirections in /bin/sh command
+ lines.
+
+ Note that, if PATH is result of a call to 'getenv', this
+ destructively modifies the environment variables, so both
+ scm_getenv and subprocesses will afterwards see the values with
+ forward slashes. That is OK as long as applied to Guile-specific
+ environment variables, since having scm_getenv return the same
+ value as used by the callers of this function is good for
+ consistency and file-name comparison. Avoid using this function on
+ values returned by 'getenv' for general-purpose environment
+ variables; instead, make a copy of the value and work on that. */
+SCM_INTERNAL char *
+scm_i_mirror_backslashes (char *path)
+{
+#ifdef __MINGW32__
+ if (path)
+ {
+ char *p = path;
+
+ while (*p)
+ {
+ if (*p == '\\')
+ *p = '/';
+ p++;
+ }
+ }
+#endif
+
+ return path;
+}
/* Initialize the global variable %load-path, given the value of the
SCM_SITE_DIR and SCM_LIBRARY_DIR preprocessor symbols and the
SCM cpath = SCM_EOL;
#ifdef SCM_LIBRARY_DIR
- env = getenv ("GUILE_SYSTEM_PATH");
+ env = scm_i_mirror_backslashes (getenv ("GUILE_SYSTEM_PATH"));
if (env && strcmp (env, "") == 0)
/* special-case interpret system-path=="" as meaning no system path instead
of '("") */
scm_from_locale_string (SCM_GLOBAL_SITE_DIR),
scm_from_locale_string (SCM_PKGDATA_DIR));
- env = getenv ("GUILE_SYSTEM_COMPILED_PATH");
+ env = scm_i_mirror_backslashes (getenv ("GUILE_SYSTEM_COMPILED_PATH"));
if (env && strcmp (env, "") == 0)
/* like above */
;
cachedir[0] = 0;
if (cachedir[0])
- *scm_loc_compile_fallback_path = scm_from_locale_string (cachedir);
+ {
+ scm_i_mirror_backslashes (cachedir);
+ *scm_loc_compile_fallback_path = scm_from_locale_string (cachedir);
+ }
}
- env = getenv ("GUILE_LOAD_PATH");
+ env = scm_i_mirror_backslashes (getenv ("GUILE_LOAD_PATH"));
if (env)
- path = scm_parse_path (scm_from_locale_string (env), path);
+ path = scm_parse_path_with_ellipsis (scm_from_locale_string (env), path);
- env = getenv ("GUILE_LOAD_COMPILED_PATH");
+ env = scm_i_mirror_backslashes (getenv ("GUILE_LOAD_COMPILED_PATH"));
if (env)
- cpath = scm_parse_path (scm_from_locale_string (env), cpath);
+ cpath = scm_parse_path_with_ellipsis (scm_from_locale_string (env), cpath);
*scm_loc_load_path = path;
*scm_loc_load_compiled_path = cpath;
/* Utility functions for assembling C strings in a buffer.
*/
-struct stringbuf {
+struct stringbuf
+{
char *buf, *ptr;
size_t buf_len;
};
-static void
-stringbuf_free (void *data)
-{
- struct stringbuf *buf = (struct stringbuf *)data;
- free (buf->buf);
-}
-
static void
stringbuf_grow (struct stringbuf *buf)
{
- size_t ptroff = buf->ptr - buf->buf;
- buf->buf_len *= 2;
- buf->buf = scm_realloc (buf->buf, buf->buf_len);
+ size_t ptroff, prev_len;
+ void *prev_buf = buf->buf;
+
+ prev_len = buf->buf_len;
+ ptroff = buf->ptr - buf->buf;
+
+ buf->buf_len *= 2;
+ buf->buf = scm_gc_malloc_pointerless (buf->buf_len, "search-path");
+ memcpy (buf->buf, prev_buf, prev_len);
buf->ptr = buf->buf + ptroff;
}
}
}
-
+/* Return non-zero if STR is suffixed by a dot followed by one of
+ EXTENSIONS. */
static int
-scm_c_string_has_an_ext (char *str, size_t len, SCM extensions)
+string_has_an_ext (SCM str, SCM extensions)
{
for (; !scm_is_null (extensions); extensions = SCM_CDR (extensions))
{
- char *ext;
- size_t extlen;
- int match;
- ext = scm_to_locale_string (SCM_CAR (extensions));
- extlen = strlen (ext);
- match = (len > extlen && str[len - extlen - 1] == '.'
- && strncmp (str + (len - extlen), ext, extlen) == 0);
- free (ext);
- if (match)
- return 1;
+ SCM extension;
+
+ extension = SCM_CAR (extensions);
+ if (scm_is_true (scm_string_suffix_p (extension, str,
+ SCM_UNDEFINED, SCM_UNDEFINED,
+ SCM_UNDEFINED, SCM_UNDEFINED)))
+ return 1;
}
+
+ return 0;
+}
+
+/* Defined as "/" for Unix and Windows alike, so that file names
+ constructed by the functions in this module wind up with Unix-style
+ forward slashes as directory separators. */
+#define FILE_NAME_SEPARATOR_STRING "/"
+
+static int
+is_file_name_separator (SCM c)
+{
+ if (scm_is_eq (c, SCM_MAKE_CHAR ('/')))
+ return 1;
+#ifdef __MINGW32__
+ if (scm_is_eq (c, SCM_MAKE_CHAR ('\\')))
+ return 1;
+#endif
+ return 0;
+}
+
+static int
+is_drive_letter (SCM c)
+{
+#ifdef __MINGW32__
+ if (SCM_CHAR (c) >= 'a' && SCM_CHAR (c) <= 'z')
+ return 1;
+ else if (SCM_CHAR (c) >= 'A' && SCM_CHAR (c) <= 'Z')
+ return 1;
+#endif
+ return 0;
+}
+
+static int
+is_absolute_file_name (SCM filename)
+{
+ size_t filename_len = scm_c_string_length (filename);
+
+ if (filename_len >= 1
+ && is_file_name_separator (scm_c_string_ref (filename, 0))
+#ifdef __MINGW32__
+ /* On Windows, one initial separator indicates a drive-relative
+ path. Two separators indicate a Universal Naming Convention
+ (UNC) path. UNC paths are always absolute. */
+ && filename_len >= 2
+ && is_file_name_separator (scm_c_string_ref (filename, 1))
+#endif
+ )
+ return 1;
+ if (filename_len >= 3
+ && is_drive_letter (scm_c_string_ref (filename, 0))
+ && scm_is_eq (scm_c_string_ref (filename, 1), SCM_MAKE_CHAR (':'))
+ && is_file_name_separator (scm_c_string_ref (filename, 2)))
+ return 1;
return 0;
}
/* Search PATH for a directory containing a file named FILENAME.
The file must be readable, and not a directory.
- If we find one, return its full filename; otherwise, return #f.
+ If we find one, return its full pathname; otherwise, return #f.
If FILENAME is absolute, return it unchanged.
+ We also fill *stat_buf corresponding to the returned pathname.
If given, EXTENSIONS is a list of strings; for each directory
in PATH, we search for FILENAME concatenated with each EXTENSION. */
static SCM
char *filename_chars;
size_t filename_len;
SCM result = SCM_BOOL_F;
+ char initial_buffer[256];
if (scm_ilength (path) < 0)
scm_misc_error ("%search-path", "path is not a proper list: ~a",
filename_len = strlen (filename_chars);
scm_dynwind_free (filename_chars);
- /* If FILENAME is absolute, return it unchanged. */
-#ifdef __MINGW32__
- if (((filename_len >= 1) &&
- (filename_chars[0] == '/' || filename_chars[0] == '\\')) ||
- ((filename_len >= 3) && filename_chars[1] == ':' &&
- ((filename_chars[0] >= 'a' && filename_chars[0] <= 'z') ||
- (filename_chars[0] >= 'A' && filename_chars[0] <= 'Z')) &&
- (filename_chars[2] == '/' || filename_chars[2] == '\\')))
-#else
- if (filename_len >= 1 && filename_chars[0] == '/')
-#endif
+ /* If FILENAME is absolute and is still valid, return it unchanged. */
+ if (is_absolute_file_name (filename))
{
- SCM res = filename;
- if (scm_is_true (require_exts) &&
- !scm_c_string_has_an_ext (filename_chars, filename_len,
- extensions))
- res = SCM_BOOL_F;
-
- scm_dynwind_end ();
- return res;
+ if ((scm_is_false (require_exts) ||
+ string_has_an_ext (filename, extensions))
+ && stat (filename_chars, stat_buf) == 0
+ && !(stat_buf->st_mode & S_IFDIR))
+ result = filename;
+ goto end;
}
/* If FILENAME has an extension, don't try to add EXTENSIONS to it. */
if (*endp == '.')
{
if (scm_is_true (require_exts) &&
- !scm_c_string_has_an_ext (filename_chars, filename_len,
- extensions))
+ !string_has_an_ext (filename, extensions))
{
/* This filename has an extension, but not one of the right
ones... */
- scm_dynwind_end ();
- return SCM_BOOL_F;
+ goto end;
}
/* This filename already has an extension, so cancel the
list of extensions. */
extensions = SCM_EOL;
break;
}
-#ifdef __MINGW32__
- else if (*endp == '/' || *endp == '\\')
-#else
- else if (*endp == '/')
-#endif
+ else if (is_file_name_separator (SCM_MAKE_CHAR (*endp)))
/* This filename has no extension, so keep the current list
of extensions. */
break;
if (scm_is_null (extensions))
extensions = scm_listofnullstr;
- buf.buf_len = 512;
- buf.buf = scm_malloc (buf.buf_len);
- scm_dynwind_unwind_handler (stringbuf_free, &buf, SCM_F_WIND_EXPLICITLY);
+ buf.buf_len = sizeof initial_buffer;
+ buf.buf = initial_buffer;
/* Try every path element.
*/
/* Concatenate the path name and the filename. */
-#ifdef __MINGW32__
- if ((buf.ptr > buf.buf) && (buf.ptr[-1] != '/') && (buf.ptr[-1] != '\\'))
-#else
- if ((buf.ptr > buf.buf) && (buf.ptr[-1] != '/'))
-#endif
- stringbuf_cat (&buf, "/");
+ if (buf.ptr > buf.buf
+ && !is_file_name_separator (SCM_MAKE_CHAR (buf.ptr[-1])))
+ stringbuf_cat (&buf, FILE_NAME_SEPARATOR_STRING);
stringbuf_cat (&buf, filename_chars);
sans_ext_len = buf.ptr - buf.buf;
if (stat (buf.buf, stat_buf) == 0
&& ! (stat_buf->st_mode & S_IFDIR))
{
- result = scm_from_locale_string (buf.buf);
+ result =
+ scm_from_locale_string (scm_i_mirror_backslashes (buf.buf));
goto end;
}
}
"@var{filename}. The file must be readable, and not a directory.\n"
"If we find one, return its full filename; otherwise, return\n"
"@code{#f}. If @var{filename} is absolute, return it unchanged.\n"
- "If given, @var{extensions} is a list of strings; for each\n"
+ "If given, @var{rest} is a list of extension strings; for each\n"
"directory in @var{path}, we search for @var{filename}\n"
- "concatenated with each @var{extension}.")
+ "concatenated with each extension.")
#define FUNC_NAME s_scm_search_path
{
SCM extensions, require_exts;
NULL, NULL);
}
-/* See also (system base compile):compiled-file-name. */
+/* The auto-compilation code will residualize a .go file in the cache
+ dir: by default, $HOME/.cache/guile/2.0/ccache/PATH.go. This
+ function determines the PATH to use as a key into the compilation
+ cache. See also (system base compile):compiled-file-name. */
static SCM
canonical_suffix (SCM fname)
{
SCM canon;
- size_t len;
+ /* CANON should be absolute. */
canon = scm_canonicalize_path (fname);
- len = scm_c_string_length (canon);
-
- if (len > 1 && scm_is_eq (scm_c_string_ref (canon, 0), SCM_MAKE_CHAR ('/')))
- return canon;
- else if (len > 2 && scm_is_eq (scm_c_string_ref (canon, 1), SCM_MAKE_CHAR (':')))
- return scm_string_append (scm_list_3 (scm_from_latin1_string ("/"),
- scm_c_substring (canon, 0, 1),
- scm_c_substring (canon, 2, len)));
- else
- return canon;
+
+#ifdef __MINGW32__
+ {
+ size_t len = scm_c_string_length (canon);
+
+ /* On Windows, an absolute file name that doesn't start with a
+ separator starts with a drive component. Transform the drive
+ component to a file name element: c:\foo -> \c\foo. */
+ if (len >= 2
+ && is_absolute_file_name (canon)
+ && !is_file_name_separator (scm_c_string_ref (canon, 0)))
+ return scm_string_append
+ (scm_list_3 (scm_from_latin1_string (FILE_NAME_SEPARATOR_STRING),
+ scm_c_substring (canon, 0, 1),
+ scm_c_substring (canon, 2, len)));
+ }
+#endif
+
+ return canon;
}
SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
(SCM args),
"Search @var{%load-path} for the file named @var{filename} and\n"
- "load it into the top-level environment. If @var{filename} is a\n"
- "relative pathname and is not found in the list of search paths,\n"
- "an error is signalled, unless the optional argument\n"
- "@var{exception_on_not_found} is @code{#f}, in which case\n"
- "@code{#f} is returned instead.")
+ "load it into the top-level environment.\n\n"
+ "If @var{filename} is a relative pathname and is not found in\n"
+ "the list of search paths, one of three things may happen,\n"
+ "depending on the optional second argument,\n"
+ "@var{exception_on_not_found}. If it is @code{#f}, @code{#f}\n"
+ "will be returned. If it is a procedure, it will be called\n"
+ "with no arguments. Otherwise an error is signalled.")
#define FUNC_NAME s_scm_primitive_load_path
{
SCM filename, exception_on_not_found;
if (scm_is_false (full_filename) && scm_is_false (compiled_filename))
{
- if (scm_is_true (exception_on_not_found))
+ if (scm_is_true (scm_procedure_p (exception_on_not_found)))
+ return scm_call_0 (exception_on_not_found);
+ else if (scm_is_false (exception_on_not_found))
+ return SCM_BOOL_F;
+ else
SCM_MISC_ERROR ("Unable to find file ~S in load path",
scm_list_1 (filename));
- else
- return SCM_BOOL_F;
}
if (!scm_is_false (hook))
scm_loc_fresh_auto_compile
= SCM_VARIABLE_LOC (scm_c_define ("%fresh-auto-compile", SCM_BOOL_F));
+ scm_ellipsis = scm_from_latin1_string ("...");
+
the_reader = scm_make_fluid_with_default (SCM_BOOL_F);
scm_c_define("current-reader", the_reader);