Changeset 14278

Timestamp:

12/03/12 00:17:58 (9 years ago)

Author:

Mark Evenson

Message:

Sync to asdf-2.26.6.

Fixes #271.

Backport r14277.

Location:

branches/1.1.x

Files:

• doc/asdf/asdf.texinfo (modified) (18 diffs)
• src/org/armedbear/lisp/asdf.lisp (modified) (20 diffs)

branches/1.1.x/doc/asdf/asdf.texinfo

@@ -318 +318 @@
 Any ASDF extension becomes invalid, and will need to be reloaded.
 This applies to e.g. CFFI-Grovel, or to hacks used by ironclad, etc.
-Starting with ASDF 2.014.8, ASDF will actually invalidate
-all previously loaded systems when it is loaded on top of
-a different ASDF version.
+Starting with ASDF 2.014.8 (as far as releases go, 2.015),
+ASDF will actually invalidate all previously loaded systems
+when it is loaded on top of a different ASDF version.
 @item
 Until all implementations provide ASDF 2.015 or later,
@@ -342 +342 @@
   (error "FOO requires ASDF ~A or later." *required-asdf-version*))
 @end example
+@item
+Until all implementations provide ASDF 2.27 or later,
+it is unsafe for a system to transitively depend on ASDF
+and not directly depend on ASDF;
+if any of the system you use either depends-on asdf,
+system-depends-on asdf, or transitively does,
+you should also do as well.
 @end itemize
 
@@ -638 +645 @@
 
 On some implementations (namely recent versions of
-ABCL, Allegro CL, Clozure CL, CMUCL, ECL, GNU CLISP, LispWorks, MKCL, SBCL and XCL),
+ABCL, Allegro CL, Clozure CL, CMUCL, ECL, GNU CLISP,
+LispWorks, MKCL, SBCL and XCL),
 ASDF hooks into the @code{CL:REQUIRE} facility
 and you can just use:
@@ -689 +697 @@
 @xref{Configuring ASDF,,Configuring ASDF to find your systems}.
 
+For the advanced users, note that
+@code{require-system} calls @code{load-system}
+with keyword arguments @code{:force-not (loaded-systems)}.
+@code{loaded-systems} returns a list of the names of loaded systems.
+@code{load-system} applies @code{operate} with the operation from
+@code{*load-system-operation*}, which by default is @code{load-op},
+the system, and any provided keyword arguments.
 
 @section Summary
@@ -1310 +1325 @@
 Operations are invoked on systems via @code{operate}.
 @anchor{operate}
-@deffn {Generic function} @code{operate} @var{operation} @var{system} @&rest @var{initargs}
-@deffnx {Generic function} @code{oos} @var{operation} @var{system} @&rest @var{initargs}
+@deffn {Generic function} @code{operate} @var{operation} @var{system} @&rest @var{initargs} @&key @code{force} @code{force-not} @code{verbose} @&allow-other-keys
+@deffnx {Generic function} @code{oos} @var{operation} @var{system} @&rest @var{initargs} @&key @&allow-other-keys
 @code{operate} invokes @var{operation} on @var{system}.
 @code{oos} is a synonym for @code{operate}.
@@ -1326 +1341 @@
 with the same @var{initargs} as the original one.
 
+If @var{force} is @code{t}, then all systems
+are forced to be recompiled even if not modified since last compilation.
+If @var{force} is a list, then it specifies a list of systems that
+are forced to be recompiled even if not modified since last compilation.
+If @var{force-not} is @code{t}, then all systems
+are forced not to be recompiled even if modified since last compilation.
+If @var{force-not} is a list, then it specifies a list of systems that
+are forced not to be recompiled even if modified since last compilation.
+@var{force} takes precedences over @var{force-not};
+both of them apply to systems that are dependencies and were already compiled.
 @end deffn
 
@@ -2887 +2912 @@
 A non-nil value designates a function of one argument
 that will be called with a function that
