Commit cd744408 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

Merge and rearrange patch by Mark Evenson allowing a translation function

as destination from output-translations, plus usage by default for jars in ABCL.
parent 90b15bf6
......@@ -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.
......
......@@ -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.
......
......@@ -153,6 +153,7 @@ case "$lisp" in
eval="-eval" ;;
abcl)
command="${ABCL:-abcl}"
flags="--noinit --noinform"
eval="--eval" ;;
*)
echo "Unsupported lisp: $1" >&2
......
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