Commit 95b40994 authored by Peter Van Eynde's avatar Peter Van Eynde
Browse files

Merge branch 'upstream'

parents 7938258f dc3e41aa
...@@ -7,6 +7,11 @@ website/changelog.xml ...@@ -7,6 +7,11 @@ website/changelog.xml
# Test stuff # Test stuff
test/results/ test/results/
test/tmp/
test/conf.d/
test/dir1/
test/dir2/
# We build these at various stages in the make process # We build these at various stages in the make process
LICENSE LICENSE
...@@ -22,3 +27,4 @@ lift-local.config ...@@ -22,3 +27,4 @@ lift-local.config
*.lib *.lib
*.o *.o
*.*fsl *.*fsl
*.bak
...@@ -174,7 +174,7 @@ ...@@ -174,7 +174,7 @@
;;;; ;;;;
(defparameter *asdf-version* (defparameter *asdf-version*
;; the 1+ hair is to ensure that we don't do an inadvertent find and replace ;; the 1+ hair is to ensure that we don't do an inadvertent find and replace
(subseq "VERSION:1.501" (1+ (length "VERSION")))) (subseq "VERSION:1.502" (1+ (length "VERSION"))))
(defun asdf-version () (defun asdf-version ()
*asdf-version*) *asdf-version*)
...@@ -816,7 +816,7 @@ to `~a` which is not a directory.~@:>" ...@@ -816,7 +816,7 @@ to `~a` which is not a directory.~@:>"
;; ON-DISK), but CMUCL barfs on that. ;; ON-DISK), but CMUCL barfs on that.
on-disk on-disk
*package*) *package*)
(load asd)) (load on-disk))
(error 'missing-definition :name name :pathname on-disk))) (error 'missing-definition :name name :pathname on-disk)))
(delete-package package)))) (delete-package package))))
(let ((in-memory (system-registered-p name))) (let ((in-memory (system-registered-p name)))
...@@ -1110,7 +1110,7 @@ to `~a` which is not a directory.~@:>" ...@@ -1110,7 +1110,7 @@ to `~a` which is not a directory.~@:>"
(error nil)) (error nil))
(dolist (kid (module-components c)) (dolist (kid (module-components c))
(handler-case (handler-case
(appendf forced (traverse operation kid )) (appendf forced (traverse operation kid))
(missing-dependency (condition) (missing-dependency (condition)
(if (eq (module-if-component-dep-fails c) (if (eq (module-if-component-dep-fails c)
:fail) :fail)
...@@ -1736,9 +1736,8 @@ output to `*verbose-out*`. Returns the shell's exit code." ...@@ -1736,9 +1736,8 @@ output to `*verbose-out*`. Returns the shell's exit code."
;;; --------------------------------------------------------------------------- ;;; ---------------------------------------------------------------------------
;;; Portions of this code were once from SWANK / SLIME ;;; Portions of this code were once from SWANK / SLIME
(defparameter *centralize-lisp-binaries* (defparameter *centralize-lisp-binaries* nil
nil " "If true, compiled lisp files without an explicit mapping (see
If true, compiled lisp files without an explicit mapping (see
\\*source-to-target-mappings\\*) will be placed in subdirectories of \\*source-to-target-mappings\\*) will be placed in subdirectories of
\\*default-toplevel-directory\\*. If false, then compiled lisp files \\*default-toplevel-directory\\*. If false, then compiled lisp files
without an explicitly mapping will be placed in subdirectories of without an explicitly mapping will be placed in subdirectories of
...@@ -1753,7 +1752,7 @@ See [implementation-specific-directory-name][] for details.") ...@@ -1753,7 +1752,7 @@ See [implementation-specific-directory-name][] for details.")
(defparameter *default-toplevel-directory* (defparameter *default-toplevel-directory*
(merge-pathnames (merge-pathnames
(make-pathname :directory '(:relative ".fasls")) (make-pathname :directory '(:relative ".cache" "common-lisp"))
(truename (user-homedir-pathname))) (truename (user-homedir-pathname)))
"If \\*centralize-lisp-binaries\\* is true, then compiled lisp files without an explicit mapping \(see \\*source-to-target-mappings\\*\) will be placed in subdirectories of \\*default-toplevel-directory\\*.") "If \\*centralize-lisp-binaries\\* is true, then compiled lisp files without an explicit mapping \(see \\*source-to-target-mappings\\*\) will be placed in subdirectories of \\*default-toplevel-directory\\*.")
...@@ -1955,7 +1954,7 @@ applied by the plain `*source-to-target-mappings*`." ...@@ -1955,7 +1954,7 @@ applied by the plain `*source-to-target-mappings*`."
(typecase component (typecase component
(cl-source-file t) (cl-source-file t)
(t nil))) (t nil)))
(let ((source (component-pathname component )) (let ((source (component-pathname component))
(paths (call-next-method))) (paths (call-next-method)))
(output-files-for-system-and-operation (output-files-for-system-and-operation
(component-system component) operation component source paths)) (component-system component) operation component source paths))
...@@ -2197,7 +2196,9 @@ with a different configuration, so the configuration would be re-read then." ...@@ -2197,7 +2196,9 @@ with a different configuration, so the configuration would be re-read then."
(defparameter *default-source-registries* (defparameter *default-source-registries*
'(process-environment-source-registry '(process-environment-source-registry
process-user-source-registry process-user-source-registry
process-user-source-registry-directory
process-system-source-registry process-system-source-registry
process-system-source-registry-directory
process-default-source-registry)) process-default-source-registry))
(defun user-configuration-pathname () (defun user-configuration-pathname ()
...@@ -2223,9 +2224,15 @@ with a different configuration, so the configuration would be re-read then." ...@@ -2223,9 +2224,15 @@ with a different configuration, so the configuration would be re-read then."
(defun process-user-source-registry (&key inherit collect) (defun process-user-source-registry (&key inherit collect)
(process-source-registry (user-source-registry-pathname) (process-source-registry (user-source-registry-pathname)
:inherit inherit :collect collect)) :inherit inherit :collect collect))
(defun process-user-source-registry-directory (&key inherit collect)
(process-source-registry (user-source-registry-directory-pathname)
:inherit inherit :collect collect))
(defun process-system-source-registry (&key inherit collect) (defun process-system-source-registry (&key inherit collect)
(process-source-registry (system-source-registry-pathname) (process-source-registry (system-source-registry-pathname)
:inherit inherit :collect collect)) :inherit inherit :collect collect))
(defun process-system-source-registry-directory (&key inherit collect)
(process-source-registry (system-source-registry-directory-pathname)
:inherit inherit :collect collect))
(defun process-default-source-registry (&key inherit collect) (defun process-default-source-registry (&key inherit collect)
(declare (ignore inherit collect)) (declare (ignore inherit collect))
nil) nil)
......
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
# - quit with exit status 0 on getting eof # - quit with exit status 0 on getting eof
# - quit with exit status >0 if an unhandled error occurs # - quit with exit status >0 if an unhandled error occurs
export CL_SOURCE_REGISTRY=$PWD export CL_SOURCE_REGISTRY="$PWD"
if [ x"$1" = "xhelp" ]; then if [ x"$1" = "xhelp" ]; then
echo "$0 [lisp invocation] [scripts-regex]" echo "$0 [lisp invocation] [scripts-regex]"
...@@ -71,47 +71,67 @@ if [ -z $1 ] ; then ...@@ -71,47 +71,67 @@ if [ -z $1 ] ; then
lisp="sbcl" lisp="sbcl"
fi fi
if [ "$lisp" = "sbcl" ] ; then case "$lisp" in
sbcl)
if type sbcl ; then if type sbcl ; then
fasl_ext="fasl" fasl_ext="fasl"
command="sbcl --userinit /dev/null --sysinit /dev/null --noinform --noprogrammer" command="sbcl --userinit /dev/null --sysinit /dev/null --noinform --noprogrammer"
fi fi ;;
elif [ "$lisp" = "clisp" ] ; then clisp)
if type clisp ; then if type clisp ; then
fasl_ext="fas" fasl_ext="fas"
command=`which clisp` command=`which clisp`
command="$command -norc -ansi -I - " command="$command -norc -ansi -I - "
fi fi ;;
elif [ "$lisp" = "allegro" ] ; then allegro)
if type alisp ; then if type alisp ; then
fasl_ext="fasl" fasl_ext="fasl"
command="alisp -q -batch " command="alisp -q -batch "
fi fi ;;
elif [ "$lisp" = "allegromodern" ] ; then allegromodern)
if type mlisp ; then if type mlisp ; then
fasl_ext="fasl" fasl_ext="fasl"
command="mlisp -q -batch " command="mlisp -q -batch "
fi fi ;;
elif [ "$lisp" = "ccl" ] ; then ccl)
if type ccl ; then if type ccl ; then
fasl_ext="dx32fsl" case `uname -s` in
Linux) fasl_os=lx ;;
Darwin) fasl_os=dx ;;
esac
case `uname -m` in
x86_64|ppc64) fasl_bits=64 ;;
i?86|ppc) fasl_bits=32 ;;
esac
fasl_ext="${fasl_os}${fasl_bits}fsl"
command="ccl --no-init --quiet --batch " command="ccl --no-init --quiet --batch "
fi fi ;;
fi cmucl)
if type lisp ; then
fasl_ext="x86f"
command="lisp -batch -noinit"
fi ;;
esac
create_asds () {
mkdir -p {conf.d,dir1,dir2/{dir3,dir4}}
for i in dir1 dir2; do touch "$i"/test.asd; done
for i in dir3 dir4; do (cd dir2/$i; touch test.asd); done
}
#if [ -x /usr/bin/lisp ] clean_up () {
#then rm -rf {conf.d,dir?}
# do_tests "/usr/bin/lisp -batch -noinit" x86f }
#fi
if [ -z "$command" ] ; then if [ -z "$command" ] ; then
echo "Error: cannot find or do not know how to run Lisp named $lisp" echo "Error: cannot find or do not know how to run Lisp named $lisp"
else else
create_asds
mkdir -p results mkdir -p results
echo $command echo $command
thedate=`date "+%Y-%m-%d"` thedate=`date "+%Y-%m-%d"`
do_tests "$command" $fasl_ext 2>&1 | tee "results/${lisp}.text" "results/${lisp}-${thedate}.save" do_tests "$command" $fasl_ext 2>&1 | tee "results/${lisp}.text" "results/${lisp}-${thedate}.save"
clean_up
fi fi
(load "script-support") (load "script-support")
(load "../asdf") (load "../asdf")
;; TODO: (defvar *test-directory*
;; - test for conditions (ensure-directory-pathname
;; - use with-env for CL_SOURCE_REGISTRY (getenv "PWD")))
;; - write clean-up procedures, if needed
(defvar *test-conf-directory*
(eval-when (:execute :compile-toplevel :load-toplevel) (merge-pathnames "conf.d/" (getenv "PWD")))
(require :sb-posix))
(defun under-test-directory (path &optional (defaults *test-directory*))
(defpackage :test-source-registry (merge-pathnames path defaults))
(:use #:cl #:asdf))
(defun ensure-recursive-directory (path)
(in-package :test-source-registry) (concatenate
'string
(defun getenv (x) (namestring
#+sbcl (ensure-directory-pathname path))
(sb-posix:getenv x)) "/"))
(defun setenv (x v) (defun create-conf-files (&optional (path *test-conf-directory*))
#+sbcl (let ((v `(("conf1.conf"
(sb-posix:putenv ((:directory ,(namestring (under-test-directory "dir1/")))))
(concatenate 'string x "=" v)) ("conf2.conf"
v) ((:tree ,(namestring (under-test-directory "dir2/"))))))))
(loop
(defmacro with-gensyms ((&rest names) &body body) :for (file contents) :in v :do
`(let ,(loop for n in names collect `(,n (gensym))) (with-open-file (out (merge-pathnames file path)
,@body)) :direction :output
:if-exists :supersede)
(defmacro with-env ((&rest kv) &body body) (with-standard-io-syntax
(let ((temps (loop :for i :upto (length kv) :collect (gensym))) (format out "~{~S~}" contents))))))
(keys (mapcar #'(lambda (x) (first x)) kv)))
(flet ((gen-getenvs () (defvar *test-config-1*
(mapcar #'(lambda (x y)
`(,y (getenv ,x)))
keys temps))
(gen-setenvs ()
(mapcar #'(lambda (x y) `(setenv ,y ,x))
temps keys)))
`(let ,(gen-getenvs)
(unwind-protect
(progn
,@(loop :for (k v) :in kv :collect `(setenv ,k ,v))
,@body)
(progn ,@(gen-setenvs)))))))
(defun make-temporary-directory ()
(let ((str (with-output-to-string (s)
(sb-ext:run-program "mktemp" '("-d" "-u") :search t :output s))))
(concatenate 'string
(string-trim '(#\newline) str) "/")))
(defvar *base-directory* (make-temporary-directory))
(defun home-directory (&optional (base *base-directory*))
(let ((s (namestring (user-homedir-pathname))))
(merge-pathnames (subseq s 1 (length s)) base)))
(defun system-directory (&optional (base *base-directory*))
(merge-pathnames "etc/" base))
(defun tmp-directory (&optional (base *base-directory*))
(merge-pathnames "tmp/" base))
(defun home-source-registry ()
(asdf::source-registry-under (merge-pathnames ".config/" (home-directory))))
(defun system-source-registry ()
(asdf::source-registry-under (system-directory)))
(defun merge-temp-under (path)
(namestring
(merge-pathnames
(let ((s (string-downcase
(prin1-to-string (gentemp)))))
(concatenate 'string s "/"))
path)))
(defvar *asd-temp-path-1*
(merge-temp-under
(merge-temp-under (tmp-directory))))
(defvar *system-source-registry-config*
`(:source-registry `(:source-registry
(:inherit-configuration) (:tree ,(getenv "PWD"))
(:tree ,*asd-temp-path-1*))) (:ignore-inherited-configuration)))
(defvar *asd-temp-path-2*
(namestring (tmp-directory))) (defvar *test-expect-1*
(defvar *home-source-registry-config* (append
`(:source-registry (loop
(:inhert-configuration) :for dir
(:directory ,(namestring (tmp-directory))))) :in '("dir1/" "dir2/dir3/" "dir2/dir4/" "dir2/")
:collect (merge-pathnames dir *test-directory*))
(defun write-registry-file (path contents) (list *test-directory*)))
(ensure-directories-exist path)
(with-open-file (out path (defvar *test-source-registries*
:direction :output '(test-environment-source-registry
:if-exists :supersede) test-environment-source-registry-recursive
(with-standard-io-syntax test-something-3))
(format out "~S" contents))))
(defun write-system-source-registry-config (defun test-environment-source-registry ()
(&key (path (system-source-registry)) (contents *system-source-registry-config*)) (process-source-registry (getenv "CL_SOURCE_REGISTRY")
(write-registry-file path contents)) :inherit *test-source-registries*))
(defun write-home-source-registry-config
(&key (path (home-source-registry)) (contents *home-source-registry-config*)) (defun test-environment-source-registry-recursive ()
(write-registry-file path contents)) (process-source-registry
(ensure-recursive-directory
;; use *asd-temp-path-X*? (getenv "CL_SOURCE_REGISTRY"))
(defun create-asd-file (&optional (directory *default-pathname-defaults*)) :inherit *test-source-registries*))
(let ((*default-pathname-defaults* directory))
(with-open-file (out (defun test-directory-source-registry
(&optional (directory *test-conf-directory*))
(process-source-registry
;; test environment variable (validate-source-registry-directory directory)))
(defun test-environment ()
(with-env-var (("CL_SOURCE_REGISTRY" (defun test-something-3 () nil)
(format nil "~A:~A" (home-directory) (system-directory))))
...)) (cl-user::quit-on-error
(create-conf-files)
;; test files (assert (every #'pathname (test-environment-source-registry)))
(defun test-files () (assert (every #'pathname (test-environment-source-registry-recursive)))
...) (assert (equal (test-directory-source-registry) *test-expect-1*))
;; (cl-user::quit-on-error ;; FIXME:
;; ...) ;; (assert (equal (process-source-registry
\ No newline at end of file ;; *test-config-1*)
;; *test-expect-1*))
;; FIXME: add more tests
;; (assert (equal ...))
)
\ No newline at end of file
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment