Skip to content
Snippets Groups Projects
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
No related branches found
No related tags found
No related merge requests found
...@@ -2364,6 +2364,16 @@ with a different configuration, so the configuration would be re-read then." ...@@ -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)))) (flet ((componentp (c) (typep c '(or string pathname keyword))))
(or (null x) (componentp x) (and (consp x) (every #'componentp x))))) (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) (defun validate-output-translations-directive (directive)
(unless (unless
(or (member directive '(:inherit-configuration (or (member directive '(:inherit-configuration
...@@ -2374,7 +2384,8 @@ with a different configuration, so the configuration would be re-read then." ...@@ -2374,7 +2384,8 @@ with a different configuration, so the configuration would be re-read then."
(or (and (eq (first directive) :include) (or (and (eq (first directive) :include)
(typep (second directive) '(or string pathname null))) (typep (second directive) '(or string pathname null)))
(and (location-designator-p (first directive)) (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) (and (length=n-p directive 1)
(location-designator-p (first directive)))))) (location-designator-p (first directive))))))
(error "Invalid directive ~S~%" directive)) (error "Invalid directive ~S~%" directive))
...@@ -2447,6 +2458,8 @@ with a different configuration, so the configuration would be re-read then." ...@@ -2447,6 +2458,8 @@ with a different configuration, so the configuration would be re-read then."
#+sbcl (,(getenv "SBCL_HOME") ()) #+sbcl (,(getenv "SBCL_HOME") ())
#+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; only needed if LPNs are resolved manually. #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; only needed if LPNs are resolved manually.
#+clozure (,(wilden (ccl::ccl-directory)) ()) ; not needed: no precompiled ASDF system #+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: ;; All-import, here is where we want user stuff to be:
:inherit-configuration :inherit-configuration
;; If we want to enable the user cache by default, here would be the place: ;; 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." ...@@ -2512,11 +2525,17 @@ with a different configuration, so the configuration would be re-read then."
(when dst (when dst
(process-output-translations (pathname dst) :inherit nil :collect collect)) (process-output-translations (pathname dst) :inherit nil :collect collect))
(when src (when src
(let* ((trusrc (truenamize (resolve-location src t))) (let ((trusrc (truenamize (resolve-location src t))))
(trudst (if dst (resolve-location dst t) trusrc)) (if (location-function-p dst)
(wilddst (make-pathname :name :wild :type :wild :defaults trudst))) (funcall collect
(funcall collect (list wilddst wilddst)) (list trusrc
(funcall collect (list trusrc trudst)))))))) (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) (defun compute-output-translations (&optional parameter)
"read the configuration, return it" "read the configuration, return it"
...@@ -2552,11 +2571,14 @@ effectively disabling the output translation facility." ...@@ -2552,11 +2571,14 @@ effectively disabling the output translation facility."
path) path)
((or pathname string) ((or pathname string)
(ensure-output-translations) (ensure-output-translations)
(setf path (truenamize path)) (loop :with p = (truenamize path)
(loop :for (source destination) :in (car *output-translations*) :for (source destination) :in (car *output-translations*)
:when (pathname-match-p path source) :when (pathname-match-p p source)
:return (translate-pathname path source destination) :return
:finally (return path))))) (if (functionp destination)
(funcall destination p source)
(translate-pathname p source destination))
:finally (return p)))))
(defmethod output-files :around (operation component) (defmethod output-files :around (operation component)
"Translate output files, unless asked not to" "Translate output files, unless asked not to"
...@@ -2574,6 +2596,18 @@ effectively disabling the output translation facility." ...@@ -2574,6 +2596,18 @@ effectively disabling the output translation facility."
(truenamize (lispize-pathname input-file)) (truenamize (lispize-pathname input-file))
keys))) 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 ;;;; Compatibility mode for ASDF-Binary-Locations
...@@ -2950,10 +2984,15 @@ with a different configuration, so the configuration would be re-read then." ...@@ -2950,10 +2984,15 @@ with a different configuration, so the configuration would be re-read then."
;;;; ----------------------------------------------------------------- ;;;; -----------------------------------------------------------------
;;;; SBCL and ClozureCL hook into REQUIRE ;;;; SBCL and ClozureCL hook into REQUIRE
;;;; ;;;;
#+(or sbcl clozure) #+(or sbcl clozure abcl)
(progn (progn
(defun module-provide-asdf (name) (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)) (let* ((*verbose-out* (make-broadcast-stream))
(system (asdf:find-system name nil))) (system (asdf:find-system name nil)))
(when system (when system
...@@ -2961,7 +3000,8 @@ with a different configuration, so the configuration would be re-read then." ...@@ -2961,7 +3000,8 @@ with a different configuration, so the configuration would be re-read then."
t)))) t))))
(pushnew 'module-provide-asdf (pushnew 'module-provide-asdf
#+sbcl sb-ext:*module-provider-functions* #+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. ;;;; Cleanups after hot-upgrade.
......
...@@ -802,7 +802,7 @@ qual := method qualifier ...@@ -802,7 +802,7 @@ qual := method qualifier
Component names (@code{simple-component-name}) Component names (@code{simple-component-name})
may be either strings or symbols. may be either strings or symbols.
@subsection Component types @subsection Component types
Component type names, even if expressed as keywords, will be looked up 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 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. ...@@ -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, Thus for ASDF the corresponding functions are in package ASDF,
and for XCVB the corresponding functions are in package XCVB. 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. will read the configuration and initialize all internal variables.
You may extend or override configuration You may extend or override configuration
from the environment and configuration files from the environment and configuration files
...@@ -1851,7 +1851,7 @@ and for XCVB the corresponding functions are in package XCVB. ...@@ -1851,7 +1851,7 @@ and for XCVB the corresponding functions are in package XCVB.
where to look for systems not yet defined. where to look for systems not yet defined.
@end defun @end defun
@defun ensure-source-registry PARAMETER @defun ensure-source-registry @&optional PARAMETER
checks whether a source registry has been initialized. checks whether a source registry has been initialized.
If not, initialize it with the given @var{PARAMETER}. If not, initialize it with the given @var{PARAMETER}.
@end defun @end defun
...@@ -2120,6 +2120,8 @@ DIRECTIVE := ...@@ -2120,6 +2120,8 @@ DIRECTIVE :=
;; add a single directory to be scanned (no recursion) ;; add a single directory to be scanned (no recursion)
(DIRECTORY-DESIGNATOR DIRECTORY-DESIGNATOR) (DIRECTORY-DESIGNATOR DIRECTORY-DESIGNATOR)
;; use a function to return the translation of a directory designator
(DIRECTORY-DESIGNATOR (:function TRANSLATION-FUNCTION))
DIRECTORY-DESIGNATOR := DIRECTORY-DESIGNATOR :=
ABSOLUTE-COMPONENT-DESIGNATOR | ABSOLUTE-COMPONENT-DESIGNATOR |
...@@ -2143,6 +2145,13 @@ RELATIVE-COMPONENT-DESIGNATOR := ...@@ -2143,6 +2145,13 @@ RELATIVE-COMPONENT-DESIGNATOR :=
:CURRENT-DIRECTORY | ;; all components of the current directory, without the :absolute :CURRENT-DIRECTORY | ;; all components of the current directory, without the :absolute
:UID | ;; current UID -- not available on Windows :UID | ;; current UID -- not available on Windows
:USER ;; current USER name -- NOT IMPLEMENTED(!) :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 @end verbatim
Relative components better be either relative 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 ...@@ -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 @code{:include} statements cause the search to recurse with the path specifications
from the file specified. 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 An @code{:inherit-configuration} statement cause the search to recurse with the path
specifications from the next configuration. specifications from the next configuration.
@xref{Controlling where ASDF saves compiled files,,Configurations}, above. @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. ...@@ -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. 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. will read the configuration and initialize all internal variables.
You may extend or override configuration You may extend or override configuration
from the environment and configuration files from the environment and configuration files
...@@ -2294,7 +2314,7 @@ The specified functions are exported from package ASDF. ...@@ -2294,7 +2314,7 @@ The specified functions are exported from package ASDF.
where to look for systems not yet defined. where to look for systems not yet defined.
@end defun @end defun
@defun ensure-output-translations PARAMETER @defun ensure-output-translations @&optional PARAMETER
checks whether output translations have been initialized. checks whether output translations have been initialized.
If not, initialize them with the given @var{PARAMETER}. If not, initialize them with the given @var{PARAMETER}.
This function will be called before any attempt to operate on a system. This function will be called before any attempt to operate on a system.
......
...@@ -153,6 +153,7 @@ case "$lisp" in ...@@ -153,6 +153,7 @@ case "$lisp" in
eval="-eval" ;; eval="-eval" ;;
abcl) abcl)
command="${ABCL:-abcl}" command="${ABCL:-abcl}"
flags="--noinit --noinform"
eval="--eval" ;; eval="--eval" ;;
*) *)
echo "Unsupported lisp: $1" >&2 echo "Unsupported lisp: $1" >&2
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment