From b0e85da9332a8822dd9496a0e4a72571b6d3546b Mon Sep 17 00:00:00 2001
From: Raymond Toy <toy.raymond@gmail.com>
Date: Fri, 15 Jun 2012 12:19:47 -0700
Subject: [PATCH] Update to asdf 2.22.  Testsuite for asdf, using 2012-06,
 passes fine.

---
 src/contrib/asdf/asdf.lisp       | 62 +++++++++++++++++---------------
 src/general-info/release-20d.txt |  2 +-
 2 files changed, 35 insertions(+), 29 deletions(-)

diff --git a/src/contrib/asdf/asdf.lisp b/src/contrib/asdf/asdf.lisp
index b7ad1dd6b..5981f67fd 100644
--- a/src/contrib/asdf/asdf.lisp
+++ b/src/contrib/asdf/asdf.lisp
@@ -1,5 +1,5 @@
 ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
-;;; This is ASDF 2.21: Another System Definition Facility.
+;;; This is ASDF 2.22: Another System Definition Facility.
 ;;;
 ;;; Feedback, bug reports, and patches are all welcome:
 ;;; please mail to <asdf-devel@common-lisp.net>.
@@ -116,7 +116,7 @@
          ;; "2.345.6" would be a development version in the official upstream
          ;; "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.21")
+         (asdf-version "2.22")
          (existing-asdf (find-class 'component nil))
          (existing-version *asdf-version*)
          (already-there (equal asdf-version existing-version)))
@@ -1343,7 +1343,7 @@ processed in order by OPERATE."))
     :initarg :if-component-dep-fails
     :accessor module-if-component-dep-fails)
    (default-component-class
-    :initform *default-component-class*
+    :initform nil
     :initarg :default-component-class
     :accessor module-default-component-class)))
 
@@ -2788,6 +2788,11 @@ details."
         directory-pathname
         (default-directory))))
 
+(defun* find-class* (x &optional (errorp t) environment)
+  (etypecase x
+    ((or standard-class built-in-class) x)
+    (symbol (find-class x errorp environment))))
+
 (defun* class-for-type (parent type)
   (or (loop :for symbol :in (list
                              type
@@ -2799,8 +2804,10 @@ details."
                                  class (find-class 'component)))
         :return class)
       (and (eq type :file)
-           (or (and parent (module-default-component-class parent))
-               (find-class *default-component-class*)))
+           (find-class*
+            (or (loop :for module = parent :then (component-parent module) :while module
+                  :thereis (module-default-component-class module))
+                *default-component-class*) nil))
       (sysdef-error "don't recognize component type ~A" type)))
 
 (defun* maybe-add-tree (tree op1 op2 c)
@@ -2886,7 +2893,7 @@ Returns the new tree (which probably shares structure with the old one)"
         (type name &rest rest &key
               ;; the following list of keywords is reproduced below in the
               ;; remove-keys form.  important to keep them in sync
-              components pathname default-component-class
+              components pathname
               perform explain output-files operation-done-p
               weakly-depends-on depends-on serial in-order-to
               do-first
@@ -2913,7 +2920,7 @@ Returns the new tree (which probably shares structure with the old one)"
                         :pathname pathname
                         :parent parent
                         (remove-keys
-                         '(components pathname default-component-class
+                         '(components pathname
                            perform explain output-files operation-done-p
                            weakly-depends-on depends-on serial in-order-to)
                          rest)))
@@ -2927,10 +2934,6 @@ Returns the new tree (which probably shares structure with the old one)"
           (setf ret (apply 'make-instance (class-for-type parent type) args)))
       (component-pathname ret) ; eagerly compute the absolute pathname
       (when (typep ret 'module)
-        (setf (module-default-component-class ret)
-              (or default-component-class
-                  (and (typep parent 'module)
-                       (module-default-component-class parent))))
         (let ((*serial-depends-on* nil))
           (setf (module-components ret)
                 (loop
@@ -3687,7 +3690,7 @@ Please remove it from your ASDF configuration"))
     #+sbcl ,(let ((h (getenv "SBCL_HOME")))
                  (when (plusp (length h)) `((,(truenamize h) ,*wild-inferiors*) ())))
     ;; The below two are not needed: no precompiled ASDF system there
-    ;; #+ecl (,(translate-logical-pathname "SYS:**;*.*") ())
+    #+ecl (,(translate-logical-pathname "SYS:**;*.*") ())
     ;; #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ()))
     ;; All-import, here is where we want user stuff to be:
     :inherit-configuration
@@ -4011,21 +4014,24 @@ with a different configuration, so the configuration would be re-read then."
       entries))
 
 (defun* directory-files (directory &optional (pattern *wild-file*))
-  (setf directory (pathname directory))
-  (when (wild-pathname-p directory)
-    (error "Invalid wild in ~S" directory))
-  (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal)
-    (error "Invalid file pattern ~S" pattern))
-  (when (typep directory 'logical-pathname)
-    (setf pattern (make-pathname-logical pattern (pathname-host directory))))
-  (let ((entries (ignore-errors (directory* (merge-pathnames* pattern directory)))))
-    (filter-logical-directory-results
-     directory entries
-     #'(lambda (f)
-         (make-pathname :defaults directory
-                        :name (pathname-name f)
-                        :type (make-pathname-component-logical (pathname-type f))
-                        :version (make-pathname-component-logical (pathname-version f)))))))
+  (let ((dir (pathname directory)))
+    (when (typep dir 'logical-pathname)
+      ;; Because of the filtering we do below,
+      ;; logical pathnames have restrictions on wild patterns.
+      ;; Not that the results are very portable when you use these patterns on physical pathnames.
+      (when (wild-pathname-p dir)
+        (error "Invalid wild pattern in logical directory ~S" directory))
+      (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal)
+        (error "Invalid file pattern ~S for logical directory ~S" pattern directory))
+      (setf pattern (make-pathname-logical pattern (pathname-host dir))))
+    (let ((entries (ignore-errors (directory* (merge-pathnames* pattern dir)))))
+      (filter-logical-directory-results
+       directory entries
+       #'(lambda (f)
+           (make-pathname :defaults dir
+                          :name (make-pathname-component-logical (pathname-name f))
+                          :type (make-pathname-component-logical (pathname-type f))
+                          :version (make-pathname-component-logical (pathname-version f))))))))
 
 (defun* directory-asd-files (directory)
   (directory-files directory *wild-asd*))
@@ -4399,7 +4405,7 @@ with a different configuration, so the configuration would be re-read then."
     (let ((*verbose-out* (make-broadcast-stream))
           (system (find-system (string-downcase name) nil)))
       (when system
-        (operate *require-asdf-operator* system :verbose nil)
+        (operate *require-asdf-operator* system :verbose nil :force-not (loaded-systems))
         t))))
 
 #+(or abcl clisp clozure cmu ecl sbcl)
diff --git a/src/general-info/release-20d.txt b/src/general-info/release-20d.txt
index e2b20e877..631fccab3 100644
--- a/src/general-info/release-20d.txt
+++ b/src/general-info/release-20d.txt
@@ -30,7 +30,7 @@ New in this release:
     * Added external format for EUC-KR.
  
   * Changes
-    * ASDF2 updated to version 2.21.
+    * ASDF2 updated to version 2.22.
     * Behavior of STRING-TO-OCTETS has changed.  This is an
       incompatible change from the previous version but should be more
       useful when a buffer is given which is not large enough to hold
-- 
GitLab