>From 642211f4cb98d4e73e0cb0d9ac4300fb63be1cd9 Mon Sep 17 00:00:00 2001 From: Evan Hanson Date: Sat, 15 Jul 2017 14:12:15 +1200 Subject: [PATCH] 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. --- batch-driver.scm | 2 +- chicken-install.scm | 15 +++++---------- chicken-status.scm | 18 +++++++----------- csc.scm | 49 ++++++++++++++++++++++++------------------------- eval.scm | 33 ++++++++++++++++++--------------- modules.scm | 2 +- scrutinizer.scm | 9 +++------ support.scm | 7 +------ tests/runtests.bat | 10 +++++----- tests/runtests.sh | 2 +- 10 files changed, 66 insertions(+), 81 deletions(-) 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 -- 2.11.0