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

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
Loading
Loading
Loading
Loading
+61 −103
Original line number Diff line number Diff line
@@ -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,6 +146,7 @@
     ':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
@@ -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)
    (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)))
                     (pathname-directory defaults)
                     (unspecific-handler defaults)))
            ((:absolute)
             (values (pathname-host specified)
                     (pathname-device specified)
                   directory))
                     directory
                     (unspecific-handler specified)))
            ((:relative)
             (values (pathname-host defaults)
                     (pathname-device defaults)
                   (append (pathname-directory defaults) (cdr directory)))))
                     (append (pathname-directory defaults) (cdr directory))
                     (unspecific-handler defaults))))
        (make-pathname :host host :device device :directory directory
                     :name name :type type :version version))))
                       :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
+23 −9
Original line number Diff line number Diff line
@@ -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.
@@ -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
@@ -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
+44 −59
Original line number Diff line number Diff 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"
    command=sbcl
    flags="--noinform --userinit /dev/null --sysinit /dev/null"
    nodebug="--disable-debugger"
      eval="--eval"
    fi ;;
    eval="--eval" ;;
  clisp)
    if type clisp ; then
	fasl_ext="fas"
	command="clisp -norc -ansi -I "
    command=clisp
    flags="-norc -ansi -I "
    nodebug="-on-error exit"
        eval="-x"
    fi ;;
    eval="-x" ;;
  allegro)
    if type alisp ; then
	fasl_ext="fasl"
	command="alisp -q "
    command=alisp
    flags="-q"
    nodebug="-batch"
        eval="-e"
    fi ;;
    eval="-e" ;;
  allegromodern)
    if type mlisp ; then
	fasl_ext="fasl"
	command="mlisp -q"
    command=mlisp
    flags="-q"
    nodebug="-batch"
        eval="-e"
    fi ;;
    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"
    command=ccl
    flags="--no-init --quiet"
    nodebug="--batch"
        eval="--eval"
    fi ;;
    eval="--eval" ;;
  cmucl)
    if type lisp ; then
	fasl_ext="x86f"
	command="lisp -noinit"
    command=lisp
    flags="-noinit"
    nodebug="-batch"
        eval="-eval"
    fi ;;
    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