-calls the @code{*compile-op-compile-file-function*} (usually @code{compile-file*})
+calls the @code{*compile-op-compile-file-function*}
+(usually @code{compile-file*})
 with proper arguments;
 the around-compile hook may supply additional arguments
 to pass to that @code{*compile-op-compile-file-function*}.
+
 One notable argument that is heeded by @code{compile-file*} is
-@code{:compile-check}, a function called when the compilation was otherwise a success,
-with the same arguments as @code{compile-file},
-to determine whether 
-(NB: The ability to pass such extra flags is only available starting with asdf 2.22.1.)
-
-Note that by using a string, you may reference
+@code{:compile-check},
+a function called when the compilation was otherwise a success,
+with the same arguments as @code{compile-file};
+the function shall return true if the compilation
+and its resulting compiled file respected all system-specific invariants,
+and false (NIL) if it broke any of those invariants;
+it may issue warnings or errors before it returns NIL.
+(NB: The ability to pass such extra flags
+is only available starting with ASDF 2.22.3.)
+This feature is notably exercised by asdf-finalizers.
+
+By using a string, you may reference
 a function, symbol and/or package
 that will only be created later during the build, but
@@ -3242 +3275 @@
 @emph{All} versions of ASDF should have the @code{:asdf} feature.
 
-Additionally, all versions of asdf 2
+Additionally, all versions of ASDF 2
 define a function @code{(asdf:asdf-version)} you may use to query the version;
-and the source code of recent versions of asdf 2 features the version number
+and the source code of recent versions of ASDF 2 features the version number
 prominently on the second line of its source code.
 
@@ -3463 +3496 @@
 
 @item
-Some systems in the large have been known not to play well with output translations.
+Some systems in the large have been known
+not to play well with output translations.
 They were relatively easy to fix.
 Once again, it is also easy to disable output translations,
@@ -3483 +3517 @@
 
 @item
-ASDF pathname designators are now specified in places where they were unspecified,
+ASDF pathname designators are now specified
+in places where they were unspecified,
 and a few small adjustments have to be made to some non-portable defsystems.
