[Chicken-hackers] [PATCH] Include files relative to the current source file

[Evan Hanson]

Adds the directory of the current source file to the list of pathnames
searched by "(include ...)". This is given the lowest search priority,
below CHICKEN_HOME and any directories specified by "-include-path".

Also fixes a segfault in the following program caused by the use of
`##sys#current-load-path` as a string when it's actually false:

  (load (open-input-string "(load-relative \"foo.scm\")"))
---
 batch-driver.scm                             |  8 ++--
 core.scm                                     | 10 ++---
 csc.scm                                      |  2 +-
 eval.scm                                     | 67 +++++++++++++++-------------
 manual/Non-standard macros and special forms |  6 +--
 5 files changed, 49 insertions(+), 44 deletions(-)

diff --git a/batch-driver.scm b/batch-driver.scm
index 3848f3b..cc9f499 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -437,7 +437,7 @@
     (let ([extends (collect-options 'extend)])
       (dribble "Loading compiler extensions...")
       (for-each
-       (lambda (f) (load (##sys#resolve-include-filename f #f #t))) 
+       (lambda (f) (load (##sys#resolve-include-filename f #f #t #f)))
        extends) )
     (set! ##sys#features (delete #:compiler-extension ##sys#features))
     (set! ##sys#features (cons '#:compiling ##sys#features))
@@ -561,7 +561,9 @@
           (print-expr "source" '|1| forms)
           (begin-time)
           ;; Canonicalize s-expressions
-          (let* ((exps0 (map canonicalize-expression
+          (let* ((exps0 (map (lambda (x)
+                               (fluid-let ((##sys#current-source-filename 
filename))
+                                 (canonicalize-expression x)))
                              (let ((forms (append initforms forms)))
                                (if (not module-name)
                                    forms
@@ -647,7 +649,7 @@
                   (for-each
                    (lambda (id)
                      (and-let* ((ifile (##sys#resolve-include-filename
-                                        (symbol->string id) '(".inline") #t))
+                                        (symbol->string id) '(".inline") #t 
#f))
                                 ((file-exists? ifile)))
                        (dribble "Loading inline file ~a ..." ifile)
                        (load-inline-file ifile)))
diff --git a/core.scm b/core.scm
index 9766c11..ff3b914 100644
--- a/core.scm
+++ b/core.scm
@@ -904,11 +904,11 @@
                                 bs) ) ) ) )
 
                       ((##core#include)
-                       (walk
-                        `(##core#begin
-                          ,@(fluid-let ((##sys#default-read-info-hook 
read-info-hook))
-                              (##sys#include-forms-from-file (cadr x))))
-                        e se dest ldest h ln))
+                       (fluid-let ((##sys#default-read-info-hook 
read-info-hook))
+                         (##sys#include-forms-from-file
+                          (cadr x)
+                          (lambda (forms)
+                            (walk `(##core#begin ,@forms) e se dest ldest h 
ln)))))
 
                       ((##core#let-module-alias)
                        (##sys#with-module-aliases
diff --git a/csc.scm b/csc.scm
index d12dba2..ec68078 100644
--- a/csc.scm
+++ b/csc.scm
@@ -314,7 +314,7 @@
 (define (find-object-files name)
 
   (define (locate-object-file filename repo)
-    (let ((f (##sys#resolve-include-filename filename '() repo)))
+    (let ((f (##sys#resolve-include-filename filename '() repo #f)))
       (and (file-exists? f) (list f))))
 
   (define (static-extension-information name)
diff --git a/eval.scm b/eval.scm
index fba6d5d..3f8d8b2 100644
--- a/eval.scm
+++ b/eval.scm
@@ -626,10 +626,10 @@
                           e #f tf cntr se))
 
                         ((##core#include)
-                         (compile
-                          `(##core#begin
-                            ,@(##sys#include-forms-from-file (cadr x)))
-                          e #f tf cntr se))
+                         (##sys#include-forms-from-file
+                          (cadr x)
+                          (lambda (forms)
+                            (compile `(##core#begin ,@forms) e #f tf cntr 
se))))
 
                         ((##core#let-module-alias)
                          (##sys#with-module-aliases
@@ -919,12 +919,27 @@
                          (fx+ argc 1) ) ] ) ) ) ) )
 
 
+;;; Pathname helpers:
+
+(define-inline (dirname p)
+  (let ((i (and (string? p) (slash-index/right p))))
+    (if (not i) "." (##sys#substring p 0 i))))
+
+(define slash-index/right
+  (let ((slashes (if ##sys#windows-platform '(#\\ #\/) '(#\/))))
+    (lambda (s)
+      (let loop ((i (fx- (##sys#size s) 1)))
+       (if (memq (##core#inline "C_subchar" s i) slashes)
+           i
+           (and (fx< 0 i) (loop (fx- i 1))))))))
+
+
 ;;; Loading source/object files:
 
 (define load-verbose (make-parameter (##sys#fudge 13)))
 
 (define ##sys#current-source-filename #f)
-(define ##sys#current-load-path "")
+(define ##sys#current-load-path ".")
 (define ##sys#dload-disabled #f)
 
 (define-foreign-variable _dlerror c-string "C_dlerror")
@@ -967,17 +982,10 @@
       (define evalproc
        (or evaluator eval))
 
-      (define (has-slash? str)
-       (let loop ((i (fx- (##sys#size str) 1)))
-         (if (memq (##core#inline "C_subchar" str i) '(#\\ #\/))
-             i
-             (and (fx< 0 i)
-                  (loop (fx- i 1))))))
-
       ;; dload doesn't consider filenames without slashes to be paths,
       ;; so we prepend a dot to force a relative pathname.
       (define (dload-path path)
-       (if (has-slash? path)
+       (if (slash-index/right path)
            path
            (##sys#string-append "./" path)))
 
@@ -1019,10 +1027,7 @@
           (lambda (abrt)
             (fluid-let ((##sys#read-error-with-line-number #t)
                         (##sys#current-source-filename fname)
-                        (##sys#current-load-path
-                         (and fname
-                              (let ((i (has-slash? fname)))
-                                (if i (##sys#substring fname 0 (fx+ i 1)) 
"")))))
+                        (##sys#current-load-path (dirname fname)))
               (let ((in (if fname (open-input-file fname) input)))
                 (##sys#dynamic-wind
                  (lambda () #f)
@@ -1062,7 +1067,7 @@
   (load/internal
    (if (memq (string-ref filename 0) '(#\\ #\/))
        filename
-       (##sys#string-append ##sys#current-load-path filename))
+       (string-append ##sys#current-load-path "/" filename))
    (optional evaluator #f)))
 
 (define (load-noisily filename #!key (evaluator #f) (time #f) (printer #f))
@@ -1128,16 +1133,16 @@
   (let ((with-input-from-file with-input-from-file)
        (read read)
        (reverse reverse))
-    (lambda (fname)
-      (let ((path (##sys#resolve-include-filename fname #t #f)))
+    (lambda (fname k)
+      (let ((path (##sys#resolve-include-filename fname #t #f #t)))
        (when (load-verbose) (print "; including " path " ..."))
        (with-input-from-file path
          (lambda ()
            (fluid-let ((##sys#current-source-filename path))
              (do ((x (read) (read))
-                  (xs '() (cons x xs)) )
-                 ((eof-object? x) 
-                  (reverse xs))) ) ) ) ) ) ) )
+                  (xs '() (cons x xs)))
+                 ((eof-object? x)
+                  (k (reverse xs)))))))))))
 
 
 ;;; Extensions:
@@ -1390,7 +1395,7 @@
   (let ((string-append string-append) )
     (define (exists? fname)
       (##sys#file-exists? fname #t #f #f))
-    (lambda (fname exts repo)
+    (lambda (fname exts repo relative)
       (define (test-extensions fname lst)
        (if (null? lst)
            (and (exists? fname) fname)
@@ -1409,14 +1414,12 @@
               (else                   ; prefer source
                (list source-file-extension ##sys#load-dynamic-extension)))))
       (or (test fname)
-         (let loop ((paths (if repo
-                               (##sys#append 
-                                ##sys#include-pathnames 
-                                (let ((rp (##sys#repository-path)))
-                                  (if rp
-                                      (list (##sys#repository-path))
-                                      '())))
-                               ##sys#include-pathnames) ) )
+         (let loop ((paths (##sys#append
+                            ##sys#include-pathnames
+                            (let ((dp (dirname ##sys#current-source-filename)))
+                              (if (and relative dp) (list dp) '()))
+                            (let ((rp (##sys#repository-path)))
+                              (if (and repo rp) (list rp) '())))))
            (cond ((eq? paths '()) fname)
                  ((test (string-append (##sys#slot paths 0)
                                        "/"
diff --git a/manual/Non-standard macros and special forms b/manual/Non-standard 
macros and special forms
index 3f45734..a583ab9 100644
--- a/manual/Non-standard macros and special forms      
+++ b/manual/Non-standard macros and special forms      
@@ -612,9 +612,9 @@ The following table should make this clearer:
 
 Include toplevel-expressions from the given source file in the currently
 compiled/interpreted program.  If the included file has the extension
-{{.scm}}, then it may be omitted.  The file is searched in the
-current directory and, if not found, in all directories specified in the
-{{-include-path}} option.
+{{.scm}}, then it may be omitted. The file is searched for in the
+current directory, all directories specified by the {{-include-path}}
+option, and relatively to the including file, in that order.
 
 ==== nth-value
 
-- 
2.8.1