~ chicken-core (chicken-5) b856a6e79f5ae221e507e5780c9c36570ae72c72
commit b856a6e79f5ae221e507e5780c9c36570ae72c72
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Sat Jul 15 14:12:15 2017 +1200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Sun Jul 23 12:24:27 2017 +0200
Fix repository searching for "-link" flag and associated tests
The part of the linking tests that was supposed to make sure the "-link"
flag picks up object files from the repository was broken, since the
reverser.o file that should have been *moved* into the test repository
was *copied* there instead. This meant that a reverser.o was left in the
current directory, and the test picked up that one rather than the one
from the repo.
Fixing this uncovered the fact that the behaviour it was meant to test
was broken, too, so this patch also fixes that by updating the
`find-object-file` procedure in csc.scm to use the same lookup logic
that `##sys#process-require` uses for static extensions. It also factors
some duplicated logic for finding files in the repository out into a new
`find-file` helper in the load module, standardises the naming of the
two procedures used to look up files for extensions, and uses internal
namespacing to share these procedures between files.
Also, use "rmdir" to make sure the test repository is always deleted
before running the test suite on Windows.
Signed-off-by: felix <felix@call-with-current-continuation.org>
diff --git a/batch-driver.scm b/batch-driver.scm
index 45bea523..66f5c803 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -601,7 +601,7 @@
import-libraries) ", ")))
(and-let* ((reqs (hash-table-ref file-requirements 'dynamic))
- (missing (remove (cut ##sys#find-extension <> #f) reqs)))
+ (missing (remove (cut chicken.load#find-dynamic-extension <> #f) reqs)))
(when (null? (lset-intersection/eq? '(eval repl) used-units))
(notice ; XXX only issued when "-verbose" is used
(sprintf "~A has dynamic requirements but doesn't load (chicken eval): ~A"
diff --git a/chicken-install.scm b/chicken-install.scm
index 8f41b10e..ad8bbfa6 100644
--- a/chicken-install.scm
+++ b/chicken-install.scm
@@ -119,20 +119,14 @@
(define (repo-path)
(if (and cross-chicken (not host-extension))
- (list (destination-repository 'target))
- (##sys#split-path (repository-path))))
+ (destination-repository 'target)
+ (repository-path)))
(define (install-path)
(if (and cross-chicken (not host-extension))
(destination-repository 'target)
(destination-repository 'host)))
-(define (find-in-repo name)
- (let loop ((dirs (repo-path)))
- (cond ((null? dirs) #f)
- ((file-exists? (make-pathname (car dirs) name)))
- (else (loop (cdr dirs))))))
-
(define (build-script-extension mode platform)
(string-append "build"
(if (eq? mode 'target) ".target" "")
@@ -690,8 +684,9 @@
(cond ((or (eq? x 'chicken) (equal? x "chicken"))
(chicken-version))
((let* ((ep (##sys#canonicalize-extension-path x 'ext-version))
- (sf (find-in-repo
- (make-pathname #f ep +egg-info-extension+))))
+ (sf (chicken.load#find-file
+ (make-pathname #f ep +egg-info-extension+)
+ (repo-path))))
(and sf
(file-exists? sf)
(load-egg-info sf))) =>
diff --git a/chicken-status.scm b/chicken-status.scm
index f1049687..a51e18d5 100644
--- a/chicken-status.scm
+++ b/chicken-status.scm
@@ -46,21 +46,17 @@
(define (repo-path)
(if (and cross-chicken (not host-extensions))
- (list (destination-repository 'target))
- (##sys#split-path (repository-path))))
-
- (define (find-in-repo name)
- (let loop ((dirs (repo-path)))
- (cond ((null? dirs) #f)
- ((file-exists? (make-pathname (car dirs) name)))
- (else (loop (cdr dirs))))))
+ (destination-repository 'target)
+ (repository-path)))
(define (grep rx lst)
(filter (cut irregex-search rx <>) lst))
(define (read-info egg)
- (load-egg-info
- (or (find-in-repo (make-pathname #f egg +egg-info-extension+))
+ (load-egg-info
+ (or (chicken.load#find-file
+ (make-pathname #f egg +egg-info-extension+)
+ (repo-path))
(error "egg not found" egg))))
(define (filter-eggs patterns mtch)
@@ -84,7 +80,7 @@
(lambda (dir)
(map pathname-file
(glob (make-pathname dir "*" +egg-info-extension+))))
- (repo-path))
+ (##sys#split-path (repo-path)))
equal?))
(define (format-string str cols #!optional right (padc #\space))
diff --git a/csc.scm b/csc.scm
index affa02e5..7fdefdde 100644
--- a/csc.scm
+++ b/csc.scm
@@ -283,14 +283,17 @@
;;; Locate object files for linking:
+(define (repo-path)
+ (if (and cross-chicken (not host-mode))
+ (destination-repository 'target)
+ (repository-path)))
+
(define (find-object-file name)
- (or (file-exists? (make-pathname #f name object-extension))
- (and (not ignore-repository)
- (file-exists? (make-pathname (destination-repository (if host-mode
- 'host
- 'target))
- name object-extension)))
- (stop "could not find linked extension: ~a" name)))
+ (let ((o (make-pathname #f name object-extension)))
+ (or (file-exists? o)
+ (and (not ignore-repository)
+ (chicken.load#find-file o (repo-path)))
+ (stop "could not find linked extension: ~a" name))))
;;; Display usage information:
@@ -542,8 +545,7 @@ EOF
(exit) )
(when (pair? linked-extensions)
(set! object-files ; add objects from linked extensions
- (append object-files
- (map find-object-file linked-extensions))))
+ (append object-files (map find-object-file linked-extensions))))
(cond [(null? scheme-files)
(when (and (null? c-files)
(null? object-files))
@@ -953,22 +955,19 @@ EOF
transient-link-files)))))
(define (collect-linked-objects object-files)
- (let ((hrepo (destination-repository 'host))
- (trepo (destination-repository 'target)))
- (define (locate lst) ; add repo-path
- (map (lambda (ofile)
- (make-pathname (destination-repository (if host-mode 'host 'target))
- ofile))
- lst))
- (let loop ((os object-files) (os2 object-files))
- (if (null? os)
- (delete-duplicates (reverse os2) string=?)
- (let* ((o (car os))
- (lfile (pathname-replace-extension o "link"))
- (newos (if (file-exists? lfile)
- (locate (with-input-from-file lfile read))
- '())))
- (loop (append newos (cdr os)) (append newos os2)))))))
+ (define (locate lst)
+ (map (lambda (ofile)
+ (chicken.load#find-file ofile (repo-path)))
+ lst))
+ (let loop ((os object-files) (os2 object-files))
+ (if (null? os)
+ (delete-duplicates (reverse os2) string=?)
+ (let* ((o (car os))
+ (lfile (pathname-replace-extension o "link"))
+ (newos (if (file-exists? lfile)
+ (locate (with-input-from-file lfile read))
+ '())))
+ (loop (append newos (cdr os)) (append newos os2))))))
(define (copy-files from to)
(command
diff --git a/eval.scm b/eval.scm
index 736de382..0aca904c 100644
--- a/eval.scm
+++ b/eval.scm
@@ -1234,7 +1234,13 @@
(set! cache (cons path lst))
lst))))))
-(define ##sys#find-extension
+(define (find-file name search-path)
+ (let loop ((p (##sys#split-path search-path)))
+ (cond ((null? p) #f)
+ ((file-exists? (string-append (car p) "/" name)))
+ (else (loop (cdr p))))))
+
+(define find-dynamic-extension
(let ((file-exists? file-exists?)
(string-append string-append))
(lambda (path inc?)
@@ -1262,7 +1268,7 @@
((any ##sys#provided? alternates))
((memq id core-units)
(load-library/internal id #f loc))
- ((##sys#find-extension id #f) =>
+ ((find-dynamic-extension id #f) =>
(lambda (ext)
(load/internal ext #f #f #f #f id)
(##sys#provide id)))
@@ -1281,18 +1287,15 @@
(for-each (cut ##sys#check-symbol <> 'provided?) ids)
(every ##sys#provided? ids))
-(define static-extension-available?
- (let ((string-append string-append))
- (lambda (id)
- (and-let* ((rp (repository-path)))
- (let loop ((rp (##sys#split-path rp)))
- (cond ((null? rp) #f)
- ((file-exists?
- (string-append (car rp) "/"
- (##sys#canonicalize-extension-path id #f)
- object-file-extension)))
- (else (loop (cdr rp)))))))))
+(define (find-static-extension id)
+ (let ((p (##sys#canonicalize-extension-path id #f)))
+ (find-file (##sys#string-append p object-file-extension)
+ (repository-path))))
+;; Export for internal use in csc, modules and batch-driver:
+(define chicken.load#find-file find-file)
+(define chicken.load#find-static-extension find-static-extension)
+(define chicken.load#find-dynamic-extension find-dynamic-extension)
;;
;; Given a library specification, returns three values:
@@ -1318,8 +1321,8 @@
`(##core#declare (uses ,id))
`(##sys#load-library (##core#quote ,id)))
id #f))
- ((and compiling? static? (static-extension-available? id)) =>
- (lambda (path)
+ ((and compiling? static? (find-static-extension id)) =>
+ (lambda (path)
(mark-static id path)
(values `(##core#declare (uses ,id)) id 'static)))
(else
diff --git a/modules.scm b/modules.scm
index c0d8816b..a9d36706 100644
--- a/modules.scm
+++ b/modules.scm
@@ -567,7 +567,7 @@
(let* ((mname (##sys#resolve-module-name lib loc))
(mod (##sys#find-module mname #f loc)))
(unless mod
- (and-let* ((il (##sys#find-extension
+ (and-let* ((il (chicken.load#find-dynamic-extension
(string-append (symbol->string mname) ".import")
#t)))
(parameterize ((##sys#current-module #f)
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 966a4a6f..6d231938 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -1706,12 +1706,9 @@
(when specialize (mark-variable name '##compiler#clean #t)))
(define (pure! name)
(when specialize (mark-variable name '##compiler#pure #t)))
- (define (locate)
- (let loop ((dirs (##sys#split-path path)))
- (cond ((null? dirs) #f)
- ((file-exists? (make-pathname (car dirs) name)))
- (else (loop (cdr dirs))))))
- (and-let* ((dbfile (if (not path) (file-exists? name) (locate))))
+ (and-let* ((dbfile (if (not path)
+ (file-exists? name)
+ (chicken.load#find-file name path))))
(debugging 'p (sprintf "loading type database `~a' ...~%" dbfile))
(fluid-let ((scrutiny-debug #f))
(for-each
diff --git a/support.scm b/support.scm
index 1b4c9874..0f8f4029 100644
--- a/support.scm
+++ b/support.scm
@@ -1652,12 +1652,7 @@
;;; Load support files
(define (load-identifier-database name) ; Used only in batch-driver.scm
- (define (locate)
- (let loop ((dirs (##sys#split-path (repository-path))))
- (cond ((null? dirs) #f)
- ((file-exists? (make-pathname (car dirs) name)))
- (else (loop (cdr dirs))))))
- (and-let* ((dbfile (locate)))
+ (and-let* ((dbfile (chicken.load#find-file name (repository-path))))
(debugging 'p (sprintf "loading identifier database ~a ...~%" dbfile))
(for-each
(lambda (e)
diff --git a/tests/runtests.bat b/tests/runtests.bat
index e0199cc8..8ac8b144 100644
--- a/tests/runtests.bat
+++ b/tests/runtests.bat
@@ -9,7 +9,7 @@ set CHICKEN=..\chicken
set CHICKEN_PROFILE=..\chicken-profile
set CHICKEN_INSTALL_REPOSITORY=%TEST_DIR%\test-repository
set CHICKEN_REPOSITORY_PATH=%TEST_DIR%\..;%CHICKEN_INSTALL_REPOSITORY%
-set PATH=%cd%\..;%PATH%
+set PATH=%TEST_DIR%\..;%PATH%
set TYPESDB=..\types.db
rem Increase this when tests start failing on "inexplicable" diffs
@@ -20,9 +20,10 @@ set compile2=..\csc -compiler %CHICKEN% -v -I%TEST_DIR%/.. -L%TEST_DIR%/.. -incl
set compile_s=..\csc -s -types %TYPESDB% -ignore-repository -compiler %CHICKEN% -v -I%TEST_DIR%/.. -L%TEST_DIR%/.. -include-path %TEST_DIR%/..
set interpret=..\csi -n -include-path %TEST_DIR%/..
-del /f /q /s *.exe *.so *.o *.import.* ..\foo.import.* test-repository
-mkdir test-repository
-copy %TYPESDB% test-repository
+del /f /q /s *.exe *.so *.o *.import.* ..\foo.import.* %CHICKEN_INSTALL_REPOSITORY%
+rmdir /q /s %CHICKEN_INSTALL_REPOSITORY%
+mkdir %CHICKEN_INSTALL_REPOSITORY%
+copy %TYPESDB% %CHICKEN_INSTALL_REPOSITORY%
echo ======================================== version tests ...
%compile% version-tests.scm
@@ -578,7 +579,6 @@ if errorlevel 1 exit /b 1
if errorlevel 1 exit /b 1
linking-tests
if errorlevel 1 exit /b 1
-mkdir %CHICKEN_INSTALL_REPOSITORY%
move reverser.o %CHICKEN_INSTALL_REPOSITORY%
move reverser.import.scm %CHICKEN_INSTALL_REPOSITORY%
%compile2% -link reverser linking-tests.scm
diff --git a/tests/runtests.sh b/tests/runtests.sh
index ef2c6def..1cce11e6 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -447,7 +447,7 @@ $compile2 -link reverser linking-tests.scm
./linking-tests
$compile2 -link reverser linking-tests.scm -static
./linking-tests
-cp reverser.o reverser.import.scm "$CHICKEN_INSTALL_REPOSITORY"
+mv reverser.o reverser.import.scm "$CHICKEN_INSTALL_REPOSITORY"
$compile2 -link reverser linking-tests.scm
./linking-tests
$compile2 -link reverser linking-tests.scm -static
Trap