Commit d324c0ad authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

1.647:

* Fix initialize-output-translations to actually use the environment,
 map output destinations to themselves, and
 actually take a parameter as documented.
* Document same parameter for initialize-source-registry, which did take it.
* Tweak symbols between unintern and fmakunbound
 to make upgrade better on both current SBCL and ECL.
* Tweak run-tests to allow for parametrizable binaries,
 to redirect output to tmp/fasls, to output Lisp command being executed,
parent 550e4f93
;;; -*- mode: common-lisp; package: asdf; -*- ;;; -*- mode: common-lisp; package: asdf; -*-
;;; This is asdf: Another System Definition Facility. ;;; This is ASDF: Another System Definition Facility.
;;; ;;;
;;; Feedback, bug reports, and patches are all welcome: ;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>. ;;; please mail to <asdf-devel@common-lisp.net>.
;;; Note first that the canonical source for asdf is presently ;;; Note first that the canonical source for ASDF is presently
;;; <URL:http://common-lisp.net/project/asdf/>. ;;; <URL:http://common-lisp.net/project/asdf/>.
;;; ;;;
;;; If you obtained this copy from anywhere else, and you experience ;;; If you obtained this copy from anywhere else, and you experience
...@@ -147,7 +147,11 @@ ...@@ -147,7 +147,11 @@
:use '(:common-lisp :asdf-utilities) :use '(:common-lisp :asdf-utilities)
:unintern '(#:*asdf-revision* #:around #:asdf-method-combination #:split #:make-collector :unintern '(#:*asdf-revision* #:around #:asdf-method-combination #:split #:make-collector
#:perform #:explain #:output-files #:operation-done-p #:perform #:explain #:output-files #:operation-done-p
#:component-relative-pathname #:system-relative-pathname) #-ecl #:component-relative-pathname)
:fmakunbound '(#:system-source-file
#:component-relative-pathname #:system-relative-pathname
#:process-source-registry
#:inherit-source-registry #:process-source-registry-directive)
:export :export
'(#:defsystem #:oos #:operate #:find-system #:run-shell-command '(#:defsystem #:oos #:operate #:find-system #:run-shell-command
#:system-definition-pathname #:find-component ; miscellaneous #:system-definition-pathname #:find-component ; miscellaneous
...@@ -238,11 +242,6 @@ ...@@ -238,11 +242,6 @@
#:ensure-source-registry #:ensure-source-registry
#:process-source-registry)))) #:process-source-registry))))
#+nil
(error "The author of this file habitually uses #+nil to comment out ~
forms. But don't worry, it was unlikely to work in the New ~
Implementation of Lisp anyway")
(in-package #:asdf) (in-package #:asdf)
;;;; ------------------------------------------------------------------------- ;;;; -------------------------------------------------------------------------
...@@ -252,7 +251,7 @@ ...@@ -252,7 +251,7 @@
;; This parameter isn't actually user-visible ;; This parameter isn't actually user-visible
;; -- please use the exported function ASDF:ASDF-VERSION below. ;; -- please use the exported function ASDF:ASDF-VERSION below.
;; 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.646" (1+ (length "VERSION")))) (subseq "VERSION:1.647" (1+ (length "VERSION"))))
(defun asdf-version () (defun asdf-version ()
"Exported interface to the version of ASDF currently installed. A string. "Exported interface to the version of ASDF currently installed. A string.
...@@ -292,11 +291,6 @@ Defaults to `t`.") ...@@ -292,11 +291,6 @@ Defaults to `t`.")
;;;; * define methods on UPDATE-INSTANCE-FOR-REDEFINED-CLASS ;;;; * define methods on UPDATE-INSTANCE-FOR-REDEFINED-CLASS
;;;; for each of the classes we define that has changed incompatibly. ;;;; for each of the classes we define that has changed incompatibly.
(eval-when (:compile-toplevel :load-toplevel :execute) (eval-when (:compile-toplevel :load-toplevel :execute)
(when (and (fboundp 'system-source-file)
(not (typep (fdefinition 'system-source-file) 'generic-function)))
(fmakunbound 'system-source-file))
(map () 'fmakunbound '(process-source-registry inherit-source-registry
process-source-registry-directive))
#+ecl #+ecl
(when (find-class 'compile-op nil) (when (find-class 'compile-op nil)
(defmethod update-instance-for-redefined-class :after (defmethod update-instance-for-redefined-class :after
...@@ -2431,13 +2425,13 @@ with a different configuration, so the configuration would be re-read then." ...@@ -2431,13 +2425,13 @@ with a different configuration, so the configuration would be re-read then."
(return `(:output-translations ,@(nreverse directives))))))))) (return `(:output-translations ,@(nreverse directives)))))))))
(defparameter *default-output-translations* (defparameter *default-output-translations*
'(implementation-output-translations '(environment-output-translations
user-output-translations-pathname user-output-translations-pathname
user-output-translations-directory-pathname user-output-translations-directory-pathname
system-output-translations-pathname system-output-translations-pathname
system-output-translations-directory-pathname)) system-output-translations-directory-pathname))
(defparameter *implementation-output-translations* (defun wrapping-output-translations ()
`(:output-translations `(:output-translations
;; Some implementations have precompiled ASDF systems, ;; Some implementations have precompiled ASDF systems,
;; so we must disable translations for implementation paths. ;; so we must disable translations for implementation paths.
...@@ -2449,9 +2443,6 @@ with a different configuration, so the configuration would be re-read then." ...@@ -2449,9 +2443,6 @@ with a different configuration, so the configuration would be re-read then."
;; If we want to enable the user cache by default, here would be the place: ;; If we want to enable the user cache by default, here would be the place:
:enable-user-cache)) :enable-user-cache))
(defun implementation-output-translations ()
*implementation-output-translations*)
(defparameter *output-translations-file* #p"asdf-output-translations.conf") (defparameter *output-translations-file* #p"asdf-output-translations.conf")
(defparameter *output-translations-directory* #p"asdf-output-translations.conf.d/") (defparameter *output-translations-directory* #p"asdf-output-translations.conf.d/")
...@@ -2471,9 +2462,7 @@ with a different configuration, so the configuration would be re-read then." ...@@ -2471,9 +2462,7 @@ with a different configuration, so the configuration would be re-read then."
(inherit *default-output-translations*) (inherit *default-output-translations*)
collect) collect)
(process-output-translations (funcall x) :inherit inherit :collect collect)) (process-output-translations (funcall x) :inherit inherit :collect collect))
(defmethod process-output-translations ((pathname pathname) &key (defmethod process-output-translations ((pathname pathname) &key inherit collect)
(inherit *default-output-translations*)
collect)
(cond (cond
((directory-pathname-p pathname) ((directory-pathname-p pathname)
(process-output-translations (validate-output-translations-directory pathname) (process-output-translations (validate-output-translations-directory pathname)
...@@ -2483,19 +2472,13 @@ with a different configuration, so the configuration would be re-read then." ...@@ -2483,19 +2472,13 @@ with a different configuration, so the configuration would be re-read then."
:inherit inherit :collect collect)) :inherit inherit :collect collect))
(t (t
(inherit-output-translations inherit :collect collect)))) (inherit-output-translations inherit :collect collect))))
(defmethod process-output-translations ((string string) &key (defmethod process-output-translations ((string string) &key inherit collect)
(inherit *default-output-translations*)
collect)
(process-output-translations (parse-output-translations-string string) (process-output-translations (parse-output-translations-string string)
:inherit inherit :collect collect)) :inherit inherit :collect collect))
(defmethod process-output-translations ((x null) &key (defmethod process-output-translations ((x null) &key inherit collect)
(inherit *default-output-translations*)
collect)
(declare (ignorable x)) (declare (ignorable x))
(inherit-output-translations inherit :collect collect)) (inherit-output-translations inherit :collect collect))
(defmethod process-output-translations ((form cons) &key (defmethod process-output-translations ((form cons) &key inherit collect)
(inherit *default-output-translations*)
collect)
(dolist (directive (cdr (validate-output-translations-form form))) (dolist (directive (cdr (validate-output-translations-form form)))
(process-output-translations-directive directive :inherit inherit :collect collect))) (process-output-translations-directive directive :inherit inherit :collect collect)))
...@@ -2521,19 +2504,21 @@ with a different configuration, so the configuration would be re-read then." ...@@ -2521,19 +2504,21 @@ with a different configuration, so the configuration would be re-read then."
(process-output-translations (pathname dst) :inherit nil :collect collect)) (process-output-translations (pathname dst) :inherit nil :collect collect))
(let* ((trusrc (truenamize (resolve-location src t))) (let* ((trusrc (truenamize (resolve-location src t)))
(trudst (if dst (resolve-location dst t) trusrc))) (trudst (if dst (resolve-location dst t) trusrc)))
(funcall collect (list trudst trudst))
(funcall collect (list trusrc trudst))))))) (funcall collect (list trusrc trudst)))))))
(defun compute-output-translations (defun compute-output-translations (&optional parameter)
(&optional (translations *default-output-translations*))
"read the configuration, return it" "read the configuration, return it"
(while-collecting (c) (remove-duplicates
(inherit-output-translations translations :collect #'c))) (while-collecting (c)
(inherit-output-translations
`(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))
:test 'equal :from-end nil))
(defun initialize-output-translations (defun initialize-output-translations (&optional parameter)
(&optional (translations *default-output-translations*))
"read the configuration, initialize the internal configuration variable, "read the configuration, initialize the internal configuration variable,
return the configuration" return the configuration"
(setf (output-translations) (compute-output-translations translations))) (setf (output-translations) (compute-output-translations parameter)))
;; checks an initial variable to see whether the state is initialized ;; checks an initial variable to see whether the state is initialized
;; or cleared. In the former case, return current configuration; in ;; or cleared. In the former case, return current configuration; in
...@@ -2779,7 +2764,8 @@ with a different configuration, so the configuration would be re-read then." ...@@ -2779,7 +2764,8 @@ with a different configuration, so the configuration would be re-read then."
user-source-registry user-source-registry
user-source-registry-directory user-source-registry-directory
system-source-registry system-source-registry
system-source-registry-directory)) system-source-registry-directory
default-source-registry))
(defparameter *source-registry-file* #p"source-registry.conf") (defparameter *source-registry-file* #p"source-registry.conf")
(defparameter *source-registry-directory* #p"source-registry.conf.d/") (defparameter *source-registry-directory* #p"source-registry.conf.d/")
...@@ -2891,8 +2877,7 @@ with a different configuration, so the configuration would be re-read then." ...@@ -2891,8 +2877,7 @@ with a different configuration, so the configuration would be re-read then."
(flatten-source-registry (flatten-source-registry
`(wrapping-source-registry `(wrapping-source-registry
,parameter ,parameter
,@*default-source-registries* ,@*default-source-registries*)))
default-source-registry)))
(simplified (simplified
(remove-duplicates flattened :test 'equal :from-end nil)) (remove-duplicates flattened :test 'equal :from-end nil))
(processed (processed
......
...@@ -855,7 +855,8 @@ and in the usual case the user is recommended not to supply it. ...@@ -855,7 +855,8 @@ and in the usual case the user is recommended not to supply it.
Instead, ASDF follows a hairy set of rules that are designed so that Instead, ASDF follows a hairy set of rules that are designed so that
@enumerate @enumerate
@item @item
@code{find-system} will load a system from disk @code{find-system}
will load a system from disk
and have its pathname default to the right place. and have its pathname default to the right place.
@item @item
This pathname information will not be overwritten with This pathname information will not be overwritten with
...@@ -1693,8 +1694,16 @@ The specified functions are exported from your build system's package. ...@@ -1693,8 +1694,16 @@ The specified functions are exported from your build system's package.
Thus for ASDF the corresponding functions are in package ASDF, Thus for ASDF the corresponding functions are in package ASDF,
and for XCVB the corresponding functions are in package XCVB. and for XCVB the corresponding functions are in package XCVB.
@defun initialize-source-registry @defun initialize-source-registry PARAMETER
will read the configuration and initialize all internal variables. will read the configuration and initialize all internal variables.
You may extend or override configuration
from the environment and configuration files
with the given @var{PARAMETER}, which can be
@code{NIL} (no configuration override),
or a SEXP (in the SEXP DSL),
a string (as in the string DSL),
a pathname (of a file or directory with configuration),
or a symbol (fbound to function that when called returns one of the above).
@end defun @end defun
@defun clear-source-registry @defun clear-source-registry
...@@ -1708,31 +1717,11 @@ and for XCVB the corresponding functions are in package XCVB. ...@@ -1708,31 +1717,11 @@ and for XCVB the corresponding functions are in package XCVB.
where to look for systems not yet defined. where to look for systems not yet defined.
@end defun @end defun
@defun ensure-source-registry @defun ensure-source-registry PARAMETER
checks whether a source registry has been initialized. checks whether a source registry has been initialized.
If not, initialize it. If not, initialize it with the given @var{PARAMETER}.
This function will be called before any attempt to find a system
in the source registry.
If your application wants to override the provided defaults,
it will have to use the below function process-source-registry.
@end defun
@defun process-source-registry X &key inherit collect
If X is a CONS, parse it as a SEXP in the configuration DSL,
and extend or override inheritted configuration.
If X is a STRING, first parse it into a SEXP
as for the CL_SOURCE_REGISTRY
environment variable (see above) then process it.
If X is a PATHNAME, read the file as a single SEXP and process it.
The inheritted configuration is provided in keyword argument inherit,
itself a list of functions that take inherit
and collect keyword arguments
and defaulting to a list of functions
that implements the default behavior.
@end defun @end defun
@section Future @section Future
If this mechanism is successful, in the future, we may declare If this mechanism is successful, in the future, we may declare
...@@ -2109,7 +2098,6 @@ To explicitly flush any information cached by the system, use the API below. ...@@ -2109,7 +2098,6 @@ To explicitly flush any information cached by the system, use the API below.
The specified functions are exported from package ASDF. The specified functions are exported from package ASDF.
@defun initialize-output-translations PARAMETER @defun initialize-output-translations PARAMETER
will read the configuration and initialize all internal variables. will read the configuration and initialize all internal variables.
You may extend or override configuration You may extend or override configuration
......
...@@ -284,6 +284,11 @@ ...@@ -284,6 +284,11 @@
make-pathname) make-pathname)
(quit-on-error (quit-on-error
(asdf:initialize-source-registry)
(format t "source registry: ~S~%" (asdf::source-registry))
(asdf:initialize-output-translations)
(format t "output translations: ~S~%" (asdf::output-translations))
(or (test-component-pathnames :delete-host t :support-string-pathnames nil) (or (test-component-pathnames :delete-host t :support-string-pathnames nil)
(leave-lisp "test failed" 1))) (leave-lisp "test failed" 1)))
......
...@@ -5,7 +5,6 @@ ...@@ -5,7 +5,6 @@
# - 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"
unset DEBUG_ASDF_TEST unset DEBUG_ASDF_TEST
while getopts "duh" OPTION while getopts "duh" OPTION
...@@ -51,10 +50,12 @@ usage () { ...@@ -51,10 +50,12 @@ usage () {
echo " -u -h -- show this message." echo " -u -h -- show this message."
} }
DO () { ( set -x ; "$@" ); }
do_tests() { do_tests() {
command="$1" eval="$2" command="$1" eval="$2"
rm -f ~/.cache/common-lisp/"`pwd`"/* || true rm -f ~/.cache/common-lisp/"`pwd`"/* || true
( cd .. && $command $eval '(load "test/compile-asdf.lisp")' ) ( cd .. && DO $command $eval '(load "test/compile-asdf.lisp")' )
if [ $? -ne 0 ] ; then if [ $? -ne 0 ] ; then
echo "Compilation FAILED" >&2 echo "Compilation FAILED" >&2
else else
...@@ -68,7 +69,7 @@ do_tests() { ...@@ -68,7 +69,7 @@ do_tests() {
echo "Testing: $i" >&2 echo "Testing: $i" >&2
test_count=`expr "$test_count" + 1` test_count=`expr "$test_count" + 1`
rm -f ~/.cache/common-lisp/"`pwd`"/* || true rm -f ~/.cache/common-lisp/"`pwd`"/* || true
if $command $eval "(load \"$i\")" ; then if DO $command $eval "(load \"$i\")" ; then
echo "Using $command, $i passed" >&2 echo "Using $command, $i passed" >&2
test_pass=`expr "$test_pass" + 1` test_pass=`expr "$test_pass" + 1`
else else
...@@ -104,54 +105,50 @@ fi ...@@ -104,54 +105,50 @@ fi
command= flags= nodebug= eval= command= flags= nodebug= eval=
case "$lisp" in case "$lisp" in
sbcl) sbcl)
command=sbcl command="${SBCL:-sbcl}"
flags="--noinform --userinit /dev/null --sysinit /dev/null" flags="--noinform --userinit /dev/null --sysinit /dev/null"
nodebug="--disable-debugger" nodebug="--disable-debugger"
eval="--eval" ;; eval="--eval" ;;
clisp) clisp)
command=clisp command="${CLISP:-clisp}"
flags="-norc -ansi -I " flags="-norc -ansi -I "
nodebug="-on-error exit" nodebug="-on-error exit"
eval="-x" ;; eval="-x" ;;
allegro) allegro)
command=alisp command="${ALLEGRO:-alisp}"
flags="-q" flags="-q"
nodebug="-batch" nodebug="-batch"
eval="-e" ;; eval="-e" ;;
allegromodern) allegromodern)
command=mlisp command="${ALLEGROMODERN:-mlisp}"
flags="-q" flags="-q"
nodebug="-batch" nodebug="-batch"
eval="-e" ;; eval="-e" ;;
ccl) ccl)
command=ccl command="${CCL:-ccl}"
flags="--no-init --quiet" flags="--no-init --quiet"
nodebug="--batch" nodebug="--batch"
eval="--eval" ;; eval="--eval" ;;
cmucl) cmucl)
command=lisp command="${CMUCL:-lisp}"
flags="-noinit" flags="-noinit"
nodebug="-batch" nodebug="-batch"
eval="-eval" ;; eval="-eval" ;;
ecl) ecl)
#if [ -x /usr/lib/ecl/ecl-original ] ; then command="${ECL:-ecl}"
# command=/usr/lib/ecl/ecl-original
#else
command=ecl
#fi
flags="-norc" flags="-norc"
eval="-eval" ;; eval="-eval" ;;
lispworks) lispworks)
command=lispworks command="${LISPWORKS:-lispworks}"
flags="-siteinit - -init -" flags="-siteinit - -init -"
eval="-eval" ;; eval="-eval" ;;
gclcvs) gclcvs)
export GCL_ANSI=t export GCL_ANSI=t
command=gclcvs command="${GCL:-gclcvs}"
flags="-batch" flags="-batch"
eval="-eval" ;; eval="-eval" ;;
abcl) abcl)
command=abcl command="${ABCL:-abcl}"
eval="--eval" ;; eval="--eval" ;;
*) *)
echo "Unsupported lisp: $1" >&2 echo "Unsupported lisp: $1" >&2
...@@ -164,10 +161,17 @@ if ! type "$command" ; then ...@@ -164,10 +161,17 @@ if ! type "$command" ; then
exit 43 exit 43
fi fi
asdfdir="$(cd .. ; /bin/pwd)"
export CL_SOURCE_REGISTRY="${asdfdir}"
export ASDF_OUTPUT_TRANSLATIONS="${asdfdir}:${asdfdir}/tmp/fasls/$(basename $command)"
env | grep asdf
command="$command $flags"
if [ -z "${DEBUG_ASDF_TEST}" ] ; then if [ -z "${DEBUG_ASDF_TEST}" ] ; then
command="$command $nodebug" command="$command $nodebug"
fi fi
create_config () { create_config () {
mkdir -p ../tmp/test-source-registry-conf.d ../tmp/test-asdf-output-translations-conf.d mkdir -p ../tmp/test-source-registry-conf.d ../tmp/test-asdf-output-translations-conf.d
} }
...@@ -181,8 +185,6 @@ if [ -z "$command" ] ; then ...@@ -181,8 +185,6 @@ if [ -z "$command" ] ; then
else else
create_config create_config
mkdir -p results mkdir -p results
command="$command $flags"
echo $command
thedate=`date "+%Y-%m-%d"` thedate=`date "+%Y-%m-%d"`
do_tests "$command" "$eval" 2>&1 | \ do_tests "$command" "$eval" 2>&1 | \
tee "results/${lisp}.text" "results/${lisp}-${thedate}.save" tee "results/${lisp}.text" "results/${lisp}-${thedate}.save"
......
...@@ -10,10 +10,8 @@ ...@@ -10,10 +10,8 @@
*load-truename*))) *load-truename*)))
(defvar *asdf-fasl* (defvar *asdf-fasl*
(compile-file-pathname (compile-file-pathname
(merge-pathnames (let ((impl (string-downcase
(make-pathname :directory '(:relative "tmp") (or #+allegro (format nil "~Alisp" excl:*current-case-mode*)
:name (format nil "asdf-~(~A~)"
(or #+allegro (format nil "~Alisp" excl:*current-case-mode*)
#+armedbear :abcl #+armedbear :abcl
#+clisp :clisp #+clisp :clisp
#+clozure :ccl #+clozure :ccl
...@@ -24,9 +22,11 @@ ...@@ -24,9 +22,11 @@
#+gcl :gcl #+gcl :gcl
#+lispworks :lispworks #+lispworks :lispworks
#+sbcl :sbcl #+sbcl :sbcl
#+scl scl)) #+scl scl))))
:defaults *asdf-lisp*) (merge-pathnames
*asdf-lisp*))) (make-pathname :directory `(:relative "tmp" "fasls" ,impl)
:defaults *asdf-lisp*)
*asdf-lisp*))))
(defun load-asdf () (defun load-asdf ()
(load *asdf-fasl*)) (load *asdf-fasl*))
......
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