diff --git a/asdf.lisp b/asdf.lisp index 384e31fcba231f956ea8047b4e2a101227b18dc8..239949555517598e8d05770e429d3cde2a9c7b56 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 b75e94adf87be27caa4d963501b5787c8cd331ac..73e0d1610d8f5826901fc408bf243466cff49999 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 3ec637bf07f4a9e1543a63625747641dfcce8267..da2ba6821e18db1695cc061a7574e33c7459b958 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