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; -*-
;;; This is asdf: Another System Definition Facility.
;;; This is ASDF: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; 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/>.
;;;
;;; If you obtained this copy from anywhere else, and you experience
......@@ -147,7 +147,11 @@
:use '(:common-lisp :asdf-utilities)
:unintern '(#:*asdf-revision* #:around #:asdf-method-combination #:split #:make-collector
#: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
'(#:defsystem #:oos #:operate #:find-system #:run-shell-command
#:system-definition-pathname #:find-component ; miscellaneous
......@@ -238,11 +242,6 @@
#:ensure-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)
;;;; -------------------------------------------------------------------------
......@@ -252,7 +251,7 @@
;; This parameter isn't actually user-visible
;; -- 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
(subseq "VERSION:1.646" (1+ (length "VERSION"))))
(subseq "VERSION:1.647" (1+ (length "VERSION"))))
(defun asdf-version ()
"Exported interface to the version of ASDF currently installed. A string.
......@@ -292,11 +291,6 @@ Defaults to `t`.")
;;;; * define methods on UPDATE-INSTANCE-FOR-REDEFINED-CLASS
;;;; for each of the classes we define that has changed incompatibly.
(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
(when (find-class 'compile-op nil)
(defmethod update-instance-for-redefined-class :after
......@@ -2431,13 +2425,13 @@ with a different configuration, so the configuration would be re-read then."
(return `(:output-translations ,@(nreverse directives)))))))))
(defparameter *default-output-translations*
'(implementation-output-translations
'(environment-output-translations
user-output-translations-pathname
user-output-translations-directory-pathname
system-output-translations-pathname
system-output-translations-directory-pathname))
(defparameter *implementation-output-translations*
(defun wrapping-output-translations ()
`(:output-translations
;; Some implementations have precompiled ASDF systems,
;; so we must disable translations for implementation paths.
......@@ -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:
:enable-user-cache))
(defun implementation-output-translations ()
*implementation-output-translations*)
(defparameter *output-translations-file* #p"asdf-output-translations.conf")
(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."
(inherit *default-output-translations*)
collect)
(process-output-translations (funcall x) :inherit inherit :collect collect))
(defmethod process-output-translations ((pathname pathname) &key
(inherit *default-output-translations*)
collect)
(defmethod process-output-translations ((pathname pathname) &key inherit collect)
(cond
((directory-pathname-p 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."
:inherit inherit :collect collect))
(t
(inherit-output-translations inherit :collect collect))))
(defmethod process-output-translations ((string string) &key
(inherit *default-output-translations*)
collect)
(defmethod process-output-translations ((string string) &key inherit collect)
(process-output-translations (parse-output-translations-string string)
:inherit inherit :collect collect))
(defmethod process-output-translations ((x null) &key
(inherit *default-output-translations*)
collect)
(defmethod process-output-translations ((x null) &key inherit collect)
(declare (ignorable x))
(inherit-output-translations inherit :collect collect))
(defmethod process-output-translations ((form cons) &key
(inherit *default-output-translations*)
collect)
(defmethod process-output-translations ((form cons) &key inherit collect)
(dolist (directive (cdr (validate-output-translations-form form)))
(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."
(process-output-translations (pathname dst) :inherit nil :collect collect))
(let* ((trusrc (truenamize (resolve-location src t)))
(trudst (if dst (resolve-location dst t) trusrc)))
(funcall collect (list trudst trudst))
(funcall collect (list trusrc trudst)))))))
(defun compute-output-translations
(&optional (translations *default-output-translations*))
(defun compute-output-translations (&optional parameter)
"read the configuration, return it"
(while-collecting (c)
(inherit-output-translations translations :collect #'c)))
(remove-duplicates
(while-collecting (c)
(inherit-output-translations
`(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))
:test 'equal :from-end nil))
(defun initialize-output-translations
(&optional (translations *default-output-translations*))
(defun initialize-output-translations (&optional parameter)
"read the configuration, initialize the internal configuration variable,
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
;; 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."
user-source-registry
user-source-registry-directory
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-directory* #p"source-registry.conf.d/")
......@@ -2891,8 +2877,7 @@ with a different configuration, so the configuration would be re-read then."
(flatten-source-registry
`(wrapping-source-registry
,parameter
,@*default-source-registries*
default-source-registry)))
,@*default-source-registries*)))
(simplified
(remove-duplicates flattened :test 'equal :from-end nil))
(processed
......
......@@ -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
@enumerate
@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.
@item
This pathname information will not be overwritten with
......@@ -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,
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.
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
@defun clear-source-registry
......@@ -1708,31 +1717,11 @@ and for XCVB the corresponding functions are in package XCVB.
where to look for systems not yet defined.
@end defun
@defun ensure-source-registry
@defun ensure-source-registry PARAMETER
checks whether a source registry has been initialized.
If not, initialize it.
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.
If not, initialize it with the given @var{PARAMETER}.
@end defun
@section Future
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.
The specified functions are exported from package ASDF.
@defun initialize-output-translations PARAMETER
will read the configuration and initialize all internal variables.
You may extend or override configuration
......
......@@ -284,6 +284,11 @@
make-pathname)
(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)
(leave-lisp "test failed" 1)))
......
......@@ -5,7 +5,6 @@
# - quit with exit status 0 on getting eof
# - quit with exit status >0 if an unhandled error occurs
export CL_SOURCE_REGISTRY="$PWD"
unset DEBUG_ASDF_TEST
while getopts "duh" OPTION
......@@ -51,10 +50,12 @@ usage () {
echo " -u -h -- show this message."
}
DO () { ( set -x ; "$@" ); }
do_tests() {
command="$1" eval="$2"
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
echo "Compilation FAILED" >&2
else
......@@ -68,7 +69,7 @@ do_tests() {
echo "Testing: $i" >&2
test_count=`expr "$test_count" + 1`
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
test_pass=`expr "$test_pass" + 1`
else
......@@ -104,54 +105,50 @@ fi
command= flags= nodebug= eval=
case "$lisp" in
sbcl)
command=sbcl
command="${SBCL:-sbcl}"
flags="--noinform --userinit /dev/null --sysinit /dev/null"
nodebug="--disable-debugger"
eval="--eval" ;;
clisp)
command=clisp
command="${CLISP:-clisp}"
flags="-norc -ansi -I "
nodebug="-on-error exit"
eval="-x" ;;
allegro)
command=alisp
command="${ALLEGRO:-alisp}"
flags="-q"
nodebug="-batch"
eval="-e" ;;
allegromodern)
command=mlisp
command="${ALLEGROMODERN:-mlisp}"
flags="-q"
nodebug="-batch"
eval="-e" ;;
ccl)
command=ccl
command="${CCL:-ccl}"
flags="--no-init --quiet"
nodebug="--batch"
eval="--eval" ;;
cmucl)
command=lisp
command="${CMUCL:-lisp}"
flags="-noinit"
nodebug="-batch"
eval="-eval" ;;
ecl)
#if [ -x /usr/lib/ecl/ecl-original ] ; then
# command=/usr/lib/ecl/ecl-original
#else
command=ecl
#fi
command="${ECL:-ecl}"
flags="-norc"
eval="-eval" ;;
lispworks)
command=lispworks
command="${LISPWORKS:-lispworks}"
flags="-siteinit - -init -"
eval="-eval" ;;
gclcvs)
export GCL_ANSI=t
command=gclcvs
command="${GCL:-gclcvs}"
flags="-batch"
eval="-eval" ;;
abcl)
command=abcl
command="${ABCL:-abcl}"
eval="--eval" ;;
*)
echo "Unsupported lisp: $1" >&2
......@@ -164,10 +161,17 @@ if ! type "$command" ; then
exit 43
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
command="$command $nodebug"
fi
create_config () {
mkdir -p ../tmp/test-source-registry-conf.d ../tmp/test-asdf-output-translations-conf.d
}
......@@ -181,8 +185,6 @@ if [ -z "$command" ] ; then
else
create_config
mkdir -p results
command="$command $flags"
echo $command
thedate=`date "+%Y-%m-%d"`
do_tests "$command" "$eval" 2>&1 | \
tee "results/${lisp}.text" "results/${lisp}-${thedate}.save"
......
......@@ -10,10 +10,8 @@
*load-truename*)))
(defvar *asdf-fasl*
(compile-file-pathname
(merge-pathnames
(make-pathname :directory '(:relative "tmp")
:name (format nil "asdf-~(~A~)"
(or #+allegro (format nil "~Alisp" excl:*current-case-mode*)
(let ((impl (string-downcase
(or #+allegro (format nil "~Alisp" excl:*current-case-mode*)
#+armedbear :abcl
#+clisp :clisp
#+clozure :ccl
......@@ -24,9 +22,11 @@
#+gcl :gcl
#+lispworks :lispworks
#+sbcl :sbcl
#+scl scl))
:defaults *asdf-lisp*)
*asdf-lisp*)))
#+scl scl))))
(merge-pathnames
(make-pathname :directory `(:relative "tmp" "fasls" ,impl)
:defaults *asdf-lisp*)
*asdf-lisp*))))
(defun load-asdf ()
(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