From 08f2609232185e09fd323afb6b8ceadad55c52f1 Mon Sep 17 00:00:00 2001 From: Kooda Date: Thu, 9 Aug 2018 20:47:14 +0200 Subject: [PATCH] Make `repository-path` from (chicken platform) return a list instead of a string --- NEWS | 3 +++ chicken-install.scm | 2 +- chicken-status.scm | 13 ++++++--- eval.scm | 44 ++++++------------------------- library.scm | 42 ++++++++++++++++++++++++++--- tests/private-repository-test.scm | 2 +- tests/repository-path-default.scm | 9 +++++++ tests/repository-path.scm | 33 +++++++++++++++++++++++ tests/runtests.bat | 10 +++++++ tests/runtests.sh | 11 +++++++- tests/sample-module.scm | 3 +++ types.db | 1 + 12 files changed, 128 insertions(+), 45 deletions(-) create mode 100644 tests/repository-path-default.scm create mode 100644 tests/repository-path.scm create mode 100644 tests/sample-module.scm diff --git a/NEWS b/NEWS index c6489e78..301bf947 100644 --- a/NEWS +++ b/NEWS @@ -102,6 +102,9 @@ - `process`, `process*` and `process-execute` now expect lists of the form (("NAME" . "VALUE") ...) instead of the previous (("NAME=VALUE") ...) as their environment argument. + - `repository-path` is now a parameter containing a list of strings instead + of a string, as the search path for libraries can now contain multiple + directories. - Module system - The compiler has been modularised, for improved namespacing. This diff --git a/chicken-install.scm b/chicken-install.scm index e88d23b6..14e07262 100644 --- a/chicken-install.scm +++ b/chicken-install.scm @@ -112,7 +112,7 @@ (define (repo-path) (if (and cross-chicken (not host-extension)) - (destination-repository 'target) + (##sys#split-path (destination-repository 'target)) (repository-path))) (define (install-path) diff --git a/chicken-status.scm b/chicken-status.scm index 25c873dc..e145e32a 100644 --- a/chicken-status.scm +++ b/chicken-status.scm @@ -63,7 +63,7 @@ (define (repo-path) (if (and cross-chicken (not host-extensions)) - (destination-repository 'target) + (##sys#split-path (destination-repository 'target)) (repository-path))) (define (grep rx lst) @@ -93,7 +93,7 @@ (lambda (dir) (map pathname-file (glob (make-pathname dir "*" +egg-info-extension+)))) - (##sys#split-path (repo-path))) + (repo-path)) equal?)) (define (format-string str cols #!optional right (padc #\space)) @@ -112,7 +112,14 @@ (let ((version (cond ((let ((info (read-info egg dir ext))) (and info (get-egg-property info 'version)))) - ((file-exists? (make-pathname (list dir egg) +version-file+)) + ((and (string? dir) + (file-exists? (make-pathname (list dir egg) +version-file+))) + => (lambda (fname) + (with-input-from-file fname read))) + ((chicken.load#find-file +version-file+ + (map (lambda (d) + (make-pathname d egg)) + dir)) => (lambda (fname) (with-input-from-file fname read))) (else "unknown")))) diff --git a/eval.scm b/eval.scm index c34622f7..68c824bf 100644 --- a/eval.scm +++ b/eval.scm @@ -1212,40 +1212,15 @@ (define ##sys#setup-mode #f) -(define path-list-separator - (if ##sys#windows-platform #\; #\:)) - -(define ##sys#split-path - (let ((cache '(#f))) - (lambda (path) - (cond ((not path) '()) - ((equal? path (car cache)) - (cdr cache)) - (else - (let* ((len (string-length path)) - (lst (let loop ((start 0) (pos 0)) - (cond ((fx>= pos len) - (if (fx= pos start) - '() - (list (substring path start pos)))) - ((char=? (string-ref path pos) - path-list-separator) - (cons (substring path start pos) - (loop (fx+ pos 1) - (fx+ pos 1)))) - (else - (loop start (fx+ pos 1))))))) - (set! cache (cons path lst)) - lst)))))) - (define (file-exists? name) ; defined here to avoid file unit dependency (and (##sys#file-exists? name #t #f #f) name)) (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)))))) + (cond ((not search-path) #f) + ((null? search-path) #f) + ((string? search-path) (find-file name (list search-path))) + ((file-exists? (string-append (car search-path) "/" name))) + (else (find-file name (cdr search-path))))) (define find-dynamic-extension (let ((string-append string-append)) @@ -1261,7 +1236,7 @@ (file-exists? (##sys#string-append p0 source-file-extension))))) (let loop ((paths (##sys#append (if ##sys#setup-mode '(".") '()) - (if rp (##sys#split-path rp) '()) + (or rp '()) (if inc? ##sys#include-pathnames '()) (if ##sys#setup-mode '() '("."))) )) (and (pair? paths) @@ -1364,11 +1339,8 @@ (or (test (make-relative-pathname source fname)) (let loop ((paths (if repo (##sys#append - ##sys#include-pathnames - (let ((rp (repository-path))) - (if rp - (##sys#split-path rp) - '()))) + ##sys#include-pathnames + (or (repository-path) '()) ) ##sys#include-pathnames) ) ) (cond ((eq? paths '()) #f) ((test (string-append (##sys#slot paths 0) diff --git a/library.scm b/library.scm index 90d491ef..e81648cd 100644 --- a/library.scm +++ b/library.scm @@ -6472,11 +6472,47 @@ static C_word C_fcall C_setenv(C_word x, C_word y) { (define (chicken-home) installation-home) +(define path-list-separator + (if ##sys#windows-platform #\; #\:)) + +(define ##sys#split-path + (let ((cache '(#f))) + (lambda (path) + (cond ((not path) '()) + ((equal? path (car cache)) + (cdr cache)) + (else + (let* ((len (string-length path)) + (lst (let loop ((start 0) (pos 0)) + (cond ((fx>= pos len) + (if (fx= pos start) + '() + (list (substring path start pos)))) + ((char=? (string-ref path pos) + path-list-separator) + (cons (substring path start pos) + (loop (fx+ pos 1) + (fx+ pos 1)))) + (else + (loop start (fx+ pos 1))))))) + (set! cache (cons path lst)) + lst)))))) + (define repository-path (make-parameter - (or (foreign-value "C_private_repository_path()" c-string) - (get-environment-variable "CHICKEN_REPOSITORY_PATH") - install-egg-home))) + (cond ((foreign-value "C_private_repository_path()" c-string) + => list) + ((get-environment-variable "CHICKEN_REPOSITORY_PATH") + => ##sys#split-path) + (install-egg-home + => list) + (else #f)) + (lambda (new) + (and new + (begin + (##sys#check-list new 'repository-path) + (for-each (lambda (p) (##sys#check-string p 'repository-path)) new) + new))))) (define installation-repository (make-parameter diff --git a/tests/private-repository-test.scm b/tests/private-repository-test.scm index d293962e..46fbf37a 100644 --- a/tests/private-repository-test.scm +++ b/tests/private-repository-test.scm @@ -12,7 +12,7 @@ ((and windows (not cygwin)) (lambda (filename _) filename)) (else read-symbolic-link))) -(define repo (normalize-pathname (read-symbolic-link* (repository-path) #t))) +(define repo (normalize-pathname (read-symbolic-link* (car (repository-path)) #t))) (define dir (normalize-pathname (read-symbolic-link* (car (command-line-arguments)) #t))) (print (list dir repo)) diff --git a/tests/repository-path-default.scm b/tests/repository-path-default.scm new file mode 100644 index 00000000..dcb1429d --- /dev/null +++ b/tests/repository-path-default.scm @@ -0,0 +1,9 @@ +(import (chicken platform)) + +(include "test.scm") + +(print (repository-path)) +(test-assert "(repository-path) contains something by default" + (= 1 (length (repository-path)))) + +(test-exit) diff --git a/tests/repository-path.scm b/tests/repository-path.scm new file mode 100644 index 00000000..0253c321 --- /dev/null +++ b/tests/repository-path.scm @@ -0,0 +1,33 @@ +(import (chicken platform) + (chicken process-context) + (chicken condition)) + +(include "test.scm") + +(test-equal "find-file on #f" + (chicken.load#find-file "repository-path.scm" #f) + #f) + +(test-equal "find-file on string" + (chicken.load#find-file "repository-path.scm" ".") + "./repository-path.scm") + +(test-equal "find-file on list" + (chicken.load#find-file "repository-path.scm" '(".." ".")) + "./repository-path.scm") + +(test-equal "(repository-path) is populated by CHICKEN_REPOSITORY_PATH" + (repository-path) + (command-line-arguments)) + +(repository-path + (cons (get-environment-variable "CHICKEN_INSTALL_REPOSITORY") + (repository-path))) + +(test-assert "setting (repository-path) and loading a library" + (handle-exceptions exn #f (begin (require-library sample-module) #t))) + +(test-error "Putting garbage in (repository-path)" + (repository-path '(foo))) + +(test-exit) diff --git a/tests/runtests.bat b/tests/runtests.bat index 6030d387..6826a734 100644 --- a/tests/runtests.bat +++ b/tests/runtests.bat @@ -27,6 +27,16 @@ rmdir /q /s %CHICKEN_INSTALL_REPOSITORY% mkdir %CHICKEN_INSTALL_REPOSITORY% copy %TYPESDB% %CHICKEN_INSTALL_REPOSITORY% +echo "======================================== repository search path ..." +setlocal +set "CHICKEN_REPOSITORY_PATH=" +%interpret% -s repository-path-default.scm +endlocal +%compile_s% sample-module.scm -j sample-module +copy sample-module.so %CHICKEN_INSTALL_REPOSITORY% +copy sample-module.import.scm %CHICKEN_INSTALL_REPOSITORY% +$interpret -s repository-path.scm "%TEST_DIR%\.." "%TEST_DIR%/test-repository" + echo "======================================== types.db consistency ..." %interpret% -s types-db-consistency.scm %TYPESDB% if errorlevel 1 exit /b 1 diff --git a/tests/runtests.sh b/tests/runtests.sh index 06279127..0232e7bd 100755 --- a/tests/runtests.sh +++ b/tests/runtests.sh @@ -4,7 +4,6 @@ # - Note: this needs a proper shell, so it will not work with plain mingw # (just the compiler and the Windows shell, without MSYS) - set -e if test -z "$MSYSTEM"; then TEST_DIR=`pwd` @@ -63,6 +62,16 @@ rm -fr *.exe *.so *.o *.out *.import.* ../foo.import.* test-repository mkdir -p test-repository cp $TYPESDB test-repository/types.db +echo "======================================== repository search path ..." +export -p >./old-environment +unset CHICKEN_REPOSITORY_PATH +$interpret -s repository-path-default.scm +. ./old-environment +$compile_s sample-module.scm -j sample-module +cp sample-module.so $CHICKEN_INSTALL_REPOSITORY +cp sample-module.import.scm $CHICKEN_INSTALL_REPOSITORY +$interpret -s repository-path.scm "${TEST_DIR}/.." "${TEST_DIR}/test-repository" + echo "======================================== types.db consistency ..." $interpret -s types-db-consistency.scm ${TYPESDB} diff --git a/tests/sample-module.scm b/tests/sample-module.scm new file mode 100644 index 00000000..32ac627f --- /dev/null +++ b/tests/sample-module.scm @@ -0,0 +1,3 @@ +(module sample-module (foo) +(import scheme) +(define foo 42)) diff --git a/types.db b/types.db index b84582b2..c92fcafd 100644 --- a/types.db +++ b/types.db @@ -1339,6 +1339,7 @@ (chicken.load#provided? (#(procedure #:clean #:enforce) chicken.load#provided? (#!rest symbol) boolean)) (chicken.load#require (#(procedure #:clean) chicken.load#require (#!rest symbol) undefined)) (chicken.load#set-dynamic-load-mode! (#(procedure #:clean #:enforce) chicken.load#set-dynamic-load-mode! ((or symbol (list-of symbol))) undefined)) +(chicken.load#find-file (#(procedure #:clean) chicken.load#find-file (string (or (list-of string) string)) (or string false))) ;; platform -- 2.18.0