From fe8c75ed7b56c052c8278164f2119091748577b6 Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <fare@tunes.org>
Date: Tue, 13 Apr 2010 17:03:16 -0400
Subject: [PATCH] 1.676: eagerly compute component-pathname, to avoid weird
 non-determinism when building in a different directory than expected by the
 asd files.

---
 asdf.lisp                                | 60 +++++++++++++++---------
 test/test-module-excessive-depend.script |  2 +-
 test/test1.script                        |  2 +-
 test/test3.asd                           |  3 +-
 4 files changed, 42 insertions(+), 25 deletions(-)

diff --git a/asdf.lisp b/asdf.lisp
index 23ab0c0b..8dc23377 100644
--- a/asdf.lisp
+++ b/asdf.lisp
@@ -60,7 +60,7 @@
 (eval-when (:load-toplevel :compile-toplevel :execute)
   (let* ((asdf-version
           ;; the 1+ hair is to ensure that we don't do an inadvertent find and replace
-          (subseq "VERSION:1.675" (1+ (length "VERSION"))))
+          (subseq "VERSION:1.676" (1+ (length "VERSION"))))
          #+allegro (excl::*autoload-package-name-alist* nil)
          (existing-asdf (find-package :asdf))
          (versym '#:*asdf-version*)
@@ -441,9 +441,15 @@ Deprecated. Use PATHNAME-DIRECTORY-PATHNAME instead."
 and NIL NAME, TYPE and VERSION components"
   (make-pathname :name nil :type nil :version nil :defaults pathname))
 
+(defun current-directory ()
+  (truenamize (pathname-directory-pathname *default-pathname-defaults*)))
+
 (defun merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
   "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that if the SPECIFIED pathname
-does not have an absolute directory, then the HOST and DEVICE come from the DEFAULTS."
+does not have an absolute directory, then the HOST and DEVICE come from the DEFAULTS.
+Also, if either argument is NIL, then the other argument is returned unmodified."
+  (when (null specified) (return-from merge-pathnames* defaults))
+  (when (null defaults) (return-from merge-pathnames* specified))
   (let* ((specified (pathname specified))
          (defaults (pathname defaults))
          (directory (pathname-directory specified))
@@ -783,6 +789,7 @@ actually-existing directory."
    ;; no direct accessor for pathname, we do this as a method to allow
    ;; it to default in funky ways if not supplied
    (relative-pathname :initarg :pathname)
+   (absolute-pathname)
    (operation-times :initform (make-hash-table)
                     :accessor component-operation-times)
    ;; XXX we should provide some atomic interface for updating the
@@ -838,13 +845,25 @@ actually-existing directory."
      :initform 'cl-source-file :initarg :default-component-class)))
 
 (defun component-parent-pathname (component)
-  (aif (component-parent component)
-       (component-pathname it)
-       (truenamize *default-pathname-defaults*)))
+  ;; No default anymore (in particular, no *default-pathname-defaults*).
+  ;; If you force component to have a NULL pathname, you better arrange
+  ;; for any of its children to explicitly provide a proper absolute pathname
+  ;; wherever a pathname is actually wanted.
+  (let ((parent (component-parent component)))
+    (when parent
+      (component-pathname parent))))
 
 (defmethod component-pathname ((component component))
-  (merge-pathnames* (component-relative-pathname component)
-                    (component-parent-pathname component)))
+  (if (slot-boundp component 'absolute-pathname)
+      (slot-value component 'absolute-pathname)
+      (let ((pathname
+             (merge-pathnames*
+             (component-relative-pathname component)
+             (component-parent-pathname component))))
+        (unless (or (null pathname) (absolute-pathname-p pathname))
+          (error "Invalid relative pathname ~S for component ~S" pathname component))
+        (setf (slot-value component 'absolute-pathname) pathname)
+        pathname)))
 
 (defmethod component-property ((c component) property)
   (cdr (assoc property (slot-value c 'properties) :test #'equal)))
@@ -1138,9 +1157,7 @@ to `~a` which is not a directory.~@:>"
    (or (slot-value component 'relative-pathname)
        (component-name component))
    :type (source-file-type component (component-system component))
-   :defaults (let ((parent (component-parent component)))
-               (and parent (component-pathname parent)))))
-
+   :defaults (component-parent-pathname component)))
 
 ;;;; -------------------------------------------------------------------------
 ;;;; Operations
@@ -1771,13 +1788,15 @@ details."
   ;; to resolve symbolic links. If not resolving symlinks, then we use
   ;; *load-pathname* instead of *load-truename* since in some
   ;; implementations, the latter has *already resolved it.
-  (or (and pathname-supplied-p pathname)
-      (when *load-pathname*
-        (pathname-directory-pathname
-         (if *resolve-symlinks*
-             (resolve-symlinks *load-truename*)
-             *load-pathname*)))
-      *default-pathname-defaults*))
+  (let ((file-pathname
+         (when (or *load-pathname* *compile-file-pathname*)
+           (pathname-directory-pathname
+            (if *resolve-symlinks*
+                (resolve-symlinks (or *load-truename* *compile-file-truename*))
+                *load-pathname*)))))
+    (or (and pathname-supplied-p (merge-pathnames pathname file-pathname))
+        file-pathname
+        (current-directory))))
 
 (defmacro defsystem (name &body options)
   (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system)
@@ -1946,6 +1965,7 @@ Returns the new tree (which probably shares structure with the old one)"
              :pathname pathname
              :parent parent
              other-args)
+      (component-pathname ret) ; eagerly compute the absolute pathname
       (when (typep ret 'module)
         (setf (module-default-component-class ret)
               (or default-component-class
@@ -1977,7 +1997,6 @@ Returns the new tree (which probably shares structure with the old one)"
             (component-do-first ret) `((compile-op (load-op ,@depends-on))))
 
       (%refresh-component-inline-methods ret rest)
-
       ret)))
 
 ;;;; ---------------------------------------------------------------------------
@@ -2357,7 +2376,7 @@ with a different configuration, so the configuration would be re-read then."
             ((eql :home) (user-homedir))
             ((eql :user-cache) (resolve-location *user-cache* nil))
             ((eql :system-cache) (resolve-location *system-cache* nil))
-            ((eql :current-directory) (truenamize *default-pathname-defaults*))))
+            ((eql :current-directory) (current-directory))))
          (s (if (and wildenp (not (pathnamep x)))
                 (wilden r)
                 r)))
@@ -2377,8 +2396,7 @@ with a different configuration, so the configuration would be re-read then."
                                  (merge-pathnames* car super) (cdr x) wildenp)))
                        (merge-pathnames* cdr car)))))
               ((eql :current-directory)
-               (relativize-pathname-directory
-                (truenamize *default-pathname-defaults*)))
+               (relativize-pathname-directory (current-directory)))
               ((eql :implementation) (implementation-identifier))
               ((eql :implementation-type) (string-downcase (implementation-type)))
               ((eql :uid) (princ-to-string (get-uid)))))
diff --git a/test/test-module-excessive-depend.script b/test/test-module-excessive-depend.script
index 1e07ed16..21827890 100644
--- a/test/test-module-excessive-depend.script
+++ b/test/test-module-excessive-depend.script
@@ -42,8 +42,8 @@
    ;; dependency bug is fixed and the excessive compilation bug is fixed.
 
    (let ((before file2-date))
-     (asdf::run-shell-command "touch file1.lisp")
      (sleep 1)
+     (asdf::run-shell-command "touch file1.lisp")
      (let ((plan (asdf::traverse
                   (make-instance 'asdf:load-op)
                   (asdf:find-system 'test-module-excessive-depend)))
diff --git a/test/test1.script b/test/test1.script
index a0306b6c..3768e0ee 100644
--- a/test/test1.script
+++ b/test/test1.script
@@ -33,7 +33,7 @@
    ;; unix cwd.  this is not a problem for run-tests.sh, but can be in general
 
    (let ((before (file-write-date file2)))
-     (asdf::run-shell-command "touch file1.lisp")
      (sleep 1)
+     (asdf::run-shell-command "touch file1.lisp")
      (asdf:operate 'asdf:load-op 'test1)
      (assert (>  (file-write-date file2) before)))))
diff --git a/test/test3.asd b/test/test3.asd
index 23848d65..b655bef8 100644
--- a/test/test3.asd
+++ b/test/test3.asd
@@ -4,8 +4,7 @@
     :components
   ((:module "deps"
             :if-component-dep-fails :try-next
-            :pathname "."
+            :pathname ""
             :components
             ((:file "file1" :in-order-to ((compile-op (feature :f1))))
              (:file "file2" :in-order-to ((compile-op (feature :f2))))))))
-
-- 
GitLab