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