new function: canonicalize-path. use when autocompiling

* libguile/filesys.h:
* libguile/filesys.c (scm_canonicalize_path): New function,
  canonicalize-path.

* module/system/base/compile.scm (compiled-file-name): Canonicalize the
  filename so that compiling e.g. ../foo.scm doesn't compile to
  ~/.guile-ccache/1.9/../foo.scm.

diff --git a/libguile/filesys.c b/libguile/filesys.c
index b49d488..a2db699 100644 (file)
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -30,6 +30,7 @@
 #endif
 
 #include <alloca.h>
+#include <canonicalize.h>
 
 #include <stdio.h>
 #include <errno.h>
@@ -1661,6 +1662,27 @@ SCM_DEFINE (scm_basename, "basename", 1, 1, 0,
 }
 #undef FUNC_NAME
 
+SCM_DEFINE (scm_canonicalize_path, "canonicalize-path", 1, 0, 0, 
+            (SCM path),
+           "Return the canonical path of @var{path}. A canonical path has\n"
+            "no @code{.} or @code{..} components, nor any repeated path\n"
+            "separators (@code{/}) nor symlinks.\n\n"
+            "Raises an error if any component of @var{path} does not exist.")
+#define FUNC_NAME s_scm_canonicalize_path
+{ char *str, *canon;
+  
+  SCM_VALIDATE_STRING (1, path);
+
+  str = scm_to_locale_string (path);
+  canon = canonicalize_file_name (str);
+  free (str);
+  
+  if (canon)
+    return scm_take_locale_string (canon);
+  else
+    SCM_SYSERROR;
+}
+#undef FUNC_NAME
 
 
 \f

diff --git a/libguile/filesys.h b/libguile/filesys.h
index 3e5c83e..b9a6ca8 100644 (file)
--- a/libguile/filesys.h
+++ b/libguile/filesys.h
@@ -65,6 +65,7 @@ SCM_API SCM scm_lstat (SCM str);
 SCM_API SCM scm_copy_file (SCM oldfile, SCM newfile);
 SCM_API SCM scm_dirname (SCM filename);
 SCM_API SCM scm_basename (SCM filename, SCM suffix);
+SCM_API SCM scm_canonicalize_path (SCM path);
 
 SCM_INTERNAL void scm_init_filesys (void);
 

diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index 9f0ff2f..dfe8823 100644 (file)
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -131,7 +131,8 @@
           (else (car %load-compiled-extensions))))
   (and %compile-fallback-path
        (let ((f (string-append
-                 %compile-fallback-path "/" file (compiled-extension))))
+                 %compile-fallback-path "/" (canonicalize-path file)
+                 (compiled-extension))))
          (and (false-if-exception (ensure-writable-dir (dirname f)))
               f))))