X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/f33b174d0e9b310bf97d6608603b72eb587952ea..bc36d0502b9b2ac7e43ded2e1fbeed2f1499bb1d:/libguile/load.c diff --git a/libguile/load.c b/libguile/load.c index 06eacbd8f..00ec130a1 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -1,50 +1,29 @@ -/* Copyright (C) 1995,1996,1998,1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,1999,2000,2001 Free Software Foundation, Inc. * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * 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 2.1 of the License, or (at your option) any later version. * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ -/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, - gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ -#include +#if HAVE_CONFIG_H +# include +#endif + +#include + #include "libguile/_scm.h" #include "libguile/libpath.h" #include "libguile/fports.h" @@ -56,6 +35,7 @@ #include "libguile/root.h" #include "libguile/strings.h" #include "libguile/modules.h" +#include "libguile/lang.h" #include "libguile/validate.h" #include "libguile/load.h" @@ -95,41 +75,34 @@ load (void *data) SCM form = scm_read (port); if (SCM_EOF_OBJECT_P (form)) break; - /* Ugh! We need to re-check the environment for every form. - * We should change this in the new module system. - */ - scm_i_eval_x (form, - scm_module_system_booted_p - ? (scm_top_level_env - (SCM_MODULE_EVAL_CLOSURE (scm_selected_module ()))) - : SCM_EOL); + scm_primitive_eval_x (form); } return SCM_UNSPECIFIED; } SCM_DEFINE (scm_primitive_load, "primitive-load", 1, 0, 0, (SCM filename), - "Load @var{file} and evaluate its contents in the top-level environment.\n" - "The load paths are not searched; @var{file} must either be a full\n" - "pathname or be a pathname relative to the current directory. If the\n" - "variable @code{%load-hook} is defined, it should be bound to a procedure\n" - "that will be called before any code is loaded. See documentation for\n" - "@code{%load-hook} later in this section.") + "Load the file named @var{filename} and evaluate its contents in\n" + "the top-level environment. The load paths are not searched;\n" + "@var{filename} must either be a full pathname or be a pathname\n" + "relative to the current directory. If the variable\n" + "@code{%load-hook} is defined, it should be bound to a procedure\n" + "that will be called before any code is loaded. See the\n" + "documentation for @code{%load-hook} later in this section.") #define FUNC_NAME s_scm_primitive_load { SCM hook = *scm_loc_load_hook; - SCM_VALIDATE_ROSTRING (1,filename); - SCM_ASSERT (SCM_FALSEP (hook) || (SCM_EQ_P (scm_procedure_p (hook), SCM_BOOL_T)), - hook, "value of %load-hook is neither a procedure nor #f", - FUNC_NAME); + 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", + SCM_EOL); - if (! SCM_FALSEP (hook)) - scm_apply (hook, scm_listify (filename, SCM_UNDEFINED), SCM_EOL); + if (!scm_is_false (hook)) + scm_call_1 (hook, filename); { /* scope */ SCM port, save_port; - port = scm_open_file (filename, - scm_makfromstr ("r", (scm_sizet) sizeof (char), 0)); + port = scm_open_file (filename, scm_mem2string ("r", sizeof (char))); save_port = port; scm_internal_dynamic_wind (swap_port, load, @@ -142,6 +115,12 @@ SCM_DEFINE (scm_primitive_load, "primitive-load", 1, 0, 0, } #undef FUNC_NAME +SCM +scm_c_primitive_load (const char *filename) +{ + return scm_primitive_load (scm_makfrom0str (filename)); +} + /* Builtin path to scheme library files. */ #ifdef SCM_PKGDATA_DIR @@ -209,8 +188,12 @@ scm_internal_parse_path (char *path, SCM tail) do { /* Scan back to the beginning of the current element. */ do scan--; +#ifdef __MINGW32__ + while (scan >= path && *scan != ';'); +#else while (scan >= path && *scan != ':'); - tail = scm_cons (scm_makfromstr (scan + 1, elt_end - (scan + 1), 0), +#endif + tail = scm_cons (scm_mem2string (scan + 1, elt_end - (scan + 1)), tail); elt_end = scan; } while (scan >= path); @@ -222,17 +205,20 @@ scm_internal_parse_path (char *path, SCM tail) 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" + "string, into a list and return the resulting list with\n" + "@var{tail} appended. If @var{path} is @code{#f}, @var{tail}\n" + "is returned.") #define FUNC_NAME s_scm_parse_path { - SCM_ASSERT (SCM_FALSEP (path) || (SCM_ROSTRINGP (path)), + SCM_ASSERT (scm_is_false (path) || (SCM_STRINGP (path)), path, SCM_ARG1, FUNC_NAME); if (SCM_UNBNDP (tail)) tail = SCM_EOL; - return (SCM_FALSEP (path) + return (scm_is_false (path) ? tail - : scm_internal_parse_path (SCM_ROCHARS (path), tail)); + : scm_internal_parse_path (SCM_STRING_CHARS (path), tail)); } #undef FUNC_NAME @@ -246,10 +232,9 @@ scm_init_load_path () SCM path = SCM_EOL; #ifdef SCM_LIBRARY_DIR - path = scm_listify (scm_makfrom0str (SCM_SITE_DIR), - scm_makfrom0str (SCM_LIBRARY_DIR), - scm_makfrom0str (SCM_PKGDATA_DIR), - SCM_UNDEFINED); + path = scm_list_3 (scm_makfrom0str (SCM_SITE_DIR), + scm_makfrom0str (SCM_LIBRARY_DIR), + scm_makfrom0str (SCM_PKGDATA_DIR)); #endif /* SCM_LIBRARY_DIR */ path = scm_internal_parse_path (getenv ("GUILE_LOAD_PATH"), path); @@ -267,7 +252,13 @@ SCM scm_listofnullstr; in PATH, we search for FILENAME concatenated with each EXTENSION. */ SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0, (SCM path, SCM filename, SCM extensions), - "") + "Search @var{path} for a directory containing a file named\n" + "@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" + "directory in @var{path}, we search for @var{filename}\n" + "concatenated with each @var{extension}.") #define FUNC_NAME s_scm_search_path { char *filename_chars; @@ -275,18 +266,27 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0, size_t max_path_len; /* maximum length of any PATH element */ size_t max_ext_len; /* maximum length of any EXTENSIONS element */ - SCM_VALIDATE_LIST (1,path); - SCM_VALIDATE_ROSTRING (2,filename); + SCM_VALIDATE_LIST (1, path); + SCM_VALIDATE_STRING (2, filename); if (SCM_UNBNDP (extensions)) extensions = SCM_EOL; else - SCM_VALIDATE_LIST (3,extensions); + SCM_VALIDATE_LIST (3, extensions); - filename_chars = SCM_ROCHARS (filename); - filename_len = SCM_ROLENGTH (filename); + filename_chars = SCM_STRING_CHARS (filename); + filename_len = SCM_STRING_LENGTH (filename); /* 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 return filename; /* Find the length of the longest element of path. */ @@ -294,14 +294,13 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0, SCM walk; max_path_len = 0; - for (walk = path; SCM_NNULLP (walk); walk = SCM_CDR (walk)) + for (walk = path; !SCM_NULL_OR_NIL_P (walk); walk = SCM_CDR (walk)) { SCM elt = SCM_CAR (walk); - SCM_ASSERT (SCM_ROSTRINGP (elt), elt, - "path is not a list of strings", - FUNC_NAME); - if (SCM_ROLENGTH (elt) > max_path_len) - max_path_len = SCM_ROLENGTH (elt); + SCM_ASSERT_TYPE (SCM_STRINGP (elt), path, 1, FUNC_NAME, + "list of strings"); + if (SCM_STRING_LENGTH (elt) > max_path_len) + max_path_len = SCM_STRING_LENGTH (elt); } } @@ -320,7 +319,11 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0, extensions = SCM_EOL; break; } +#ifdef __MINGW32__ + else if (*endp == '/' || *endp == '\\') +#else else if (*endp == '/') +#endif /* This filename has no extension, so keep the current list of extensions. */ break; @@ -333,14 +336,13 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0, SCM walk; max_ext_len = 0; - for (walk = extensions; SCM_NNULLP (walk); walk = SCM_CDR (walk)) + for (walk = extensions; !SCM_NULL_OR_NIL_P (walk); walk = SCM_CDR (walk)) { SCM elt = SCM_CAR (walk); - SCM_ASSERT (SCM_ROSTRINGP (elt), elt, - "extension list is not a list of strings", - FUNC_NAME); - if (SCM_ROLENGTH (elt) > max_ext_len) - max_ext_len = SCM_ROLENGTH (elt); + SCM_ASSERT_TYPE (SCM_STRINGP (elt), elt, 3, FUNC_NAME, + "list of strings"); + if (SCM_STRING_LENGTH (elt) > max_ext_len) + max_ext_len = SCM_STRING_LENGTH (elt); } } @@ -348,39 +350,43 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0, { /* scope */ SCM result = SCM_BOOL_F; - int buf_size = max_path_len + 1 + filename_len + max_ext_len + 1; - char *buf = SCM_MUST_MALLOC (buf_size); + size_t buf_size = max_path_len + 1 + filename_len + max_ext_len + 1; + char *buf = scm_malloc (buf_size); /* This simplifies the loop below a bit. */ - if (SCM_NULLP (extensions)) + if (SCM_NULL_OR_NIL_P (extensions)) extensions = scm_listofnullstr; /* Try every path element. At this point, we know the path is a proper list of strings. */ - for (; SCM_NNULLP (path); path = SCM_CDR (path)) + for (; !SCM_NULL_OR_NIL_P (path); path = SCM_CDR (path)) { - int len; + size_t len; SCM dir = SCM_CAR (path); SCM exts; /* Concatenate the path name and the filename. */ - len = SCM_ROLENGTH (dir); - memcpy (buf, SCM_ROCHARS (dir), len); + len = SCM_STRING_LENGTH (dir); + memcpy (buf, SCM_STRING_CHARS (dir), len); +#ifdef __MINGW32__ + if (len >= 1 && buf[len - 1] != '/' && buf[len - 1] != '\\') +#else if (len >= 1 && buf[len - 1] != '/') +#endif buf[len++] = '/'; memcpy (buf + len, filename_chars, filename_len); len += filename_len; /* Try every extension. At this point, we know the extension list is a proper, nonempty list of strings. */ - for (exts = extensions; SCM_NNULLP (exts); exts = SCM_CDR (exts)) + for (exts = extensions; !SCM_NULL_OR_NIL_P (exts); exts = SCM_CDR (exts)) { SCM ext = SCM_CAR (exts); - int ext_len = SCM_ROLENGTH (ext); + size_t ext_len = SCM_STRING_LENGTH (ext); struct stat mode; /* Concatenate the extension. */ - memcpy (buf + len, SCM_ROCHARS (ext), ext_len); + memcpy (buf + len, SCM_STRING_CHARS (ext), ext_len); buf[len + ext_len] = '\0'; /* If the file exists at all, we should return it. If the @@ -388,15 +394,14 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0, if (stat (buf, &mode) == 0 && ! (mode.st_mode & S_IFDIR)) { - result = scm_makfromstr (buf, len + ext_len, 0); + result = scm_mem2string (buf, len + ext_len); goto end; } } } end: - scm_must_free (buf); - scm_done_malloc (- buf_size); + free (buf); SCM_ALLOW_INTS; return result; } @@ -409,79 +414,67 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0, If we find one, return its full filename; otherwise, return #f. If FILENAME is absolute, return it unchanged. */ SCM_DEFINE (scm_sys_search_load_path, "%search-load-path", 1, 0, 0, - (SCM filename), - "Search @var{%load-path} for @var{file}, which must be readable by the\n" - "current user. If @var{file} is found in the list of paths to search or\n" - "is an absolute pathname, return its full pathname. Otherwise, return\n" - "@code{#f}. Filenames may have any of the optional extensions in the\n" - "@code{%load-extensions} list; @code{%search-load-path} will try each\n" - "extension automatically.") + (SCM filename), + "Search @var{%load-path} for the file named @var{filename},\n" + "which must be readable by the current user. If @var{filename}\n" + "is found in the list of paths to search or is an absolute\n" + "pathname, return its full pathname. Otherwise, return\n" + "@code{#f}. Filenames may have any of the optional extensions\n" + "in the @code{%load-extensions} list; @code{%search-load-path}\n" + "will try each extension automatically.") #define FUNC_NAME s_scm_sys_search_load_path { SCM path = *scm_loc_load_path; SCM exts = *scm_loc_load_extensions; - SCM_VALIDATE_ROSTRING (1,filename); + SCM_VALIDATE_STRING (1, filename); - SCM_ASSERT (scm_ilength (path) >= 0, path, "load path is not a proper list", - FUNC_NAME); - SCM_ASSERT (scm_ilength (exts) >= 0, exts, - "load extension list is not a proper list", - FUNC_NAME); + if (scm_ilength (path) < 0) + SCM_MISC_ERROR ("%load-path is not a proper list", SCM_EOL); + if (scm_ilength (exts) < 0) + SCM_MISC_ERROR ("%load-extension list is not a proper list", SCM_EOL); return scm_search_path (path, filename, exts); } #undef FUNC_NAME SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 0, 0, - (SCM filename), - "Search @var{%load-path} for @var{file} and load it into the top-level\n" - "environment. If @var{file} is a relative pathname and is not found in\n" - "the list of search paths, an error is signalled.") + (SCM filename), + "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.") #define FUNC_NAME s_scm_primitive_load_path { SCM full_filename; - SCM_VALIDATE_ROSTRING (1,filename); + SCM_VALIDATE_STRING (1, filename); full_filename = scm_sys_search_load_path (filename); - if (SCM_FALSEP (full_filename)) + if (scm_is_false (full_filename)) { - int absolute = (SCM_ROLENGTH (filename) >= 1 - && SCM_ROCHARS (filename)[0] == '/'); + int absolute = (SCM_STRING_LENGTH (filename) >= 1 +#ifdef __MINGW32__ + && (SCM_STRING_CHARS (filename)[0] == '/' || + SCM_STRING_CHARS (filename)[0] == '\\')); +#else + && SCM_STRING_CHARS (filename)[0] == '/'); +#endif SCM_MISC_ERROR ((absolute ? "Unable to load file ~S" : "Unable to find file ~S in load path"), - scm_listify (filename, SCM_UNDEFINED)); + scm_list_1 (filename)); } return scm_primitive_load (full_filename); } #undef FUNC_NAME -#if SCM_DEBUG_DEPRECATED == 0 - -/* Eval now copies source properties, so this function is no longer required. - */ - -SCM_SYMBOL (scm_end_of_file_key, "end-of-file"); - -SCM_DEFINE (scm_read_and_eval_x, "read-and-eval!", 0, 1, 0, - (SCM port), - "Read a form from @var{port} (standard input by default), and evaluate it\n" - "(memoizing it in the process) in the top-level environment. If no data\n" - "is left to be read from @var{port}, an @code{end-of-file} error is\n" - "signalled.") -#define FUNC_NAME s_scm_read_and_eval_x +SCM +scm_c_primitive_load_path (const char *filename) { - SCM form = scm_read (port); - if (SCM_EOF_OBJECT_P (form)) - scm_ithrow (scm_end_of_file_key, SCM_EOL, 1); - return scm_eval_x (form, scm_selected_module ()); + return scm_primitive_load_path (scm_makfrom0str (filename)); } -#undef FUNC_NAME - -#endif /* Information about the build environment. */ @@ -492,11 +485,11 @@ static void init_build_info () { static struct { char *name; char *value; } info[] = SCM_BUILD_INFO; - SCM *loc = SCM_CDRLOC (scm_sysintern ("%guile-build-info", SCM_EOL)); - unsigned int i; + SCM *loc = SCM_VARIABLE_LOC (scm_c_define ("%guile-build-info", SCM_EOL)); + unsigned long i; for (i = 0; i < (sizeof (info) / sizeof (info[0])); i++) - *loc = scm_acons (SCM_CAR (scm_intern0 (info[i].name)), + *loc = scm_acons (scm_str2symbol (info[i].name), scm_makfrom0str (info[i].value), *loc); } @@ -506,14 +499,13 @@ init_build_info () void scm_init_load () { - scm_listofnullstr = scm_permanent_object (SCM_LIST1 (scm_nullstr)); - scm_loc_load_path = SCM_CDRLOC (scm_sysintern ("%load-path", SCM_EOL)); + scm_listofnullstr = scm_permanent_object (scm_list_1 (scm_nullstr)); + scm_loc_load_path = SCM_VARIABLE_LOC (scm_c_define ("%load-path", SCM_EOL)); scm_loc_load_extensions - = SCM_CDRLOC (scm_sysintern ("%load-extensions", - scm_listify (scm_makfrom0str (".scm"), - scm_makfrom0str (""), - SCM_UNDEFINED))); - scm_loc_load_hook = SCM_CDRLOC (scm_sysintern ("%load-hook", SCM_BOOL_F)); + = SCM_VARIABLE_LOC (scm_c_define ("%load-extensions", + scm_list_2 (scm_makfrom0str (".scm"), + scm_nullstr))); + scm_loc_load_hook = SCM_VARIABLE_LOC (scm_c_define ("%load-hook", SCM_BOOL_F)); init_build_info ();