From 95c5ffb888ba342970bd994c2a82e4a0c17171b5 Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <fare@tunes.org>
Date: Sun, 2 May 2010 22:06:00 -0400
Subject: [PATCH] 1.714: Better print-method for component: prints the complete
 access path to the component, not just its name. Also refactor find-component
 while we're at it, so we can use that path. Document flatten-tree.

---
 asdf.lisp                             | 94 ++++++++++++++++-----------
 test/test-module-excessive-depend.asd |  2 +-
 2 files changed, 58 insertions(+), 38 deletions(-)

diff --git a/asdf.lisp b/asdf.lisp
index 5d6b13ff..cb5c0bec 100644
--- a/asdf.lisp
+++ b/asdf.lisp
@@ -63,7 +63,7 @@
         (remove "asdf" excl::*autoload-package-name-alist* :test 'equalp :key 'car))
   (let* ((asdf-version
           ;; the 1+ hair is to ensure that we don't do an inadvertent find and replace
-          (subseq "VERSION:1.713" (1+ (length "VERSION"))))
+          (subseq "VERSION:1.714" (1+ (length "VERSION"))))
          (existing-asdf (find-package :asdf))
          (versym '#:*asdf-version*)
          (existing-version (and existing-asdf
@@ -72,7 +72,7 @@
          (redefined-functions
           '(#:perform #:explain #:output-files #:operation-done-p
             #:perform-with-restarts #:component-relative-pathname
-            #:system-source-file #:operate))
+            #:system-source-file #:operate #:find-component))
          (already-there (equal asdf-version existing-version)))
     (unless (and existing-asdf already-there)
       (when existing-asdf
@@ -369,10 +369,9 @@ another pathname in a degenerate way."))
 
 (defgeneric version-satisfies (component version))
 
-(defgeneric find-component (module name &optional version)
-  (:documentation "Finds the component with name NAME present in the
-MODULE module; if MODULE is nil, then the component is assumed to be a
-system."))
+(defgeneric find-component (base path)
+  (:documentation "Finds the component with PATH starting from BASE module;
+if BASE is nil, then the component is assumed to be a system."))
 
 (defgeneric source-file-type (component system))
 
@@ -824,6 +823,16 @@ actually-existing directory."
    (properties :accessor component-properties :initarg :properties
                :initform nil)))
 
+(defun component-find-path (component)
+  (reverse
+   (loop :for c = component :then (component-parent c)
+     :while c :collect (component-name c))))
+
+(defmethod print-object ((c component) stream)
+  (print-unreadable-object (c stream :type t :identity nil)
+    (format stream "~@<~{~S~^ ~}~@:>" (component-find-path c))))
+
+
 ;;;; methods: conditions
 
 (defmethod print-object ((c missing-dependency) s)
@@ -856,11 +865,6 @@ actually-existing directory."
        (component-system it)
        component))
 
-(defmethod print-object ((c component) stream)
-  (print-unreadable-object (c stream :type t :identity t)
-    (ignore-errors
-      (prin1 (component-name c) stream))))
-
 (defvar *default-component-class* 'cl-source-file)
 
 (defun compute-module-components-by-name (module)
@@ -1076,11 +1080,14 @@ to `~a` which is not a directory.~@:>"
          (package package))))
 
 (defun safe-file-write-date (pathname)
-           ;; if FILE-WRITE-DATE returns NIL, it's possible that the
-           ;; user or some other agent has deleted an input file.  If
-           ;; that's the case, well, that's not good, but as long as
-           ;; the operation is otherwise considered to be done we
-           ;; could continue and survive.
+  ;; If FILE-WRITE-DATE returns NIL, it's possible that
+  ;; the user or some other agent has deleted an input file.
+  ;; Also, generated files will not exist at the time planning is done
+  ;; and calls operation-done-p which calls safe-file-write-date.
+  ;; So it is very possible that we can't get a valid file-write-date,
+  ;; and we can survive and we will continue the planning
+  ;; as if the file were very old.
+  ;; (or should we treat the case in a different, special way?)
   (or (and pathname (probe-file pathname) (file-write-date pathname))
       (progn
         (when pathname
@@ -1105,10 +1112,7 @@ to `~a` which is not a directory.~@:>"
                (let ((*package* package))
                  (asdf-message
                   "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
-                  ;; FIXME: This wants to be (ENOUGH-NAMESTRING
-                  ;; ON-DISK), but CMUCL barfs on that.
-                  on-disk
-                  *package*)
+                  on-disk *package*)
                  (load on-disk)))
           (delete-package package))))
     (let ((in-memory (system-registered-p name)))
@@ -1127,17 +1131,31 @@ to `~a` which is not a directory.~@:>"
 ;;;; -------------------------------------------------------------------------
 ;;;; Finding components
 
-(defmethod find-component ((module module) name &optional version)
-  (if (slot-boundp module 'components)
-      (let ((m (gethash name (module-components-by-name module))))
-        (if (and m (version-satisfies m version)) m))))
+(defmethod find-component ((base string) path)
+  (let ((s (find-system base nil)))
+    (and s (find-component s path))))
+
+(defmethod find-component ((base symbol) path)
+  (cond
+    (base (find-component (coerce-name base) path))
+    (path (find-component path nil))
+    (t    nil)))
+
+(defmethod find-component ((base cons) path)
+  (find-component (car base) (cons (cdr base) path)))
+
+(defmethod find-component ((module module) (name string))
+  (when (slot-boundp module 'components-by-name)
+    (values (gethash name (module-components-by-name module)))))
+
+(defmethod find-component ((component component) (name symbol))
+  (if name
+      (find-component component (string name))
+      component))
 
+(defmethod find-component ((module module) (name cons))
+  (find-component (find-component module (car name)) (cdr name)))
 
-;;; a component with no parent is a system
-(defmethod find-component ((module (eql nil)) name &optional version)
-  (declare (ignorable module))
-  (let ((m (find-system name nil)))
-    (if (and m (version-satisfies m version)) m)))
 
 ;;; component subclasses
 
@@ -1393,12 +1411,8 @@ recursive calls to traverse.")
 (defun %do-one-dep (operation c collect required-op required-c required-v)
   ;; collects a partial plan that results from performing required-op
   ;; on required-c, possibly with a required-vERSION
-  (let* ((dep-c (or (find-component
-                     (component-parent c)
-                     ;; XXX tacky.  really we should build the
-                     ;; in-order-to slot with canonicalized
-                     ;; names instead of coercing this late
-                     (coerce-name required-c) required-v)
+  (let* ((dep-c (or (let ((d (find-component (component-parent c) required-c)))
+                      (and d (version-satisfies d required-v) d))
                     (if required-v
                         (error 'missing-dependency-of-version
                                :required-by c
@@ -1576,9 +1590,15 @@ recursive calls to traverse.")
      (do-traverse operation c #'collect))))
 
 (defun flatten-tree (l)
+  ;; You collected things into a list.
+  ;; Most elements are just things to collect again.
+  ;; A (simple-vector 1) indicate that you should recurse into its contents.
+  ;; This way, in two passes (rather than N being the depth of the tree),
+  ;; you can collect things with marginally constant-time append,
+  ;; achieving linear time collection instead of quadratic time.
   (while-collecting (c)
     (labels ((r (x)
-               (if (vectorp x)
+               (if (typep x '(simple-vector 1))
                    (r* (svref x 0))
                    (c x)))
              (r* (l)
@@ -2839,7 +2859,7 @@ effectively disabling the output translation facility."
      (merge-pathnames*
       (relativize-pathname-directory source)
       (merge-pathnames*
-       (relativize-pathname-directory p)
+       (relativize-pathname-directory (ensure-directory-pathname p))
        root)))))
 
 ;;;; -----------------------------------------------------------------
diff --git a/test/test-module-excessive-depend.asd b/test/test-module-excessive-depend.asd
index a8d8495c..249a9bdf 100644
--- a/test/test-module-excessive-depend.asd
+++ b/test/test-module-excessive-depend.asd
@@ -29,7 +29,7 @@
         (call-next-method)))
 
 (defmethod find-component :around ((m (eql (find-quux)))
-                                   (c string) &optional version)
+                                   (c string))
   "FIND-COMPONENT on a component is a no-op --- it's already found."
   (declare (ignore version))
   (if (string-equal c "file3-only")
-- 
GitLab