Non-vector 1D arrays print as #1()
[bpt/guile.git] / libguile / load.c
index f2af6c8..74f3bb4 100644 (file)
@@ -1,5 +1,5 @@
 /* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2004, 2006, 2008,
- *   2009, 2010, 2011, 2012, 2013 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
@@ -28,7 +28,6 @@
 #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>
@@ -89,7 +85,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 +97,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 +189,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 */
+
 
 \f
 /* Initializing the load path, and searching it.  */
@@ -272,6 +276,41 @@ SCM_DEFINE (scm_parse_path_with_ellipsis, "parse-path-with-ellipsis", 2, 0, 0,
 }
 #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
@@ -284,7 +323,7 @@ scm_init_load_path ()
   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 '("") */
@@ -297,7 +336,7 @@ scm_init_load_path ()
                        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 */
     ; 
@@ -340,14 +379,17 @@ scm_init_load_path ()
       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_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_with_ellipsis (scm_from_locale_string (env), cpath);
 
@@ -360,24 +402,24 @@ SCM scm_listofnullstr;
 /* 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;
 }
 
@@ -427,39 +469,37 @@ stringbuf_cat (struct stringbuf *buf, char *str)
     }
 }
 
-  
+/* 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;
 }
 
-#ifdef __MINGW32__
-#define FILE_NAME_SEPARATOR_STRING "\\"
-#else
+/* 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 "/"
-#endif
 
 static int
 is_file_name_separator (SCM c)
 {
-  if (c == SCM_MAKE_CHAR ('/'))
+  if (scm_is_eq (c, SCM_MAKE_CHAR ('/')))
     return 1;
 #ifdef __MINGW32__
-  if (c == SCM_MAKE_CHAR ('\\'))
+  if (scm_is_eq (c, SCM_MAKE_CHAR ('\\')))
     return 1;
 #endif
   return 0;
@@ -478,23 +518,25 @@ is_drive_letter (SCM c)
 }
 
 static int
-is_absolute_file_name (const char *filename_chars, size_t filename_len)
+is_absolute_file_name (SCM filename)
 {
+  size_t filename_len = scm_c_string_length (filename);
+
   if (filename_len >= 1
-      && is_file_name_separator (SCM_MAKE_CHAR (filename_chars[0]))
+      && 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_MAKE_CHAR (filename_chars[1]))
+      && is_file_name_separator (scm_c_string_ref (filename, 1))
 #endif
       )
     return 1;
   if (filename_len >= 3
-      && is_drive_letter (SCM_MAKE_CHAR (filename_chars[0]))
-      && filename_chars[1] == ':'
-      && is_file_name_separator (SCM_MAKE_CHAR (filename_chars[2])))
+      && 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;
 }
@@ -514,6 +556,7 @@ search_path (SCM path, SCM filename, SCM extensions, SCM require_exts,
   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",
@@ -529,11 +572,10 @@ 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.  */
-  if (is_absolute_file_name (filename_chars, filename_len))
+  if (is_absolute_file_name (filename))
     {
       if ((scm_is_false (require_exts) ||
-           scm_c_string_has_an_ext (filename_chars, filename_len,
-                                    extensions))
+           string_has_an_ext (filename, extensions))
           && stat (filename_chars, stat_buf) == 0
           && !(stat_buf->st_mode & S_IFDIR))
         result = filename;
