From cd744408461ae3d6c2ca53a211d65b4761f2a0ff Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <fare@tunes.org>
Date: Mon, 5 Apr 2010 14:56:51 -0400
Subject: [PATCH] Merge and rearrange patch by Mark Evenson allowing a
 translation function as destination from output-translations, plus usage by
 default for jars in ABCL.

---
 asdf.lisp         | 68 +++++++++++++++++++++++++++++++++++++----------
 doc/asdf.texinfo  | 30 +++++++++++++++++----
 test/run-tests.sh |  1 +
 3 files changed, 80 insertions(+), 19 deletions(-)

diff --git a/asdf.lisp b/asdf.lisp
index 384e31fc..23994955 100644
--- a/asdf.lisp
+++ b/asdf.lisp
@@ -2364,6 +2364,16 @@ with a different configuration, so the configuration would be re-read then."
   (flet ((componentp (c) (typep c '(or string pathname keyword))))
     (or (null x) (componentp x) (and (consp x) (every #'componentp x)))))
 
+(defun location-function-p (x)
+  (and
+   (consp x)
+   (length=n-p x 2)
+   (or (and (equal (first x) :function)
+            (typep (second x) 'symbol))
+       (and (equal (first x) 'lambda)
+            (cddr x)
+            (length=n-p (second x) 2)))))
+
 (defun validate-output-translations-directive (directive)
   (unless
       (or (member directive '(:inherit-configuration
@@ -2374,7 +2384,8 @@ with a different configuration, so the configuration would be re-read then."
                         (or (and (eq (first directive) :include)
                                  (typep (second directive) '(or string pathname null)))
                             (and (location-designator-p (first directive))
-                                 (location-designator-p (second directive)))))
+                                 (or (location-designator-p (second directive))
+                                     (location-function-p (second directive))))))
                    (and (length=n-p directive 1)
                         (location-designator-p (first directive))))))
     (error "Invalid directive ~S~%" directive))
@@ -2447,6 +2458,8 @@ with a different configuration, so the configuration would be re-read then."
     #+sbcl (,(getenv "SBCL_HOME") ())
     #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; only needed if LPNs are resolved manually.
     #+clozure (,(wilden (ccl::ccl-directory)) ()) ; not needed: no precompiled ASDF system
+    #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
+    #+abcl (#p"/:jar:file/**/*.*" (:user-cache #p"**/*.*"))
     ;; All-import, here is where we want user stuff to be:
     :inherit-configuration
     ;; If we want to enable the user cache by default, here would be the place:
@@ -2512,11 +2525,17 @@ with a different configuration, so the configuration would be re-read then."
             (when dst
               (process-output-translations (pathname dst) :inherit nil :collect collect))
             (when src
-              (let* ((trusrc (truenamize (resolve-location src t)))
-                     (trudst (if dst (resolve-location dst t) trusrc))
-                     (wilddst (make-pathname :name :wild :type :wild :defaults trudst)))
-                (funcall collect (list wilddst wilddst))
-                (funcall collect (list trusrc trudst))))))))
+              (let ((trusrc (truenamize (resolve-location src t))))
+                (if (location-function-p dst)
+                    (funcall collect
+                             (list trusrc
+                                   (if (symbolp (second dst))
+                                       (fdefinition (second dst))
+                                       (eval (second dst)))))
+                    (let* ((trudst (if dst (resolve-location dst t) trusrc))
+                           (wilddst (make-pathname :name :wild :type :wild :defaults trudst)))
+                      (funcall collect (list wilddst wilddst))
+                      (funcall collect (list trusrc trudst))))))))))
 
 (defun compute-output-translations (&optional parameter)
   "read the configuration, return it"
@@ -2552,11 +2571,14 @@ effectively disabling the output translation facility."
      path)
     ((or pathname string)
      (ensure-output-translations)
-     (setf path (truenamize path))
-     (loop :for (source destination) :in (car *output-translations*)
-       :when (pathname-match-p path source)
-       :return (translate-pathname path source destination)
-       :finally (return path)))))
+     (loop :with p = (truenamize path)
+       :for (source destination) :in (car *output-translations*)
+       :when (pathname-match-p p source)
+       :return
+        (if (functionp destination)
+            (funcall destination p source)
+            (translate-pathname p source destination))
+       :finally (return p)))))
 
 (defmethod output-files :around (operation component)
   "Translate output files, unless asked not to"
@@ -2574,6 +2596,18 @@ effectively disabling the output translation facility."
           (truenamize (lispize-pathname input-file))
           keys)))
 
