module/ice-9/psyntax.scm

@@ -3268,11 +3268,14 @@ searched relative to the @var{dirname} instead of the current working
 directory.  Also, @var{filename} can be a syntax object; in that case,
 and if @var{dirname} is not specified, the @code{syntax-source} of
 @var{filename} is used to obtain a base directory for relative file
-names."
+names.  As a special case, when the COMPILATION-SOURCE-FILE-NAME
+parameter is set, its value is used directly, overriding any FILENAME
+and DIRNAME argument provided."
       (let* ((filename (syntax->datum filename))
              (p (open-input-file
-                 (cond ((absolute-file-name? filename)
-                        filename)
+                 (cond ((compilation-source-file-name) => identity)
+                       ((absolute-file-name? filename)
+                           filename)
                        (dirname
                         (in-vicinity dirname filename))
                        (else

module/srfi/srfi-151.scm

@@ -51,6 +51,7 @@
           (bitwise-bit-count (bitwise-not i)))))
 
   ;; Stable part of the implementation
-  (include "srfi-151/bitwise-33.scm")
-  (include "srfi-151/bitwise-60.scm")
-  (include "srfi-151/bitwise-other.scm"))
+  ;; (include "srfi-151/bitwise-33.scm")
+  ;; (include "srfi-151/bitwise-60.scm")
+  ;; (include "srfi-151/bitwise-other.scm")
+  )

module/system/base/compile.scm

@@ -44,6 +44,10 @@
 (define default-warning-level (make-parameter 1 level-validator))
 (define default-optimization-level (make-parameter 2 level-validator))
 
+;;; This parameter is used by `include' to locate the true source when
+;;; 'relative canonicalization strips a leading part of the source file.
+(define compilation-source-file-name (make-parameter #f))
+
 ;;;
 ;;; Compiler
 ;;;
@@ -175,25 +179,26 @@
                        (canonicalization 'relative))
   (validate-options opts)
   (with-fluids ((%file-port-name-canonicalization canonicalization))
-    (let* ((comp (or output-file (compiled-file-name file)
-                     (error "failed to create path for auto-compiled file"
-                            file)))
-           (in (open-input-file file))
-           (enc (file-encoding in)))
-      ;; Choose the input encoding deterministically.
-      (set-port-encoding! in (or enc "UTF-8"))
-
-      (ensure-directory (dirname comp))
-      (call-with-output-file/atomic comp
-        (lambda (port)
-          ((language-printer (ensure-language to))
-           (read-and-compile in #:env env #:from from #:to to
-                             #:optimization-level optimization-level
-                             #:warning-level warning-level
-                             #:opts (cons* #:to-file? #t opts))
-           port))
-        file)
-      comp)))
+    (parameterize ((compilation-source-file-name file))
+      (let* ((comp (or output-file (compiled-file-name file)
+                       (error "failed to create path for auto-compiled file"
+                              file)))
+             (in (open-input-file file))
+             (enc (file-encoding in)))
+        ;; Choose the input encoding deterministically.
+        (set-port-encoding! in (or enc "UTF-8"))
+
+        (ensure-directory (dirname comp))
+        (call-with-output-file/atomic comp
+          (lambda (port)
+            ((language-printer (ensure-language to))
+             (read-and-compile in #:env env #:from from #:to to
+                               #:optimization-level optimization-level
+                               #:warning-level warning-level
+                               #:opts (cons* #:to-file? #t opts))
+             port))
+          file)
+        comp))))
 
 (define* (compile-and-load file #:key (from (current-language)) (to 'value)
                            (env (current-module))
@@ -203,11 +208,12 @@
                            (canonicalization 'relative))
   (validate-options opts)
   (with-fluids ((%file-port-name-canonicalization canonicalization))
-    (read-and-compile (open-input-file file)
-                      #:from from #:to to #:opts opts
-                      #:optimization-level optimization-level
-                      #:warning-level warning-level
-                      #:env env)))
+    (parameterize ((compilation-source-file-name file))
+      (read-and-compile (open-input-file file)
+                        #:from from #:to to #:opts opts
+                        #:optimization-level optimization-level
+                        #:warning-level warning-level
+                        #:env env))))
 
 
 ;;;