@@ -551,8 +593,7 @@ search_path (SCM path, SCM filename, SCM extensions, SCM require_exts,
        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... */
@@ -575,9 +616,8 @@ search_path (SCM path, SCM filename, SCM extensions, SCM require_exts,
   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.
    */
@@ -613,7 +653,8 @@ search_path (SCM path, SCM filename, SCM extensions, SCM require_exts,
          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;
            }
        }
@@ -732,11 +773,11 @@ compiled_is_fresh (SCM full_filename, SCM compiled_filename,
   else
     {
       compiled_is_newer = 0;
-      scm_puts (";;; note: source file ", scm_current_error_port ());
+      scm_puts_unlocked (";;; note: source file ", scm_current_error_port ());
       scm_display (full_filename, scm_current_error_port ());
-      scm_puts ("\n;;;       newer than compiled ", scm_current_error_port ());
+      scm_puts_unlocked ("\n;;;       newer than compiled ", scm_current_error_port ());
       scm_display (compiled_filename, scm_current_error_port ());
-      scm_puts ("\n", scm_current_error_port ());
+      scm_puts_unlocked ("\n", scm_current_error_port ());
     }
 
   return compiled_is_newer;
@@ -751,10 +792,10 @@ SCM_SYMBOL (sym_auto_compilation_options, "%auto-compilation-options");
 static SCM
 do_try_auto_compile (void *data)
 {
-  SCM source = PTR2SCM (data);
+  SCM source = SCM_PACK_POINTER (data);
   SCM comp_mod, compile_file;
 
-  scm_puts (";;; compiling ", scm_current_error_port ());
+  scm_puts_unlocked (";;; compiling ", scm_current_error_port ());
   scm_display (source, scm_current_error_port ());
   scm_newline (scm_current_error_port ());
 
@@ -783,16 +824,16 @@ do_try_auto_compile (void *data)
       /* Assume `*current-warning-prefix*' has an appropriate value.  */
       res = scm_call_n (scm_variable_ref (compile_file), args, 5);
 
-      scm_puts (";;; compiled ", scm_current_error_port ());
+      scm_puts_unlocked (";;; compiled ", scm_current_error_port ());
       scm_display (res, scm_current_error_port ());
       scm_newline (scm_current_error_port ());
       return res;
     }
   else
     {
-      scm_puts (";;; it seems ", scm_current_error_port ());
+      scm_puts_unlocked (";;; it seems ", scm_current_error_port ());
       scm_display (source, scm_current_error_port ());
-      scm_puts ("\n;;; is part of the compiler; skipping auto-compilation\n",
+      scm_puts_unlocked ("\n;;; is part of the compiler; skipping auto-compilation\n",
                 scm_current_error_port ());
       return SCM_BOOL_F;
     }
@@ -801,22 +842,22 @@ do_try_auto_compile (void *data)
 static SCM
 auto_compile_catch_handler (void *data, SCM tag, SCM throw_args)
 {
-  SCM source = PTR2SCM (data);
+  SCM source = SCM_PACK_POINTER (data);
   SCM oport, lines;
 
   oport = scm_open_output_string ();
   scm_print_exception (oport, SCM_BOOL_F, tag, throw_args);
 
-  scm_puts (";;; WARNING: compilation of ", scm_current_warning_port ());
+  scm_puts_unlocked (";;; WARNING: compilation of ", scm_current_warning_port ());
   scm_display (source, scm_current_warning_port ());
-  scm_puts (" failed:\n", scm_current_warning_port ());
+  scm_puts_unlocked (" failed:\n", scm_current_warning_port ());
 
   lines = scm_string_split (scm_get_output_string (oport),
                             SCM_MAKE_CHAR ('\n'));
   for (; scm_is_pair (lines); lines = scm_cdr (lines))
     if (scm_c_string_length (scm_car (lines)))
       {
-        scm_puts (";;; ", scm_current_warning_port ());
+        scm_puts_unlocked (";;; ", scm_current_warning_port ());
         scm_display (scm_car (lines), scm_current_warning_port ());
         scm_newline (scm_current_warning_port ());
       }
@@ -834,7 +875,7 @@ SCM_DEFINE (scm_sys_warn_auto_compilation_enabled, "%warn-auto-compilation-enabl
 
   if (!message_shown)
     {
-      scm_puts (";;; note: auto-compilation is enabled, set GUILE_AUTO_COMPILE=0\n"
+      scm_puts_unlocked (";;; note: auto-compilation is enabled, set GUILE_AUTO_COMPILE=0\n"
                 ";;;       or pass the --no-auto-compile argument to disable.\n",
                 scm_current_warning_port ());
       message_shown = 1;
@@ -853,9 +894,9 @@ scm_try_auto_compile (SCM source)
   scm_sys_warn_auto_compilation_enabled ();
   return scm_c_catch (SCM_BOOL_T,
                       do_try_auto_compile,
-                      SCM2PTR (source),
+                      SCM_UNPACK_POINTER (source),
                       auto_compile_catch_handler,
-                      SCM2PTR (source),
+                      SCM_UNPACK_POINTER (source),
                       NULL, NULL);
 }
 
@@ -870,7 +911,7 @@ canonical_suffix (SCM fname)
 
   /* CANON should be absolute.  */
   canon = scm_canonicalize_path (fname);
-  
+
 #ifdef __MINGW32__
   {
     size_t len = scm_c_string_length (canon);
@@ -1018,7 +1059,7 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
       if (stat_ret == 0 && compiled_is_fresh (full_filename, fallback,
                                               &stat_source, &stat_compiled))
         {
-          scm_puts (";;; found fresh local cache at ", scm_current_warning_port ());
+          scm_puts_unlocked (";;; found fresh local cache at ", scm_current_warning_port ());
           scm_display (fallback, scm_current_warning_port ());
           scm_newline (scm_current_warning_port ());
           return scm_load_compiled_with_vm (fallback);
@@ -1083,7 +1124,7 @@ init_build_info ()
 
   for (i = 0; i < (sizeof (info) / sizeof (info[0])); i++)
     {
-      SCM key = scm_from_locale_symbol (info[i].name);
+      SCM key = scm_from_utf8_symbol (info[i].name);
       SCM val = scm_from_locale_string (info[i].value);
       *loc = scm_acons (key, val, *loc);
     }