-Notably, in the @code{:pathname} argument to a @code{defsystem} and its components,
+Notably, in the @code{:pathname} argument
+to a @code{defsystem} and its components,
 a logical pathname (or implementation-dependent hierarchical pathname)
 must now be specified with @code{#p} syntax
@@ -3513 +3549 @@
 based on the Windows registry.
 Other implementations make do with environment variables,
-that you may have to define yourself if you're using an older version of Windows.
+that you may have to define yourself
+if you're using an older version of Windows.
 Windows support is somewhat less tested than Unix support.
 Please help report and fix bugs.
+@emph{Update}: As of ASDF 2.21, all implementations
+should now use the same proper default configuration pathnames
+and they should actually work, though they haven't all been tested.
 
 @item
 The mechanism by which one customizes a system so that Lisp files
 may use a different extension from the default @file{.lisp} has changed.
-Previously, the pathname for a component was lazily computed when operating on a system,
+Previously, the pathname for a component
+was lazily computed when operating on a system,
 and you would
 @code{(defmethod source-file-type ((component cl-source-file) (system (eql (find-system 'foo))))
@@ -3526 +3567 @@
 Now, the pathname for a component is eagerly computed when defining the system,
 and instead you will @code{(defclass cl-source-file.lis (cl-source-file) ((type :initform "lis")))}
-and use @code{:default-component-class cl-source-file.lis} as argument to @code{defsystem},
+and use @code{:default-component-class cl-source-file.lis}
+as argument to @code{defsystem},
 as detailed in a @pxref{FAQ,How do I create a system definition where all the source files have a .cl extension?} below.
 
@@ -3554 +3596 @@
 You may consult with the maintainer for which specific version they recommend,
 but the latest @code{release} should be correct.
-We trust you to thoroughly test it with your implementation before you release it.
+We trust you to thoroughly test it with your implementation
+before you release it.
 If there are any issues with the current release,
 it's a bug that you should report upstream and that we will fix ASAP.
@@ -3572 +3615 @@
 then it would be nice to add ASDF to this hook the same way that
 ABCL, CCL, CLISP, CMUCL, ECL, SBCL and SCL do it.
+Please send us appropriate code to this end.
 
 @item
@@ -3907 +3951 @@
 
 
-** document all the error classes
-
-** what to do with compile-file failure
-
-Should check the primary return value from compile-file and see if
-that gets us any closer to a sensible error handling strategy
-
-** foreign files
-
-lift unix-dso stuff from db-sockets
-
 ** Diagnostics
 
@@ -3923 +3956 @@
 
 @lisp
-(traverse (make-instance '<operation-name>)
-          (find-system <system-name>)
-          'explain)
+(let ((asdf::*verbose-out* *standard-output*))
+  (loop :for (op . comp) :in
+    (asdf::traverse (make-instance '<operation-name> :force t)
+                    (asdf:find-system <system-name>))
+    :do (asdf:explain op comp)))
 @end lisp
 
@@ -3935 +3970 @@
 ** reuse the same scratch package whenever a system is reloaded from disk
 
+Have a package ASDF-USER instead of all these temporary packages?
+
 ** proclamations probably aren't
 
-** when a system is reloaded with fewer components than it previously had, odd things happen
-
-We should do something inventive when processing a @code{defsystem} form,
-like take the list of kids and @code{setf} the slot to @code{nil},
-then transfer children from old to new list as they're found.
-
 ** (stuff that might happen later)
 
@@ -3951 +3982 @@
         @code{(asdf:compile-system :araneida :force t)}
 
-also forces compilation of every other system the @code{:araneida} system depends on.
+also forces compilation of every other system
+the @code{:araneida} system depends on.
 This is rarely useful to me;
-usually, when I want to force recompilation of something more than a single source file,
+usually, when I want to force recompilation
+of something more than a single source file,
 I want to recompile only one system.
 So it would be more useful to have @code{make-sub-operation}

branches/1.1.x/src/org/armedbear/lisp/asdf.lisp

@@ -1 +1 @@
 ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
-;;; This is ASDF 2.26: Another System Definition Facility.
+;;; This is ASDF 2.26.6: Another System Definition Facility.
 ;;;
 ;;; Feedback, bug reports, and patches are all welcome:
@@ -119 +119 @@
          ;; "2.345.0.7" would be your seventh local modification of official release 2.345
          ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
-         (asdf-version "2.26")
+         (asdf-version "2.26.6")
          (existing-asdf (find-class 'component nil))
          (existing-version *asdf-version*)
@@ -216 +216 @@
                                  shadow export redefined-functions)
              (let* ((p (ensure-exists name nicknames use)))
-               (ensure-unintern p (append unintern #+cmu redefined-functions))
+               (ensure-unintern p unintern)
                (ensure-shadow p shadow)
                (ensure-export p export)
-               #-cmu (ensure-fmakunbound p redefined-functions)
+               (ensure-fmakunbound p redefined-functions)
                p)))
         (macrolet
@@ -412 +412 @@
 
 (defvar *compile-file-failure-behaviour*
-  (or #+sbcl :error #+clisp :ignore :warn)
+  (or #+(or mkcl sbcl) :error #+clisp :ignore :warn)
   "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE)
 when compiling a file?  Valid values are :error, :warn, and :ignore.
@@ -1213 +1213 @@
    (operation :reader error-operation :initarg :operation))
   (:report (lambda (c s)
-               (format s (compatfmt "~@<Error while invoking ~A on ~A~@:>")
-                       (error-operation c) (error-component c)))))
+               (format s (compatfmt "~@<~A while invoking ~A on ~A~@:>")
+                       (type-of c) (error-operation c) (error-component c)))))
 (define-condition compile-error (operation-error) ())
 (define-condition compile-failed (compile-error) ())
@@ -1462 +1462 @@
    (licence :accessor system-licence :initarg :licence
             :accessor system-license :initarg :license)
-   (source-file :reader %system-source-file :initarg :source-file ; for CLISP upgrade
-                :writer %set-system-source-file)
+   (source-file :initarg :source-file :writer %set-system-source-file) ; upgrade issues on CLISP, CMUCL
    (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on)))
 
@@ -1637 +1636 @@
 FN should be a function of one argument. It will be
 called with an object of type asdf:system."
-  (maphash #'(lambda (_ datum)
-               (declare (ignore _))
-               (destructuring-bind (_ . def) datum
-                 (declare (ignore _))
-                 (funcall fn def)))
-           *defined-systems*))
+  (loop :for (nil . system) :being :the hash-values :of *defined-systems*
+        :do (funcall fn system)))
 
 ;;; for the sake of keeping things reasonably neat, we adopt a
@@ -1796 +1791 @@
 (defvar *systems-being-defined* nil
   "A hash-table of systems currently being defined keyed by name, or NIL")
+(defvar *systems-being-operated* nil
+  "A boolean indicating that some systems are being operated on")
 
 (defun* find-system-if-being-defined (name)
@@ -2005 +2002 @@
   (declare (ignorable operation slot-names force force-not))
   (macrolet ((frob (x) ;; normalize forced and forced-not slots
-               `(when (consp (,x operation))
-                  (setf (,x operation)
-                        (mapcar #'coerce-name (,x operation))))))
-    (frob operation-forced) (frob operation-forced-not))
+               `(when (consp (slot-value operation ',x))
+                  (setf (slot-value operation ',x)
+                        (mapcar #'coerce-name (slot-value operation ',x))))))
+    (frob forced) (frob forced-not))
   (values))
 
@@ -2358 +2355 @@
                    (c x)))
              (r* (l)
-               (dolist (x l) (r x))))
+               (map () #'r l)))
       (r* l))))
 
@@ -2459 +2456 @@
                                  (read-from-string fun))))))))
 
-(defmethod call-with-around-compile-hook ((c component) thunk)
-  (let ((hook (around-compile-hook c)))
-    (if hook
-        (funcall (ensure-function hook) thunk)
-        (funcall thunk))))
+(defun call-around-hook (hook function)
+  (funcall (or (ensure-function hook) 'funcall) function))
+
+(defmethod call-with-around-compile-hook ((c component) function)
+  (call-around-hook (around-compile-hook c) function))
 
 ;;; perform is required to check output-files to find out where to put
@@ -2619 +2616 @@
 (defmethod operation-done-p ((o load-source-op) (c source-file))
   (declare (ignorable o))
-  (if (or (not (component-property c 'last-loaded-as-source))
-          (> (safe-file-write-date (component-pathname c))
-             (component-property c 'last-loaded-as-source)))
-      nil t))
+  (and (component-property c 'last-loaded-as-source)
+       (<= (safe-file-write-date (component-pathname c))
+           (component-property c 'last-loaded-as-source))))
 
 (defmethod operation-description ((operation load-source-op) component)
@@ -2658 +2654 @@
 (defgeneric* operate (operation-class system &key &allow-other-keys))
 (defgeneric* perform-plan (plan &key))
+(defgeneric* plan-operates-on-p (plan component))
 
 ;;;; Separating this into a different function makes it more forward-compatible
@@ -2692 +2689 @@
     (cleanup-upgraded-asdf version)))
 
+(defmethod plan-operates-on-p ((plan list) (component-path list))
+  (find component-path (mapcar 'cdr plan)
+        :test 'equal :key 'component-find-path))
+
 (defmethod perform-plan ((steps list) &key)
   (let ((*package* *package*)
@@ -2700 +2701 @@
 
 (defmethod operate (operation-class system &rest args
-                    &key ((:verbose *asdf-verbose*) *asdf-verbose*) version force
-                    &allow-other-keys)
-  (declare (ignore force))
+                    &key force force-not verbose version &allow-other-keys)
+  (declare (ignore force force-not))
   (with-system-definitions ()
-    (let* ((op (apply 'make-instance operation-class
-                      :original-initargs args
-                      args))
-           (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream)))
+    (let* ((*asdf-verbose* verbose)
+           (*verbose-out* (if verbose *standard-output* (make-broadcast-stream)))
+           (op (apply 'make-instance operation-class
+                      :original-initargs args args))
            (system (etypecase system
                      (system system)
-                     ((or string symbol) (find-system system)))))
-      (unless (version-satisfies system version)
-        (error 'missing-component-of-version :requires system :version version))
-      (let ((steps (traverse op system)))
-        (when (and (not (equal '("asdf") (component-find-path system)))
-                   (find '("asdf") (mapcar 'cdr steps)
-                         :test 'equal :key 'component-find-path)
-                   (upgrade-asdf))
-          ;; If we needed to upgrade ASDF to achieve our goal,
-          ;; then do it specially as the first thing, then
-          ;; invalidate all existing system
-          ;; retry the whole thing with the new OPERATE function,
-          ;; which on some implementations
-          ;; has a new symbol shadowing the current one.
-          (return-from operate
-            (apply (find-symbol* 'operate :asdf) operation-class system args)))
-        (perform-plan steps)
-        (values op steps)))))
-
-(defun* oos (operation-class system &rest args &key force verbose version
-            &allow-other-keys)
-  (declare (ignore force verbose version))
+                     ((or string symbol) (find-system system))))
+           (systems-being-operated *systems-being-operated*)
+           (*systems-being-operated* (or systems-being-operated (make-hash-table :test 'equal))))
+      (check-type system system)
+      (setf (gethash (coerce-name system) *systems-being-operated*) system)
+      (flet ((upgrade ()
+               ;; If we needed to upgrade ASDF to achieve our goal,
+               ;; then do it specially as the first thing,
+               ;; which will invalidate all existing systems;
+               ;; afterwards, retry the whole thing with the new OPERATE function,
+               ;; which on some implementations
+               ;; has a new symbol shadowing the current one.
+               (unless (gethash "asdf" *systems-being-operated*)
+                 (upgrade-asdf)
+                 (return-from operate
+                   (apply (find-symbol* 'operate :asdf) operation-class system args)))))
+        (when systems-being-operated ;; Upgrade if loading a system from another one.
+          (upgrade))
+        (unless (version-satisfies system version)
+          (error 'missing-component-of-version :requires system :version version))
+        (let ((plan (traverse op system)))
+          (when (plan-operates-on-p plan '("asdf"))
+            (upgrade)) ;; Upgrade early if the plan involves upgrading asdf at any time.
+          (perform-plan plan)
+          (values op plan))))))
+
+(defun* oos (operation-class system &rest args
+             &key force force-not verbose version &allow-other-keys)
+  (declare (ignore force force-not verbose version))
   (apply 'operate operation-class system args))
 
@@ -3184 +3191 @@
     (%set-system-source-file
      (probe-asd (component-name system) (component-pathname system)) system))
-  (%system-source-file system))
+  (slot-value system 'source-file))
 (defmethod system-source-file ((system-name string))
-  (%system-source-file (find-system system-name)))
+  (system-source-file (find-system system-name)))
 (defmethod system-source-file ((system-name symbol))
-  (%system-source-file (find-system system-name)))
+  (system-source-file (find-system system-name)))
 
 (defun* system-source-directory (system-designator)
@@ -3919 +3926 @@
 
 (defun* tmpize-pathname (x)
-  (make-pathname
-   :name (strcat "ASDF-TMP-" (pathname-name x))
-   :defaults x))
+  (make-pathname :name (strcat "ASDF-TMP-" (pathname-name x)) :defaults x))
 
 (defun* delete-file-if-exists (x)
@@ -3956 +3961 @@
       (values output-truename warnings-p failure-p))))
 
-#+abcl 
+#+abcl
 (defun* translate-jar-pathname (source wildcard)
   (declare (ignore wildcard))
-  (let* ((jar 
-          (pathname (first (pathname-device source))))
-         (target-root-directory-namestring
-          (format nil "/___jar___file___root___/~@[~A/~]"
-                  (and (find :windows *features*)
-                       (pathname-device jar))))
-         (relative-source 
-          (relativize-pathname-directory source))
-         (relative-jar 
-          (relativize-pathname-directory (ensure-directory-pathname jar)))
-         (target-root-directory
-          (if (find :windows *features*)
-              (make-pathname :name nil
-                             :type nil
-                             :version nil
-                             :defaults (parse-namestring target-root-directory-namestring))
-              (make-pathname :device :unspecific 
-                             :name nil
-                             :type nil
-                             :version nil
-                             :defaults (parse-namestring target-root-directory-namestring))))
-         (target-root 
-          (merge-pathnames* relative-jar target-root-directory))
-         (target 
-          (merge-pathnames* relative-source target-root)))
-    (if (find :windows *features*)
-        (apply-output-translations target)
-        (make-pathname :defaults (apply-output-translations target)
-                       :device :unspecific))))
+  (flet ((normalize-device (pathname)
+           (if (find :windows *features*)
+               pathname
+               (make-pathname :defaults pathname :device :unspecific))))
+    (let* ((jar
+             (pathname (first (pathname-device source))))
+           (target-root-directory-namestring
+             (format nil "/___jar___file___root___/~@[~A/~]"
+                     (and (find :windows *features*)
+                          (pathname-device jar))))
+           (relative-source
+             (relativize-pathname-directory source))
+           (relative-jar
+             (relativize-pathname-directory (ensure-directory-pathname jar)))
+           (target-root-directory
+             (normalize-device
+              (pathname-directory-pathname
+               (parse-namestring target-root-directory-namestring))))
+           (target-root
+             (merge-pathnames* relative-jar target-root-directory))
+           (target
+             (merge-pathnames* relative-source target-root)))
+      (normalize-device (apply-output-translations target)))))
 
 ;;;; -----------------------------------------------------------------
@@ -4155 +4154 @@
 
 (defun* collect-sub*directories-asd-files
-    (directory &key
-     (exclude *default-source-registry-exclusions*)
-     collect)
+    (directory &key (exclude *default-source-registry-exclusions*) collect)
   (collect-sub*directories
    directory
@@ -4509 +4506 @@
 
 #+mkcl
-(progn
-  (defvar *loading-asdf-bundle* nil)
-  (unless *loading-asdf-bundle*
-    (let ((*central-registry*
-           (cons (translate-logical-pathname #P"CONTRIB:asdf-bundle;") *central-registry*))
-    (*loading-asdf-bundle* t))
-      (clear-system :asdf-bundle) ;; we hope to force a reload.
-      (multiple-value-bind (result bundling-error)
-          (ignore-errors (asdf:oos 'asdf:load-op :asdf-bundle))
-        (unless result
-    (format *error-output*
-      "~&;;; ASDF: Failed to load package 'asdf-bundle'!~%;;; ASDF: Reason is: ~A.~%"
-      bundling-error))))))
+(handler-case
+    (progn
+      (load-sysdef "asdf-bundle"
+                   (subpathname (translate-logical-pathname #P"CONTRIB:")
+                                "asdf-bundle/asdf-bundle.asd"))
+      (load-system "asdf-bundle"))
+  (error (e)
+    (format *error-output*
+            "~&;;; ASDF: Failed to load package 'asdf-bundle'!~%;;; ~A~%"
+            e)))
 
 #+allegro