Commit 826b12b0 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

1.636: do without asdf:around method qualifier, instead use perform-with-restarts method.

Treat :unspecific specially in merge-pathnames wrt logical-pathnames, use it in split-name-type.
Add protocol to short-circuit output translation.
Some updates to the documentation manual.
Add testing support for gclcvs (though it currently fails bigtime).
Refactor run-tests to to remove need to know $fasl_ext.
parent 29ea7dcd
......@@ -85,6 +85,10 @@
(unintern sym package))))
(ensure-unintern (package symbols)
(dolist (sym symbols) (remove-symbol sym package)))
(ensure-fmakunbound (package symbols)
(loop :for name :in symbols
:for sym = (find-symbol (string name) package)
:when sym :do (fmakunbound sym)))
(ensure-shadow (package symbols)
(shadow symbols package))
(ensure-use (package use)
......@@ -101,9 +105,10 @@
(remove-symbol sym package)))
(dolist (sym syms)
(export sym package))))
(ensure-package (name &key nicknames use unintern shadow export)
(ensure-package (name &key nicknames use unintern fmakunbound shadow export)
(let ((p (ensure-exists name nicknames use)))
(ensure-unintern p unintern)
(ensure-fmakunbound p fmakunbound)
(ensure-shadow p shadow)
(ensure-export p export)
p)))
......@@ -141,13 +146,14 @@
':asdf
:use '(:common-lisp :asdf-utilities)
:unintern '(#:*asdf-revision*)
:fmakunbound '(#:perform #:explain #:output-files #:operation-done-p)
:export
'(#:defsystem #:oos #:operate #:find-system #:run-shell-command
#:system-definition-pathname #:find-component ; miscellaneous
#:compile-system #:load-system #:test-system
#:compile-op #:load-op #:load-source-op
#:test-op
#:operation ; operations
#:operation ; operations
#:feature ; sort-of operation
#:version ; metaphorically sort-of an operation
......@@ -217,9 +223,6 @@
#:coerce-entry-to-directory
#:remove-entry-from-registry
#:standard-asdf-method-combination
#:around ; protocol assistants
#:initialize-output-translations
#:clear-output-translations
#:ensure-output-translations
......@@ -247,7 +250,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.635" (1+ (length "VERSION"))))
(subseq "VERSION:1.636" (1+ (length "VERSION"))))
(defun asdf-version ()
"Exported interface to the version of ASDF currently installed. A string.
......@@ -268,7 +271,7 @@ Defaults to `t`.")
(defvar *verbose-out* nil)
(defparameter +asdf-methods+
'(perform explain output-files operation-done-p))
'(perform-with-restarts perform explain output-files operation-done-p))
#+allegro
(eval-when (:compile-toplevel :execute)
......@@ -300,57 +303,15 @@ Defaults to `t`.")
(let ((system-p (getf plist 'system-p)))
(when system-p (setf (getf (slot-value c 'flags) :system-p) system-p))))))
;;;; -------------------------------------------------------------------------
;;;; CLOS magic for asdf:around methods
(define-method-combination standard-asdf-method-combination ()
((around-asdf (around))
(around (:around))
(before (:before))
(primary () :required t)
(after (:after)))
(flet ((call-methods (methods)
(mapcar #'(lambda (method)
`(call-method ,method))
methods)))
(let* ((form (if (or before after (rest primary))
`(multiple-value-prog1
(progn ,@(call-methods before)
(call-method ,(first primary)
,(rest primary)))
,@(call-methods (reverse after)))
`(call-method ,(first primary))))
(standard-form (if around
`(call-method ,(first around)
(,@(rest around)
(make-method ,form)))
form)))
(if around-asdf
`(call-method ,(first around-asdf)
(,@(rest around-asdf) (make-method ,standard-form)))
standard-form))))
(setf (documentation 'standard-asdf-method-combination
'method-combination)
"This method combination is based on the standard method combination,
but defines a new method-qualifier, `asdf:around`. `asdf:around`
methods will be run *around* any `:around` methods, so that the core
protocol may employ around methods and those around methods will not
be overridden by around methods added by a system developer.")
;;;; -------------------------------------------------------------------------
;;;; ASDF Interface, in terms of generic functions.
(defgeneric perform (operation component)
(:method-combination standard-asdf-method-combination))
(defgeneric operation-done-p (operation component)
(:method-combination standard-asdf-method-combination))
(defgeneric explain (operation component)
(:method-combination standard-asdf-method-combination))
(defgeneric output-files (operation component)
(:method-combination standard-asdf-method-combination))
(defgeneric input-files (operation component)
(:method-combination standard-asdf-method-combination))
(defgeneric perform-with-restarts (operation component))
(defgeneric perform (operation component))
(defgeneric operation-done-p (operation component))
(defgeneric explain (operation component))
(defgeneric output-files (operation component))
(defgeneric input-files (operation component))
(defgeneric system-source-file (system)
(:documentation "Return the source file in which system is defined."))
......@@ -440,27 +401,6 @@ The plan returned is a list of dotted-pairs. Each pair is the `cons`
of ASDF operation object and a `component` object. The pairs will be
processed in order by `operate`."))
(defgeneric output-files-using-mappings (source possible-paths path-mappings)
(:documentation
"Use the variable \\*source-to-target-mappings\\* to find
an output path for the source. The algorithm transforms each
entry in possible-paths as follows: If there is a mapping
whose source starts with the path of possible-path, then
replace possible-path with a pathname that starts with the
target of the mapping and continues with the rest of
possible-path. If no such mapping is found, then use the
default mapping.
If \\*centralize-lisp-binaries\\* is false, then the default
mapping is to place the output in a subdirectory of the
source. The subdirectory is named using the Lisp
implementation \(see
implementation-specific-directory-name\). If
\\*centralize-lisp-binaries\\* is true, then the default
mapping is to place the output in subdirectories of
\\*default-toplevel-directory\\* where the subdirectory
structure will mirror that of the source."))
;;;; -------------------------------------------------------------------------
;;;; General Purpose Utilities
......@@ -499,22 +439,31 @@ does not have an absolute directory, then the HOST and DEVICE come from the DEFA
(name (or (pathname-name specified) (pathname-name defaults)))
(type (or (pathname-type specified) (pathname-type defaults)))
(version (or (pathname-version specified) (pathname-version defaults))))
(multiple-value-bind (host device directory)
(ecase (first directory)
((nil)
(values (pathname-host defaults)
(pathname-device defaults)
(pathname-directory defaults)))
((:absolute)
(values (pathname-host specified)
(pathname-device specified)
directory))
((:relative)
(values (pathname-host defaults)
(pathname-device defaults)
(append (pathname-directory defaults) (cdr directory)))))
(make-pathname :host host :device device :directory directory
:name name :type type :version version))))
(labels ((ununspecific (x)
(if (eq x :unspecific) nil x))
(unspecific-handler (p)
(if (typep p 'logical-pathname) #'ununspecific #'identity)))
(multiple-value-bind (host device directory unspecific-handler)
(ecase (first directory)
((nil)
(values (pathname-host defaults)
(pathname-device defaults)
(pathname-directory defaults)
(unspecific-handler defaults)))
((:absolute)
(values (pathname-host specified)
(pathname-device specified)
directory
(unspecific-handler specified)))
((:relative)
(values (pathname-host defaults)
(pathname-device defaults)
(append (pathname-directory defaults) (cdr directory))
(unspecific-handler defaults))))
(make-pathname :host host :device device :directory directory
:name (funcall unspecific-handler name)
:type (funcall unspecific-handler type)
:version (funcall unspecific-handler version))))))
(define-modify-macro appendf (&rest args)
append "Append onto list")
......@@ -546,10 +495,10 @@ starting the separation from the end, e.g. when called with arguments
(setf end start))))))
(defun split-name-type (filename)
(destructuring-bind (name &optional type)
(destructuring-bind (name &optional (type :unspecific))
(split-string filename :max 2 :separator ".")
(if (equal name "")
(values filename nil)
(values filename :unspecific)
(values name type))))
(defun component-name-to-pathname-components (s &optional force-directory)
......@@ -1193,7 +1142,7 @@ to `~a` which is not a directory.~@:>"
&allow-other-keys)
(declare (ignorable operation slot-names force))
;; empty method to disable initarg validity checking
)
(values))
(defun node-for (o c)
(cons (class-name (class-of o)) c))
......@@ -1594,7 +1543,10 @@ recursive calls to traverse.")
:collect (let ((output (compile-file-pathname i)))
(load output))))
(defmethod perform around ((o load-op) (c cl-source-file))
(defmethod perform-with-restarts (operation component)
(perform operation component))
(defmethod perform-with-restarts :around ((o load-op) (c cl-source-file))
(let ((state :initial))
(loop :until (or (eq state :success)
(eq state :failure)) :do
......@@ -1605,7 +1557,7 @@ recursive calls to traverse.")
(setf state :success))
(:failed-load
(setf state :recompiled)
(perform (make-instance 'asdf:compile-op) c))
(perform (make-instance 'compile-op) c))
(t
(with-simple-restart
(try-recompiling "Recompile ~a and try loading it again"
......@@ -1614,7 +1566,7 @@ recursive calls to traverse.")
(call-next-method)
(setf state :success)))))))
(defmethod perform around ((o compile-op) (c cl-source-file))
(defmethod perform-with-restarts :around ((o compile-op) (c cl-source-file))
(let ((state :initial))
(loop :until (or (eq state :success)
(eq state :failure)) :do
......@@ -1625,7 +1577,7 @@ recursive calls to traverse.")
(setf state :success))
(:failed-compile
(setf state :recompiled)
(perform (make-instance 'asdf:compile-op) c))
(perform-with-restarts o c))
(t
(with-simple-restart
(try-recompiling "Try recompiling ~a"
......@@ -1717,7 +1669,7 @@ recursive calls to traverse.")
(loop :for (op . component) :in steps :do
(loop
(restart-case
(progn (perform op component)
(progn (perform-with-restarts op component)
(return))
(retry ()
:report
......@@ -2536,9 +2488,15 @@ return the configuration"
:return (translate-pathname path source destination)
:finally (return path)))))
(defmethod output-files :around ((op operation) (c component))
"Method to rewrite output files to fasl-root"
(mapcar #'apply-output-translations (call-next-method)))
(defmethod output-files :around (operation component)
"Translate output files, unless asked not to"
(declare (ignorable operation component))
(values
(multiple-value-bind (files fixedp) (call-next-method)
(if fixedp
files
(mapcar #'apply-output-translations files)))
t))
(defun compile-file-pathname* (input-file &rest keys)
(apply-output-translations
......
......@@ -152,14 +152,14 @@ the ASDF internals and how to extend ASDF.
NOTA BENE:
We are preparing for a release of ASDF 2,
which will have version 2.000 and later.
Releases in the 1.6xx series and beyond should be considered as
Releases in the 1.600 series and beyond should be considered as
release candidates,
but we're still working on documentation,
and on fixing the occasional bug.
For all practical purposes, ASDF 2 refers to releases later than 1.634,
and ASDF 1 to any release earlier than 1.369 or so.
ASDF 2.0 release candidates and beyond will have
ASDF 2.000 release candidates and beyond will have
@code{:asdf2} onto @code{*features*} so that if you are writing
ASDF-dependent code you may check for this feature to see if the new API
is present. @emph{All} versions of ASDF should have the @code{:asdf} feature.
......@@ -221,8 +221,8 @@ or none at all:
@lisp
(let* ((a (find-package :asdf))
(v (and a (find-symbol (symbol-name :asdf-version) a))))
(cond (v (funcall v))(a :old)))
(v (and a (find-symbol (symbol-name :asdf-version) a))))
(cond (v (funcall v))(a :old)))
@end lisp
If it returns a version number, that's the version of ASDF installed.
......@@ -418,7 +418,7 @@ by plenty of object files.
Starting with ASDF 1.600, the @code{asdf-output-translations} facility
was added to ASDF itself, that controls where object files will be stored.
This facility is fully described in a chapter of this manual,
This facility is fully described in a chapter of this manual,
@ref{Controlling where ASDF saves compiled files}.
The simplest way to add a translation to your search path,
......@@ -793,6 +793,13 @@ Therefore, it is a rare case that pathname objects should be used at all.
Unhappily, old versions of ASDF (before 1.600) didn't properly support
parsing component names as strings specifying paths with directories,
and the cumbersome @code{#.(make-pathname ...)} syntax had to be used.
Note that when specifying pathname objects, no magic interpretation of the pathname
is made depending on the component type.
On the one hand, you have to be careful to provide a pathname that correctly
fulfills whatever constraints are required from that component type
(e.g. naming a directory or a file with appropriate type);
on the other hand, you can circumvent the file type that would otherwise
be forced upon you if you were specifying a string.
@subsection Warning about logical pathnames
......@@ -1109,6 +1116,13 @@ when invoked with an object of type @code{source-file}:
@itemize
@item @code{output-files}
The @code{output-files} method determines where the method will put its files.
It returns two values, a list of pathnames, and a boolean.
If the boolean is @code{T} then the pathnames are marked
not be translated by enclosing @code{:around} methods.
If the boolean is @code{NIL} then enclosing @code{:around} methods
may translate these pathnames, e.g. to ensure object files
are somehow stored in some implementation-dependent cache.
@item @code{perform}
The @code{perform} method must call @code{output-files}
to find out where to put its files,
......@@ -1434,7 +1448,7 @@ purposes; these are given elsewhere.
@xref{The defsystem grammar}.
Users can create new classes for their systems:
the default @code{defsystem} macro takes a @code{:classs} keyword argument.
the default @code{defsystem} macro takes a @code{:class} keyword argument.
@end deffn
@node Creating new component types, , Pre-defined subclasses of component, Components
......@@ -1455,7 +1469,7 @@ We create a subclass of
@lisp
(defclass unportable-cl-source-file (cl-source-file)
())
())
@end lisp
A hypothetical function @code{system-dependent-dirname}
......@@ -1467,7 +1481,7 @@ of an @code{unportable-cl-source-file}.
(defmethod component-pathname ((component unportable-cl-source-file))
(let ((pathname (call-next-method))
(name (string-downcase (system-dependent-dirname))))
(merge-pathnames
(merge-pathnames*
(make-pathname :directory (list :relative name))
pathname)))
@end lisp
......@@ -1494,7 +1508,7 @@ The new component type is used in a @code{defsystem} form in this way:
Configurations specify paths where to find system files.
1- An application may explicitly initialize the source-registry
configuration using the configuration API
configuration using the configuration API
(@pxref{Controlling where ASDF searches for systems,Configuration API,Configuration API}, below)
in which case this takes precedence.
It may itself compute this configuration from the command-line,
......
......@@ -52,8 +52,8 @@ usage () {
}
do_tests() {
command=$1 eval=$2 fasl_ext=$3
rm -f *.$fasl_ext ~/.cache/common-lisp/"`pwd`"/*.$fasl_ext || true
command=$1 eval=$2
rm -f ~/.cache/common-lisp/"`pwd`"/* || true
( cd .. && $command $eval '(load "test/compile-asdf.lisp")' )
if [ $? -ne 0 ] ; then
echo "Compilation FAILED" >&2
......@@ -67,7 +67,7 @@ do_tests() {
do
echo "Testing: $i" >&2
test_count=`expr "$test_count" + 1`
rm -f *.$fasl_ext ~/.cache/common-lisp/"`pwd`"/*.$fasl_ext || true
rm -f ~/.cache/common-lisp/"`pwd`"/* || true
if $command $eval "(load \"$i\")" ; then
echo "Using $command, $i passed" >&2
test_pass=`expr "$test_pass" + 1`
......@@ -104,67 +104,48 @@ fi
command=
case "$lisp" in
sbcl)
if type sbcl ; then
fasl_ext="fasl"
command="sbcl --noinform --userinit /dev/null --sysinit /dev/null"
nodebug="--disable-debugger"
eval="--eval"
fi ;;
command=sbcl
flags="--noinform --userinit /dev/null --sysinit /dev/null"
nodebug="--disable-debugger"
eval="--eval" ;;
clisp)
if type clisp ; then
fasl_ext="fas"
command="clisp -norc -ansi -I "
nodebug="-on-error exit"
eval="-x"
fi ;;
command=clisp
flags="-norc -ansi -I "
nodebug="-on-error exit"
eval="-x" ;;
allegro)
if type alisp ; then
fasl_ext="fasl"
command="alisp -q "
nodebug="-batch"
eval="-e"
fi ;;
command=alisp
flags="-q"
nodebug="-batch"
eval="-e" ;;
allegromodern)
if type mlisp ; then
fasl_ext="fasl"
command="mlisp -q"
nodebug="-batch"
eval="-e"
fi ;;
command=mlisp
flags="-q"
nodebug="-batch"
eval="-e" ;;
ccl)
if type ccl ; then
case `uname -s` in
Linux) fasl_os=lx ;;
Darwin) fasl_os=dx ;;
esac
case `uname -m` in
x86_64|ppc64) fasl_bits=64 ;;
i?86|ppc) fasl_bits=32 ;;
esac
fasl_ext="${fasl_os}${fasl_bits}fsl"
command="ccl --no-init --quiet"
nodebug="--batch"
eval="--eval"
fi ;;
command=ccl
flags="--no-init --quiet"
nodebug="--batch"
eval="--eval" ;;
cmucl)
if type lisp ; then
fasl_ext="x86f"
command="lisp -noinit"
nodebug="-batch"
eval="-eval"
fi ;;
command=lisp
flags="-noinit"
nodebug="-batch"
eval="-eval" ;;
ecl)
if type ecl ; then
fasl_ext="fas"
command="ecl -norc"
eval="-eval"
fi ;;
command=ecl
flags="-norc"
eval="-eval" ;;
lispworks)
if type lispworks ; then
fasl_ext="ofasl"
command="lispworks -siteinit - -init -"
eval="-eval"
fi ;;
command=lispworks
flags="-siteinit - -init -"
eval="-eval" ;;
gclcvs)
export GCL_ANSI=t
command=gclcvs
flags="-q"
eval="-eval" ;;
*)
echo "Unsupported lisp: $1" >&2
echo "Please add support to run-tests.sh" >&2
......@@ -172,7 +153,11 @@ case "$lisp" in
esac
if [ -z "$command" ] ; then
echo "lisp implementation not found: $1" >&2
echo "lisp implementation not recognized: $1" >&2
exit 43
fi
if ! type "$command" ; then
echo "lisp implementation not found: $command" >&2
exit 43
fi
......@@ -195,7 +180,7 @@ else
mkdir -p results
echo $command
thedate=`date "+%Y-%m-%d"`
do_tests "$command" "$eval" "$fasl_ext" 2>&1 | \
do_tests "$command" "$eval" 2>&1 | \
tee "results/${lisp}.text" "results/${lisp}-${thedate}.save"
clean_up
fi
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