~ chicken-core (chicken-5) 0867c40abc61ffa2194209ac97bcc6a9d7362058

commit 0867c40abc61ffa2194209ac97bcc6a9d7362058
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Wed Dec 4 13:00:23 2024 +0100
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Wed Dec 4 13:00:23 2024 +0100

    adapt to proper handling of ##sys#current-source-filename, which was not yet applied in c6

diff --git a/core.scm b/core.scm
index 0482cadf..0459a214 100644
--- a/core.scm
+++ b/core.scm
@@ -634,15 +634,17 @@
 		 (print "\n;; END OF FILE"))))) ) )
 
    (define (include-file x ci e dest ldest h ln tl?)
-       (##sys#include-forms-from-file
-              (cadr x) (caddr x) ci
-              (lambda (forms)
-                (walk (if (pair? (cdddr x)) ; body?
-                        (canonicalize-body/ln ln
-                                              (append forms (cadddr x))
-                                              compiler-syntax-enabled)
-                        `(##core#begin ,@forms))
-                    e dest ldest h ln tl?))))
+     (##sys#include-forms-from-file
+       (cadr x) (caddr x) ci
+       (lambda (forms path)
+         (let ((code (if (pair? (cdddr x)) ; body?
+                         (canonicalize-body/ln
+                           ln
+                           (append forms (cadddr x))
+                           compiler-syntax-enabled)
+                         `(##core#begin ,@forms))))
+           (fluid-let ((##sys#current-source-filename path))
+             (walk code e dest ldest h ln tl?))))))
 
   (define (walk x e dest ldest h outer-ln tl?)
     (cond ((keyword? x) `(quote ,x))
diff --git a/eval.scm b/eval.scm
index faf8face..64a9bbda 100644
--- a/eval.scm
+++ b/eval.scm
@@ -141,12 +141,14 @@
       (define (include-file x ci e tf cntr tl?)
         (##sys#include-forms-from-file
           (cadr x) (caddr x) ci
-	  (lambda (forms)
-            (compile (if (pair? (cdddr x)) ; body?
-                         (##sys#canonicalize-body (append forms (cadddr x))
-                                                  (##sys#current-environment))
-                         `(##core#begin ,@forms))
-                     e #f tf cntr tl?))))
+	  (lambda (forms path)
+            (let ((code (if (pair? (cdddr x)) ; body?
+                            (##sys#canonicalize-body
+                              (append forms (cadddr x))
+                              (##sys#current-environment))
+                            `(##core#begin ,@forms))))
+	      (fluid-let ((##sys#current-source-filename path))
+                (compile code e #f tf cntr tl?))))))
 
       (define (compile x e h tf cntr tl?)
 	(cond ((keyword? x) (lambda v x))
@@ -1195,12 +1197,15 @@
 	  (print "; including " path " ..."))
 	(call-with-input-file path
 	  (lambda (in)
-            (##sys#setislot in 13 (not ci))
-	    (fluid-let ((##sys#current-source-filename path))
-               (do ((x (read-with-source-info in) (read-with-source-info in))
-                    (xs '() (cons x xs)))
-                   ((eof-object? x)
-                    (k (reverse xs)))))))))))
+	    (let ((oldci (##sys#slot in 13)))
+  	     (k (fluid-let ((##sys#current-source-filename path))
+                 (##sys#setislot in 13 (not ci))
+                 (do ((x (read-with-source-info in) (read-with-source-info in))
+                      (xs '() (cons x xs)))
+                     ((eof-object? x)
+                      (##sys#setislot in 13 oldci)
+                      (reverse xs))))
+                path))))))))
 
 
 ;;; Extensions:
diff --git a/expand.scm b/expand.scm
index 2f3521e6..bb16f724 100644
--- a/expand.scm
+++ b/expand.scm
@@ -1283,7 +1283,7 @@
            (##sys#include-forms-from-file
                filename
                ##sys#current-source-filename ci?
-               (lambda (forms) (map expand/begin forms)))))
+               (lambda (forms path) (map expand/begin forms)))))
        (define (process-include-decls fnames)
 	 (parse-decls (append-map (lambda (fname) (read-forms fname #t)) fnames)))
        (define (fail spec)