X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/c12da2be81d5a77040f2e75a2a0646837b29c4f5..8cb0d6d7fa9aaac316c29a64c541336b51b6f93d:/libguile/load.c diff --git a/libguile/load.c b/libguile/load.c index 74eab19b3..50b3180e6 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -1,5 +1,5 @@ /* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2004, 2006, 2008, - * 2009, 2010, 2011, 2012 Free Software Foundation, Inc. + * 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 @@ -50,10 +50,7 @@ #include #include - -#ifdef HAVE_UNISTD_H #include -#endif /* HAVE_UNISTD_H */ #ifdef HAVE_PWD_H #include @@ -89,7 +86,6 @@ SCM_DEFINE (scm_primitive_load, "primitive-load", 1, 0, 0, { SCM hook = *scm_loc_load_hook; SCM ret = SCM_UNSPECIFIED; - char *encoding; SCM_VALIDATE_STRING (1, filename); if (scm_is_true (hook) && scm_is_false (scm_procedure_p (hook))) @@ -102,18 +98,14 @@ SCM_DEFINE (scm_primitive_load, "primitive-load", 1, 0, 0, { SCM port; - port = scm_open_file (filename, scm_from_locale_string ("r")); + 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; @@ -198,6 +190,19 @@ SCM_DEFINE (scm_sys_global_site_dir, "%global-site-dir", 0,0,0, #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 */ + /* Initializing the load path, and searching it. */ @@ -221,6 +226,9 @@ static SCM *scm_loc_fresh_auto_compile; /* 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" @@ -243,6 +251,32 @@ SCM_DEFINE (scm_parse_path, "parse-path", 1, 1, 0, } #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 + /* Initialize the global variable %load-path, given the value of the SCM_SITE_DIR and SCM_LIBRARY_DIR preprocessor symbols and the @@ -316,11 +350,11 @@ scm_init_load_path () env = 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"); 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; @@ -418,6 +452,60 @@ scm_c_string_has_an_ext (char *str, size_t len, SCM extensions) return 0; } +#ifdef __MINGW32__ +#define FILE_NAME_SEPARATOR_STRING "\\" +#else +#define FILE_NAME_SEPARATOR_STRING "/" +#endif + +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 pathname; otherwise, return #f. @@ -448,16 +536,7 @@ search_path (SCM path, SCM filename, SCM extensions, SCM require_exts, scm_dynwind_free (filename_chars); /* If FILENAME is absolute and is still valid, 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 (is_absolute_file_name (filename)) { if ((scm_is_false (require_exts) || scm_c_string_has_an_ext (filename_chars, filename_len, @@ -491,11 +570,7 @@ search_path (SCM path, SCM filename, SCM extensions, SCM require_exts, 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; @@ -524,12 +599,9 @@ search_path (SCM path, SCM filename, SCM extensions, SCM require_exts, /* 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; @@ -571,9 +643,9 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 0, 1, "@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; @@ -794,34 +866,48 @@ scm_try_auto_compile (SCM source) 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; @@ -895,11 +981,13 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1, 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)) @@ -1047,6 +1135,8 @@ scm_init_load () 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);