+(defun translate-jar-pathname (source wildcard)
+  (declare (ignore wildcard))
+  (let ((root (apply-output-translations
+               (concatenate 'string
+                            "/:jar:file/"
+                            (namestring (first (pathname-device
+                                                source))))))
+        (entry (make-pathname :directory (pathname-directory source)
+                              :name (pathname-name source)
+                              :type (pathname-type source))))
+    (concatenate 'string (namestring root) (namestring entry))))
+
 ;;;; -----------------------------------------------------------------
 ;;;; Compatibility mode for ASDF-Binary-Locations
 
@@ -2950,10 +2984,15 @@ with a different configuration, so the configuration would be re-read then."
 ;;;; -----------------------------------------------------------------
 ;;;; SBCL and ClozureCL hook into REQUIRE
 ;;;;
-#+(or sbcl clozure)
+#+(or sbcl clozure abcl)
 (progn
   (defun module-provide-asdf (name)
-    (handler-bind ((style-warning #'muffle-warning))
+    (handler-bind
+        ((style-warning #'muffle-warning)
+         (missing-component (constantly nil))
+         (error (lambda (e)
+                  (format *error-output* "ASDF could not load ~A because ~A.~%"
+                          name e))))
       (let* ((*verbose-out* (make-broadcast-stream))
              (system (asdf:find-system name nil)))
         (when system
@@ -2961,7 +3000,8 @@ with a different configuration, so the configuration would be re-read then."
           t))))
   (pushnew 'module-provide-asdf
            #+sbcl sb-ext:*module-provider-functions*
-           #+clozure ccl::*module-provider-functions*))
+           #+clozure ccl::*module-provider-functions*
+           #+abcl sys::*module-provider-functions*))
 
 ;;;; -------------------------------------------------------------------------
 ;;;; Cleanups after hot-upgrade.
diff --git a/doc/asdf.texinfo b/doc/asdf.texinfo
index b75e94ad..73e0d161 100644
--- a/doc/asdf.texinfo
+++ b/doc/asdf.texinfo
@@ -802,7 +802,7 @@ qual := method qualifier
 Component names (@code{simple-component-name})
 may be either strings or symbols.
 
-@subsection Component types 
+@subsection Component types
 
 Component type names, even if expressed as keywords, will be looked up
 by name in the current package and in the asdf package, if not found in
@@ -1828,7 +1828,7 @@ 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 PARAMETER
+@defun initialize-source-registry @&optional PARAMETER
    will read the configuration and initialize all internal variables.
    You may extend or override configuration
    from the environment and configuration files
@@ -1851,7 +1851,7 @@ and for XCVB the corresponding functions are in package XCVB.
    where to look for systems not yet defined.
 @end defun
 
-@defun ensure-source-registry PARAMETER
+@defun ensure-source-registry @&optional PARAMETER
    checks whether a source registry has been initialized.
    If not, initialize it with the given @var{PARAMETER}.
 @end defun
@@ -2120,6 +2120,8 @@ DIRECTIVE :=
     ;; add a single directory to be scanned (no recursion)
     (DIRECTORY-DESIGNATOR DIRECTORY-DESIGNATOR)
 
+    ;; use a function to return the translation of a directory designator
+    (DIRECTORY-DESIGNATOR (:function TRANSLATION-FUNCTION))
 
 DIRECTORY-DESIGNATOR :=
     ABSOLUTE-COMPONENT-DESIGNATOR |
@@ -2143,6 +2145,13 @@ RELATIVE-COMPONENT-DESIGNATOR :=
     :CURRENT-DIRECTORY | ;; all components of the current directory, without the :absolute
     :UID | ;; current UID -- not available on Windows
     :USER ;; current USER name -- NOT IMPLEMENTED(!)
+
+TRANSLATION-FUNCTION :=
+    SYMBOL | ;; symbol of a function that takes two arguments,
+             ;; the pathname to be translated and the matching DIRECTORY-DESIGNATOR
+    LAMBDA   ;; A form which evalutates to a function taking two arguments consisting of
+             ;; the pathname to be translated and the matching DIRECTORY-DESIGNATOR
+
 @end verbatim
 
 Relative components better be either relative
@@ -2161,6 +2170,17 @@ to anything but themselves (same as if the second designator was the same as the
 @code{:include} statements cause the search to recurse with the path specifications
 from the file specified.
 
+If the @code{translate-pathname} mechanism cannot achieve a desired
+translation, the user may provide a function which provides the
+required algorithim.  Such a translation function is specified by
+supplying a list as the second @code{directory-designator} whose first
+element is the keyword @code{:function}, and whose second element is
+either a symbol which designates a function or a lambda expression.
+The function designated by the second argument must take two
+arguments, the first being the pathname of the source file, the second
+being the wildcard that was matched.  The result of the function
+invocation should be the translated pathname.
+
 An @code{:inherit-configuration} statement cause the search to recurse with the path
 specifications from the next configuration.
 @xref{Controlling where ASDF saves compiled files,,Configurations}, above.
@@ -2265,7 +2285,7 @@ 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
+@defun initialize-output-translations @&optional PARAMETER
    will read the configuration and initialize all internal variables.
    You may extend or override configuration
    from the environment and configuration files
@@ -2294,7 +2314,7 @@ The specified functions are exported from package ASDF.
    where to look for systems not yet defined.
 @end defun
 
-@defun ensure-output-translations PARAMETER
+@defun ensure-output-translations @&optional PARAMETER
    checks whether output translations have been initialized.
    If not, initialize them with the given @var{PARAMETER}.
    This function will be called before any attempt to operate on a system.
diff --git a/test/run-tests.sh b/test/run-tests.sh
index 3ec637bf..da2ba682 100755
--- a/test/run-tests.sh
+++ b/test/run-tests.sh
@@ -153,6 +153,7 @@ case "$lisp" in
     eval="-eval" ;;
   abcl)
     command="${ABCL:-abcl}"
+    flags="--noinit --noinform"
     eval="--eval" ;;
   *)
     echo "Unsupported lisp: $1" >&2
-- 
GitLab