~ chicken-core (chicken-5) 7796f12a385be5fbbfdca5c6aa632d3ad7037e9b
commit 7796f12a385be5fbbfdca5c6aa632d3ad7037e9b
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Tue Aug 9 23:55:39 2016 +1200
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Tue Aug 9 19:35:05 2016 +0200
Add `include-relative` form to "chicken" module
Adds a new include form that searches for files relative to the
including file rather than the CWD. In all other ways it behaves like
the normal `include`.
Because `load-relative` and `include-relative` are so similar, this
change also moves some pathname handling code into a group of shared
procedures in eval.scm and uses them for both.
Also slightly simplifies the filename handling code in `load` and fixes
a segfault in the following program caused by the use of
`##sys#current-load-path` as a string when it's false:
(load (open-input-string "(load-relative \"foo.scm\")"))
Signed-off-by: Peter Bex <peter@more-magic.net>
diff --git a/NEWS b/NEWS
index d4eb49dc..27e6be58 100644
--- a/NEWS
+++ b/NEWS
@@ -38,6 +38,8 @@
a single bidirectional port.
- New `input-port-open?` and `output-port-open?` procedures have been
added for testing whether a port is open in a specific direction.
+ - An `include-relative` form has been added to the chicken module.
+ This works like `load-relative` but for textual inclusion.
- Module system
- The compiler has been modularised, for improved namespacing. This
diff --git a/batch-driver.scm b/batch-driver.scm
index 3848f3be..e33e38c5 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -437,7 +437,10 @@
(let ([extends (collect-options 'extend)])
(dribble "Loading compiler extensions...")
(for-each
- (lambda (f) (load (##sys#resolve-include-filename f #f #t)))
+ (lambda (e)
+ (let ((f (##sys#resolve-include-filename e #f #t #f)))
+ (when (not f) (quit-compiling "cannot load extension: ~a" e))
+ (load f)))
extends) )
(set! ##sys#features (delete #:compiler-extension ##sys#features))
(set! ##sys#features (cons '#:compiling ##sys#features))
@@ -561,7 +564,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,8 +652,7 @@
(for-each
(lambda (id)
(and-let* ((ifile (##sys#resolve-include-filename
- (symbol->string id) '(".inline") #t))
- ((file-exists? ifile)))
+ (symbol->string id) '(".inline") #t #f)))
(dribble "Loading inline file ~a ..." ifile)
(load-inline-file ifile)))
mreq))
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index b30e8205..1ec885ce 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -169,7 +169,14 @@
(##sys#er-transformer
(lambda (form r c)
(##sys#check-syntax 'include form '(_ string))
- `(##core#include ,(cadr form)))))
+ `(##core#include ,(cadr form) #f))))
+
+(##sys#extend-macro-environment
+ 'include-relative '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'include-relative form '(_ string))
+ `(##core#include ,(cadr form) ,##sys#current-source-filename))))
(##sys#extend-macro-environment
'assert '()
diff --git a/core.scm b/core.scm
index 806d7cff..6ba31078 100644
--- a/core.scm
+++ b/core.scm
@@ -111,7 +111,7 @@
; (##core#lambda ({<variable>}+ [. <variable>]) <body>)
; (##core#set! <variable> <exp>)
; (##core#begin <exp> ...)
-; (##core#include <string>)
+; (##core#include <string> <string> | #f)
; (##core#loop-lambda <llist> <body>)
; (##core#undefined)
; (##core#primitive <name>)
@@ -902,11 +902,12 @@
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)
+ (caddr 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 d12dba23..ea59f069 100644
--- a/csc.scm
+++ b/csc.scm
@@ -314,8 +314,8 @@
(define (find-object-files name)
(define (locate-object-file filename repo)
- (let ((f (##sys#resolve-include-filename filename '() repo)))
- (and (file-exists? f) (list f))))
+ (and-let* ((f (##sys#resolve-include-filename filename '() repo #f)))
+ (list f)))
(define (static-extension-information name)
(and-let* ((info (extension-information name))
diff --git a/eval.scm b/eval.scm
index fba6d5da..7ee369a3 100644
--- a/eval.scm
+++ b/eval.scm
@@ -626,10 +626,11 @@
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)
+ (caddr x)
+ (lambda (forms)
+ (compile `(##core#begin ,@forms) e #f tf cntr se))))
((##core#let-module-alias)
(##sys#with-module-aliases
@@ -919,12 +920,30 @@
(fx+ argc 1) ) ] ) ) ) ) )
+;;; Pathname helpers:
+
+(define path-separators
+ (if ##sys#windows-platform '(#\\ #\/) '(#\/)))
+
+(define (path-separator-index/right s)
+ (let loop ((i (fx- (##sys#size s) 1)))
+ (if (memq (##core#inline "C_subchar" s i) path-separators)
+ i
+ (and (fx< 0 i) (loop (fx- i 1))))))
+
+(define (make-relative-pathname from file)
+ (let ((i (and (string? from)
+ (positive? (##sys#size file)) ; XXX probably an error?
+ (not (memq (##core#inline "C_subchar" file 0) path-separators))
+ (path-separator-index/right from))))
+ (if (not i) file (string-append (##sys#substring from 0 i) "/" file))))
+
+
;;; 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-filename #f)
(define ##sys#dload-disabled #f)
(define-foreign-variable _dlerror c-string "C_dlerror")
@@ -967,17 +986,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 (path-separator-index/right path)
path
(##sys#string-append "./" path)))
@@ -996,17 +1008,12 @@
((not (string? input))
(##sys#signal-hook #:type-error 'load "bad argument type - not a port or string" input))
((##sys#file-exists? input #t #f 'load) input)
+ ((let ((f (##sys#string-append input ##sys#load-dynamic-extension)))
+ (and dload? (##sys#file-exists? f #t #f 'load) f)))
+ ((let ((f (##sys#string-append input source-file-extension)))
+ (and (##sys#file-exists? f #t #f 'load) f)))
(else
- (let ((fname2 (##sys#string-append input ##sys#load-dynamic-extension)))
- (if (and dload? (##sys#file-exists? fname2 #t #f 'load))
- fname2
- (let ((fname3 (##sys#string-append input source-file-extension)))
- (if (##sys#file-exists? fname3 #t #f 'load)
- fname3
- input)))))))
-
- (when (and (string? input) (not fname))
- (##sys#signal-hook #:file-error 'load "cannot open file" input))
+ (##sys#signal-hook #:file-error 'load "cannot open file" input))))
(when (and (load-verbose) fname)
(display "; loading ")
@@ -1018,11 +1025,8 @@
(call-with-current-continuation
(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-filename fname)
+ (##sys#current-source-filename fname))
(let ((in (if fname (open-input-file fname) input)))
(##sys#dynamic-wind
(lambda () #f)
@@ -1060,9 +1064,7 @@
(define (load-relative filename . evaluator)
(load/internal
- (if (memq (string-ref filename 0) '(#\\ #\/))
- filename
- (##sys#string-append ##sys#current-load-path filename))
+ (make-relative-pathname ##sys#current-load-filename filename)
(optional evaluator #f)))
(define (load-noisily filename #!key (evaluator #f) (time #f) (printer #f))
@@ -1128,16 +1130,19 @@
(let ((with-input-from-file with-input-from-file)
(read read)
(reverse reverse))
- (lambda (fname)
- (let ((path (##sys#resolve-include-filename fname #t #f)))
- (when (load-verbose) (print "; including " path " ..."))
+ (lambda (filename source k)
+ (let ((path (##sys#resolve-include-filename filename #t #f source)))
+ (when (not path)
+ (##sys#signal-hook #:file-error 'include "cannot open file" filename))
+ (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 source)
(define (test-extensions fname lst)
(if (null? lst)
(and (exists? fname) fname)
@@ -1408,7 +1413,7 @@
(list ##sys#load-dynamic-extension source-file-extension))
(else ; prefer source
(list source-file-extension ##sys#load-dynamic-extension)))))
- (or (test fname)
+ (or (test (make-relative-pathname source fname))
(let loop ((paths (if repo
(##sys#append
##sys#include-pathnames
@@ -1417,7 +1422,7 @@
(list (##sys#repository-path))
'())))
##sys#include-pathnames) ) )
- (cond ((eq? paths '()) fname)
+ (cond ((eq? paths '()) #f)
((test (string-append (##sys#slot paths 0)
"/"
fname) ) )
diff --git a/expand.scm b/expand.scm
index d96477da..29ef3fa6 100644
--- a/expand.scm
+++ b/expand.scm
@@ -74,6 +74,9 @@
(define-inline (putp sym prop val)
(##core#inline_allocate ("C_a_i_putprop" 8) sym prop val))
+;;; Source file tracking
+
+(define ##sys#current-source-filename #f)
;;; Syntactic environments
@@ -1521,7 +1524,7 @@
(if (and (pair? body)
(null? (cdr body))
(string? (car body)))
- `((##core#include ,(car body)))
+ `((##core#include ,(car body) ,##sys#current-source-filename))
body))))))))))
(##sys#extend-macro-environment
diff --git a/manual/Non-standard macros and special forms b/manual/Non-standard macros and special forms
index 3f45734d..78a56f5a 100644
--- a/manual/Non-standard macros and special forms
+++ b/manual/Non-standard macros and special forms
@@ -612,9 +612,16 @@ 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 and all directories specified by the {{-include-path}}
+option.
+
+==== include-relative
+
+<macro>(include-relative STRING)</macro>
+
+Works like {{include}}, but the filename is searched for relative to the
+including file rather than the current directory.
==== nth-value
diff --git a/tests/runtests.bat b/tests/runtests.bat
index 07ec3b6d..8e488d0d 100644
--- a/tests/runtests.bat
+++ b/tests/runtests.bat
@@ -511,6 +511,26 @@ if errorlevel 1 exit /b 1
echo ======================================== syntax-rules stress test ...
%interpret% -bnq syntax-rule-stress-test.scm
+echo "======================================== include test ..."
+mkdir a\b
+echo > a\b\ok.scm
+echo '(include "a/b/ok.scm")' > a\b\include.scm
+%compile% -analyze-only a\b\include.scm
+if errorlevel 1 exit /b 1
+echo '(include "b/ok.scm")' > a\b\include.scm
+%compile% -analyze-only a\b\include.scm -include-path a
+if errorlevel 1 exit /b 1
+echo '(include-relative "ok.scm")' > a\b\include.scm
+%compile% -analyze-only a\b\include.scm
+if errorlevel 1 exit /b 1
+echo '(include-relative "b/ok.scm")' > a\include.scm
+%compile% -analyze-only a\include.scm
+if errorlevel 1 exit /b 1
+echo '(include-relative "b/ok.scm")' > a\b\include.scm
+%compile% -analyze-only a\b\include.scm -include-path a
+if errorlevel 1 exit /b 1
+del /f /s /q a
+
echo "======================================== executable tests ..."
%compile% executable-tests.scm
if errorlevel 1 exit /b 1
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 72cb56e8..279f70f3 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -435,6 +435,21 @@ $compile locative-stress-test.scm
echo "======================================== syntax-rules stress test ..."
time $interpret -bnq syntax-rule-stress-test.scm
+echo "======================================== include test ..."
+mkdir -p a/b
+echo > a/b/ok.scm
+echo '(include "a/b/ok.scm")' > a/b/include.scm
+$compile -analyze-only a/b/include.scm
+echo '(include "b/ok.scm")' > a/b/include.scm
+$compile -analyze-only a/b/include.scm -include-path a
+echo '(include-relative "ok.scm")' > a/b/include.scm
+$compile -analyze-only a/b/include.scm
+echo '(include-relative "b/ok.scm")' > a/include.scm
+$compile -analyze-only a/include.scm
+echo '(include-relative "b/ok.scm")' > a/b/include.scm
+$compile -analyze-only a/b/include.scm -include-path a
+rm -r a
+
echo "======================================== executable tests ..."
$compile executable-tests.scm
./a.out "$TEST_DIR/a.out"
Trap