From d324c0ad2d44dd18a4d3267ec49cfec205510805 Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <fare@tunes.org> Date: Tue, 16 Mar 2010 21:28:27 -0400 Subject: [PATCH] 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, --- asdf.lisp | 67 +++++++++++++--------------------- asdf.texinfo | 38 +++++++------------ test/asdf-pathname-test.script | 5 +++ test/run-tests.sh | 40 ++++++++++---------- test/script-support.lisp | 14 +++---- 5 files changed, 72 insertions(+), 92 deletions(-) diff --git a/asdf.lisp b/asdf.lisp index e4a7ff1e..2a27720c 100644 --- a/asdf.lisp +++ b/asdf.lisp @@ -1,9 +1,9 @@ ;;; -*- 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 diff --git a/asdf.texinfo b/asdf.texinfo index dc2d8eda..272f5f42 100644 --- a/asdf.texinfo +++ b/asdf.texinfo @@ -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 diff --git a/test/asdf-pathname-test.script b/test/asdf-pathname-test.script index 9f797a7f..6ee7af5a 100644 --- a/test/asdf-pathname-test.script +++ b/test/asdf-pathname-test.script @@ -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))) diff --git a/test/run-tests.sh b/test/run-tests.sh index 60273c04..829d282d 100755 --- a/test/run-tests.sh +++ b/test/run-tests.sh @@ -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" diff --git a/test/script-support.lisp b/test/script-support.lisp index 1c368903..14d9ab77 100644 --- a/test/script-support.lisp +++ b/test/script-support.lisp @@ -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*)) -- GitLab