summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/load.c20
-rw-r--r--module/ice-9/boot-9.scm14
-rw-r--r--module/system/base/compile.scm14
3 files changed, 41 insertions, 7 deletions
diff --git a/libguile/load.c b/libguile/load.c
index 3b6ba2b38..91309bb1e 100644
--- a/libguile/load.c
+++ b/libguile/load.c
@@ -793,6 +793,22 @@ scm_try_auto_compile (SCM source)
NULL, NULL);
}
+/* See also (system base compile):compiled-file-name. */
+static SCM
+canonical_to_suffix (SCM canon)
+{
+ size_t 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;
+}
+
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"
@@ -857,7 +873,7 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
{
SCM fallback = scm_string_append
(scm_list_3 (*scm_loc_compile_fallback_path,
- full_filename,
+ canonical_to_suffix (full_filename),
scm_car (*scm_loc_load_compiled_extensions)));
if (scm_is_true (scm_stat (fallback, SCM_BOOL_F)))
{
@@ -895,7 +911,7 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1,
{
SCM fallback = scm_string_append
(scm_list_3 (*scm_loc_compile_fallback_path,
- full_filename,
+ canonical_to_suffix (full_filename),
scm_car (*scm_loc_load_compiled_extensions)));
if (scm_is_true (scm_stat (fallback, SCM_BOOL_F))
&& compiled_is_fresh (full_filename, fallback))
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 24f63f592..1ddb0ff07 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -3450,6 +3450,15 @@ module '(ice-9 q) '(make-q q-length))}."
'(#:warnings (unbound-variable arity-mismatch format)))
(define* (load-in-vicinity dir path #:optional reader)
+ (define (canonical->suffix canon)
+ (cond
+ ((string-prefix? "/" canon) canon)
+ ((and (> (string-length canon) 2)
+ (eqv? (string-ref canon 1) #\:))
+ ;; Paths like C:... transform to /C...
+ (string-append "/" (substring canon 0 1) (substring canon 2)))
+ (else canon)))
+
;; Returns the .go file corresponding to `name'. Does not search load
;; paths, only the fallback path. If the .go file is missing or out of
;; date, and auto-compilation is enabled, will try auto-compilation, just
@@ -3461,11 +3470,12 @@ module '(ice-9 q) '(make-q q-length))}."
;; partially duplicates functionality from (system base compile).
;;
(define (compiled-file-name canon-path)
+ ;; FIXME: would probably be better just to append SHA1(canon-path)
+ ;; to the %compile-fallback-path, to avoid deep directory stats.
(and %compile-fallback-path
(string-append
%compile-fallback-path
- ;; no need for '/' separator here, canon-path is absolute
- canon-path
+ (canonical->suffix canon-path)
(cond ((or (null? %load-compiled-extensions)
(string-null? (car %load-compiled-extensions)))
(warn "invalid %load-compiled-extensions"
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index 1b6e73f32..943999040 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -103,6 +103,16 @@
;;;
;;; See also boot-9.scm:load.
(define (compiled-file-name file)
+ ;; FIXME: would probably be better just to append SHA1(canon-path)
+ ;; to the %compile-fallback-path, to avoid deep directory stats.
+ (define (canonical->suffix canon)
+ (cond
+ ((string-prefix? "/" canon) canon)
+ ((and (> (string-length canon) 2)
+ (eqv? (string-ref canon 1) #\:))
+ ;; Paths like C:... transform to /C...
+ (string-append "/" (substring canon 0 1) (substring canon 2)))
+ (else canon)))
(define (compiled-extension)
(cond ((or (null? %load-compiled-extensions)
(string-null? (car %load-compiled-extensions)))
@@ -113,9 +123,7 @@
(and %compile-fallback-path
(let ((f (string-append
%compile-fallback-path
- ;; no need for '/' separator here, canonicalize-path
- ;; will give us an absolute path
- (canonicalize-path file)
+ (canonical->suffix (canonicalize-path file))
(compiled-extension))))
(and (false-if-exception (ensure-writable-dir (dirname f)))
f))))