From aa031e1831179afaeb8cb1934c79a2f004589b5e Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <tunes@google.com>
Date: Tue, 29 Jan 2013 13:51:37 -0500
Subject: [PATCH] 2.26.166: Debug a define-package bug.

ENSURE-EXPORTED was exporting the wrong symbol via EXPORT*.
Also, backward compatibility with systems (i.e. cxml) that directly access
the relative-pathname slot of a system the ASDF 1 way,
instead of using system-relative-pathname.
Eliminate the last use of merge-pathnames.
---
 asdf.asd                 |   2 +-
 bundle.lisp              |   2 +-
 header.lisp              |   2 +-
 package.lisp             | 545 +++++++++++++++++++++------------------
 system.lisp              |   7 +-
 test/run-tests.sh        |   4 -
 test/script-support.lisp |  84 +++---
 upgrade.lisp             |   2 +-
 utility.lisp             |  47 ++--
 version.lisp-expr        |   2 +-
 10 files changed, 377 insertions(+), 320 deletions(-)

diff --git a/asdf.asd b/asdf.asd
index 08ed65a62..c910bd787 100644
--- a/asdf.asd
+++ b/asdf.asd
@@ -66,7 +66,7 @@
   :licence "MIT"
   :description "Another System Definition Facility"
   :long-description "ASDF builds Common Lisp software organized into defined systems."
-  :version "2.26.165" ;; to be automatically updated by make bump-version
+  :version "2.26.166" ;; to be automatically updated by make bump-version
   :depends-on ()
   #+asdf3 :encoding #+asdf3 :utf-8
   ;; For most purposes, asdf itself specially counts as a builtin system.
diff --git a/bundle.lisp b/bundle.lisp
index 55ff80d2c..08d1a3419 100644
--- a/bundle.lisp
+++ b/bundle.lisp
@@ -270,7 +270,7 @@
          (move-here-path (if (and move-here
                                   (typep move-here '(or pathname string)))
                              (pathname move-here)
-                             (merge-pathnames "./asdf-output/")))
+                             (system-relative-pathname system "asdf-output/")))
          (operation (apply #'operate operation-name
                            system
                            (remove-plist-keys '(:monolithic :type :move-here) args)))
diff --git a/header.lisp b/header.lisp
index a48e27663..c83a0194b 100644
--- a/header.lisp
+++ b/header.lisp
@@ -1,5 +1,5 @@
 ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
-;;; This is ASDF 2.26.165: Another System Definition Facility.
+;;; This is ASDF 2.26.166: Another System Definition Facility.
 ;;;
 ;;; Feedback, bug reports, and patches are all welcome:
 ;;; please mail to <asdf-devel@common-lisp.net>.
diff --git a/package.lisp b/package.lisp
index 1069e8dbf..8c8ecc7d4 100644
--- a/package.lisp
+++ b/package.lisp
@@ -120,16 +120,9 @@ or when loading the package is optional."
 (eval-when (:load-toplevel :compile-toplevel :execute)
   (defvar *all-package-happiness* '())
   (defvar *all-package-fishiness* (list t))
-  (defvar *package-fishiness* '())
-  (defun flush-fishy ()
-    (when *package-fishiness*
-      (if (null (rest *package-fishiness*))
-          (push (first *package-fishiness*) *all-package-happiness*)
-          (push (nreverse *package-fishiness*) *all-package-fishiness*))
-      (setf *package-fishiness* nil)))
   (defun record-fishy (info)
     ;;(format t "~&FISHY: ~S~%" info)
-    (push info *package-fishiness*))
+    (push info *all-package-fishiness*))
   (defmacro when-package-fishiness (&body body)
     `(when *all-package-fishiness* ,@body))
   (defmacro note-package-fishiness (&rest info)
@@ -207,9 +200,9 @@ or when loading the package is optional."
                   (and overwritten-symbol-status
                        (symbol-shadowing-p overwritten-symbol package))))
             (note-package-fishiness
-             :rehome-symbol name (package-name old-package)
-             (package-name package) old-status (and shadowing t)
-             overwritten-symbol-status overwritten-symbol-shadowing-p)
+             :rehome-symbol name
+             (when old-package (package-name old-package)) old-status (and shadowing t)
+             (package-name package) overwritten-symbol-status overwritten-symbol-shadowing-p)
             (when old-package
               (if shadowing
                   (shadowing-import shadowing old-package))
@@ -337,8 +330,211 @@ or when loading the package is optional."
 
 
 ;;; ensure-package, define-package
-
 (eval-when (:load-toplevel :compile-toplevel :execute)
+  (defun ensure-shadowing-import (name to-package from-package shadowed imported)
+    (check-type name string)
+    (check-type to-package package)
+    (check-type from-package package)
+    (check-type shadowed hash-table)
+    (check-type imported hash-table)
+    (let ((import-me (find-symbol* name from-package)))
+      (multiple-value-bind (existing status) (find-symbol name to-package)
+        (cond
+          ((gethash name shadowed)
+           (unless (eq import-me existing)
+             (error "Conflicting shadowings for ~A" name)))
+          (t
+           (setf (gethash name shadowed) t)
+           (setf (gethash name imported) t)
+           (unless (or (null status)
+                       (and (member status '(:internal :external))
+                            (eq existing import-me)
+                            (symbol-shadowing-p existing to-package)))
+             (note-package-fishiness
+              :shadowing-import name
+              (package-name from-package)
+              (or (home-package-p import-me from-package) (symbol-package-name import-me))
+              (package-name to-package) status
+              (and status (or (home-package-p existing to-package) (symbol-package-name existing))))
+           (shadowing-import import-me to-package)))))))
+  (defun ensure-import (name to-package from-package shadowed imported)
+    (check-type name string)
+    (check-type to-package package)
+    (check-type from-package package)
+    (check-type shadowed hash-table)
+    (check-type imported hash-table)
+    (let* ((import-me (find-symbol* name from-package)))
+      (multiple-value-bind (existing status) (find-symbol name to-package)
+        (cond
+          ((gethash name imported)
+           (unless (eq import-me existing)
+             (error "Can't import ~S from both ~S and ~S"
+                    name (package-name (symbol-package existing)) (package-name from-package))))
+          ((gethash name shadowed)
+           (error "Can't both shadow ~S and import it from ~S" name (package-name from-package)))
+          (t
+           (setf (gethash name imported) t)
+           (unless (and status (eq import-me existing))
+             (when status
+               (note-package-fishiness
+                :import name
+                (package-name from-package)
+                (or (home-package-p import-me from-package) (symbol-package-name import-me))
+                (package-name to-package) status
+                (and status (or (home-package-p existing to-package) (symbol-package-name existing))))
+               (unintern* existing to-package))
+             (import import-me to-package)))))))
+  (defun ensure-inherited (name symbol to-package from-package mixp shadowed imported inherited)
+    (check-type name string)
+    (check-type symbol symbol)
+    (check-type to-package package)
+    (check-type from-package package)
+    (check-type mixp boolean)
+    (check-type shadowed hash-table)
+    (check-type imported hash-table)
+    (check-type inherited hash-table)
+    (multiple-value-bind (existing status) (find-symbol name to-package)
+      (let* ((sp (symbol-package symbol))
+             (in (gethash name inherited))
+             (xp (and status (symbol-package existing))))
+        (when (null sp)
+          (note-package-fishiness
+           :import-uninterned name
+           (package-name from-package) (package-name to-package) mixp)
+          (import symbol from-package)
+          (setf sp (package-name from-package)))
+        (cond
+          ((gethash name shadowed))
+          (in
+           (unless (equal sp (first in))
+             (if mixp
+                 (ensure-shadowing-import name to-package (second in) shadowed imported)
+                 (error "Can't inherit ~S from ~S, it is inherited from ~S"
+                        name (package-name sp) (package-name (first in))))))
+          ((gethash name imported)
+           (unless (eq symbol existing)
+             (error "Can't inherit ~S from ~S, it is imported from ~S"
+                    name (package-name sp) (package-name xp))))
+          (t
+           (setf (gethash name inherited) (list sp from-package))
+           (when (and status (not (eq sp xp)))
+             (let ((shadowing (symbol-shadowing-p existing to-package)))
+               (note-package-fishiness
+                :inherited name
+                (package-name from-package)
+                (or (home-package-p symbol from-package) (symbol-package-name symbol))
+                (package-name to-package)
+                (or (home-package-p existing to-package) (symbol-package-name existing)))
+               (if shadowing (ensure-shadowing-import name to-package from-package shadowed imported)
+                   (unintern* existing to-package)))))))))
+  (defun ensure-mix (name symbol to-package from-package shadowed imported inherited)
+    (check-type name string)
+    (check-type symbol symbol)
+    (check-type to-package package)
+    (check-type from-package package)
+    (check-type shadowed hash-table)
+    (check-type imported hash-table)
+    (check-type inherited hash-table)
+    (unless (gethash name shadowed)
+      (multiple-value-bind (existing status) (find-symbol name to-package)
+        (let* ((sp (symbol-package symbol))
+               (im (gethash name imported))
+               (in (gethash name inherited)))
+          (cond
+            ((or (null status)
+                 (and status (eq symbol existing))
+                 (and in (eq sp (first in))))
+             (ensure-inherited name symbol to-package from-package t shadowed imported inherited))
+            (in
+             (remhash name inherited)
+             (ensure-shadowing-import name to-package (second in) shadowed imported))
+            (im
+             (error "Symbol ~S import from ~S~:[~*~; actually ~:[~*uninterned~;from ~S~]~] conflicts with existing symbol in ~S~:[~*~; actually ~:[~*uninterned~;from ~S~]~]"
+                    name (package-name from-package)
+                    (home-package-p symbol from-package) (symbol-package-name symbol)
+                    (package-name to-package)
+                    (home-package-p existing to-package) (symbol-package-name existing)))
+            (t
+             (ensure-inherited name symbol to-package from-package t shadowed imported inherited)))))))
+  (defun recycle-symbol (name recycle exported)
+    (check-type name string)
+    (check-type recycle list)
+    (check-type exported hash-table)
+    (when (gethash name exported) ;; don't bother recycling private symbols
+      (let (recycled foundp)
+        (dolist (r recycle (values recycled foundp))
+          (multiple-value-bind (symbol status) (find-symbol name r)
+            (when (and status (home-package-p symbol r))
+              (cond
+                (foundp
+                 ;; (nuke-symbol symbol)) -- even simple variable names like O or C will do that.
+                 (note-package-fishiness :recycled-duplicate name (package-name foundp) (package-name r)))
+                (t
+                 (setf recycled symbol foundp r)))))))))
+  (defun symbol-recycled-p (sym recycle)
+    (check-type sym symbol)
+    (check-type recycle list)
+    (member (symbol-package sym) recycle))
+  (defun ensure-symbol (name package intern recycle shadowed imported inherited exported)
+    (check-type name string)
+    (check-type package package)
+    (check-type intern boolean)
+    (check-type shadowed hash-table)
+    (check-type imported hash-table)
+    (check-type inherited hash-table)
+    (unless (or (gethash name shadowed)
+                (gethash name imported)
+                (gethash name inherited))
+      (multiple-value-bind (existing status)
+          (find-symbol name package)
+        (multiple-value-bind (recycled previous) (recycle-symbol name recycle exported)
+          (cond
+            ((and status (eq existing recycled) (eq previous package)))
+            (previous
+             (rehome-symbol recycled package))
+            ((and status (eq package (symbol-package existing))))
+            (t
+             (when status
+               (note-package-fishiness
+                :ensure-symbol name
+                (reify-package (symbol-package existing) package)
+                status intern)
+               (unintern existing))
+             (when intern
+               (intern* name package))))))))
+  (declaim (ftype function ensure-exported))
+  (defun ensure-exported-to-user (name symbol to-package &optional recycle)
+    (check-type name string)
+    (check-type symbol symbol)
+    (check-type to-package package)
+    (check-type recycle list)
+    (multiple-value-bind (existing status) (find-symbol name to-package)
+      (unless (and status (eq symbol existing))
+        (let ((accessible
+                (or (null status)
+                    (let ((shadowing (symbol-shadowing-p existing to-package))
+                          (recycled (symbol-recycled-p existing recycle)))
+                      (unless (and shadowing (not recycled))
+                        (note-package-fishiness
+                         :ensure-export name (symbol-package-name symbol)
+                         (package-name to-package)
+                         (or (home-package-p existing to-package) (symbol-package-name existing))
+                         status shadowing)
+                        (if (or (eq status :inherited) shadowing)
+                            (shadowing-import symbol to-package)
+                            (unintern existing to-package))
+                        t)))))
+          (when (and accessible (eq status :external))
+            (ensure-exported name symbol to-package recycle))))))
+  (defun ensure-exported (name symbol from-package &optional recycle)
+    (dolist (to-package (package-used-by-list from-package))
+      (ensure-exported-to-user name symbol to-package recycle))
+    (import symbol from-package)
+    (export* name from-package))
+  (defun ensure-export (name from-package &optional recycle)
+    (multiple-value-bind (symbol status) (find-symbol* name from-package)
+      (unless (eq status :external)
+        (ensure-exported name symbol from-package recycle))))
   (defun ensure-package (name &key
                                 nicknames documentation use
                                 shadow shadowing-import-from
@@ -346,239 +542,98 @@ or when loading the package is optional."
                                 recycle mix reexport
                                 unintern)
     #+(or gcl2.6 genera) (declare (ignore documentation))
-    (macrolet ((when-fishy (&body body) `(when-package-fishiness ,@body))
-               (fishy (&rest info) `(note-package-fishiness ,@info)))
-      (let* ((package-name (string name))
-             (nicknames (mapcar #'string nicknames))
-             (names (cons package-name nicknames))
-             (previous (packages-from-names names))
-             (discarded (cdr previous))
-             (to-delete ())
-             (package (or (first previous) (make-package package-name :nicknames nicknames)))
-             (recycle (packages-from-names recycle))
-             (use (mapcar 'find-package* use))
-             (mix (mapcar 'find-package* mix))
-             (reexport (mapcar 'find-package* reexport))
-             (shadow (mapcar 'string shadow))
-             (export (mapcar 'string export))
-             (intern (mapcar 'string intern))
-             (unintern (mapcar 'string unintern))
-             (shadowed (make-hash-table :test 'equal)) ; string to bool
-             (imported (make-hash-table :test 'equal)) ; string to bool
-             (exported (make-hash-table :test 'equal)) ; string to bool
-             ;; string to list home package and use package:
-             (inherited (make-hash-table :test 'equal)))
-        (when-fishy (record-fishy package-name))
-        (labels
-            ((ensure-shadowing-import (name p)
-               (let ((import-me (find-symbol* name p)))
-                 (multiple-value-bind (existing status) (find-symbol name package)
-                   (cond
-                     ((gethash name shadowed)
-                      (unless (eq import-me existing)
-                        (error "Conflicting shadowings for ~A" name)))
-                     (t
-                      (setf (gethash name shadowed) t)
-                      (setf (gethash name imported) t)
-                      (unless (or (null status)
-                                  (and (member status '(:internal :external))
-                                       (eq existing import-me)
-                                       (symbol-shadowing-p existing package)))
-                        (fishy :shadowing-import
-                               name (package-name p) (symbol-package-name import-me)
-                               (and status (symbol-package-name existing)) status))
-                      (shadowing-import import-me package))))))
-             (ensure-import (sym p)
-               (let* ((name (string sym))
-                      (import-me (find-symbol* name p)))
-                 (multiple-value-bind (existing status) (find-symbol name package)
-                   (cond
-                     ((gethash name imported)
-                      (unless (eq import-me existing)
-                        (error "Can't import ~S from both ~S and ~S"
-                               name (package-name (symbol-package existing)) (package-name p))))
-                     ((gethash name shadowed)
-                      (error "Can't both shadow ~S and import it from ~S" name (package-name p)))
-                     (t
-                      (setf (gethash name imported) t)
-                      (unless (and status (eq import-me existing))
-                        (when status
-                          (fishy :import name (package-name p) (symbol-package-name import-me)
-                                 (and status (symbol-package-name existing)) status)
-                          (unintern* existing package))
-                        (import import-me package)))))))
-             (ensure-mix (name symbol p)
-               (unless (gethash name shadowed)
-                 (multiple-value-bind (existing status) (find-symbol name package)
-                   (let* ((sp (symbol-package symbol))
-                          (im (gethash name imported))
-                          (in (gethash name inherited)))
-                     (cond
-                       ((or (null status)
-                            (and status (eq symbol existing))
-                            (and in (eq sp (first in))))
-                        (ensure-inherited name symbol p t))
-                       (in
-                        (remhash name inherited)
-                        (ensure-shadowing-import name (second in)))
-                       (im
-                         (error "Imported symbol ~S conflicts with inherited symbol ~S in ~S"
-                                existing symbol (package-name package)))
-                       (t
-                        (ensure-inherited name symbol p t)))))))
-             (ensure-inherited (name symbol p mix)
-               (multiple-value-bind (existing status) (find-symbol name package)
-                 (let* ((sp (symbol-package symbol))
-                        (in (gethash name inherited))
-                        (xp (and status (symbol-package existing))))
-                   (when (null sp)
-                     (fishy :import-uninterned name (package-name p) mix)
-                     (import symbol p)
-                     (setf sp (package-name p)))
-                   (cond
-                     ((gethash name shadowed))
-                     (in
-                      (unless (equal sp (first in))
-                        (if mix
-                            (ensure-shadowing-import name (second in))
-                            (error "Can't inherit ~S from ~S, it is inherited from ~S"
-                                   name (package-name sp) (package-name (first in))))))
-                     ((gethash name imported)
-                      (unless (eq symbol existing)
-                        (error "Can't inherit ~S from ~S, it is imported from ~S"
-                               name (package-name sp) (package-name xp))))
-                     (t
-                      (setf (gethash name inherited) (list sp p))
-                      (when (and status (not (eq sp xp)))
-                        (let ((shadowing (symbol-shadowing-p existing package)))
-                          (fishy :inherited name (package-name p) (package-name sp)
-                                 (package-name xp))
-                          (if shadowing (ensure-shadowing-import name p)
-                              (unintern* existing package)))))))))
-             (recycle-symbol (name)
-               (when (gethash name exported) ;; don't bother recycling private symbols
-                 (let (recycled foundp)
-                   (dolist (r recycle (values recycled foundp))
-                     (multiple-value-bind (symbol status) (find-symbol name r)
-                       (when (and status (home-package-p symbol r))
-                         (cond
-                           (foundp
-                            ;; (nuke-symbol symbol)) -- even simple variable names like O or C will do that.
-                            (fishy :recycled-duplicate name (package-name foundp) (package-name r)))
-                           (t
-                            (setf recycled symbol foundp r)))))))))
-             (symbol-recycled-p (sym)
-               (member (symbol-package sym) recycle))
-             (ensure-symbol (name &optional intern)
-               (unless (or (gethash name shadowed)
-                           (gethash name imported)
-                           (gethash name inherited))
-                 (multiple-value-bind (existing status)
-                     (find-symbol name package)
-                   (multiple-value-bind (recycled previous) (recycle-symbol name)
-                     (cond
-                       ((and status (eq existing recycled) (eq previous package)))
-                       (previous
-                        (rehome-symbol recycled package))
-                       ((and status (eq package (symbol-package existing))))
-                       (t
-                        (when status
-                          (fishy :ensure-symbol name
-                                 (reify-package (symbol-package existing) package)
-                                 status intern)
-                          (unintern existing))
-                        (when intern
-                          (intern* name package))))))))
-             (ensure-export (name p)
-               (multiple-value-bind (symbol status) (find-symbol* name p)
-                 (unless (eq status :external)
-                   (ensure-exported name symbol p))))
-             (ensure-exported (name sym p)
-               (dolist (u (package-used-by-list p))
-                 (ensure-exported-to-user name sym u))
-               (export* sym p))
-             (ensure-exported-to-user (name sym u)
-               (multiple-value-bind (usym ustat) (find-symbol name u)
-                 (unless (and ustat (eq sym usym))
-                   (let ((accessible
-                           (or (null ustat)
-                               (let ((shadowing (symbol-shadowing-p usym u))
-                                     (recycled (symbol-recycled-p usym)))
-                                 (unless (and shadowing (not recycled))
-                                   (fishy :ensure-export name (symbol-package-name sym)
-                                          (package-name u)
-                                          (and ustat (symbol-package-name usym)) ustat shadowing)
-                                   (if (or (eq ustat :inherited) shadowing)
-                                       (shadowing-import sym u)
-                                       (unintern usym u))
-                                   t)))))
-                     (when (and accessible (eq ustat :external))
-                       (ensure-exported name sym u)))))))
-          #-(or gcl2.6 genera)
-          (when documentation (setf (documentation package t) documentation))
-          (loop :for p :in (set-difference (package-use-list package) (append mix use))
-                :do (fishy :use (package-names p)) (unuse-package p package))
-          (loop :for p :in discarded
-                :for n = (remove-if #'(lambda (x) (member x names :test 'equal))
-                                    (package-names p))
-                :do (fishy :nickname (package-names p))
-                    (cond (n (rename-package p (first n) (rest n)))
-                          (t (rename-package-away p)
-                             (push p to-delete))))
-          (rename-package package package-name nicknames)
-          (dolist (name unintern)
-            (multiple-value-bind (existing status) (find-symbol name package)
-              (when status
-                (unless (eq status :inherited)
-                  (fishy :unintern name (symbol-package-name existing) status)
-                  (unintern* name package nil)))))
-          (dolist (name export)
-            (setf (gethash name exported) t))
-          (dolist (p reexport)
-            (do-external-symbols (sym p)
-              (setf (gethash (string sym) exported) t)))
-          (do-external-symbols (sym package)
-            (let ((name (symbol-name sym)))
-              (unless (gethash name exported)
-                (fishy :over-exported name (symbol-package-name sym))
-                (unexport sym package))))
-          (dolist (name shadow)
-            (setf (gethash name shadowed) t)
-            (multiple-value-bind (existing status) (find-symbol name package)
-              (multiple-value-bind (recycled previous) (recycle-symbol name)
-                (let ((shadowing (and status (symbol-shadowing-p existing package))))
-                  (cond
-                    ((eq previous package))
-                    (previous
-                     (rehome-symbol recycled package))
-                    ((or (member status '(nil :inherited))
-                         (home-package-p existing package)))
-                    (t
-                     (let ((dummy (make-symbol name)))
-                       (fishy :shadow-imported name (symbol-package-name existing) status shadowing)
-                       (shadowing-import dummy package)
-                       (import dummy package)))))))
-            (shadow name package))
-          (loop :for (p . syms) :in shadowing-import-from
-                :for pp = (find-package* p) :do
-                  (dolist (sym syms) (ensure-shadowing-import (string sym) pp)))
-          (dolist (p mix)
-            (do-external-symbols (sym p) (ensure-mix (symbol-name sym) sym p)))
-          (loop :for (p . syms) :in import-from :do
-            (dolist (sym syms) (ensure-import sym p)))
-          (dolist (p (append use mix))
-            (do-external-symbols (sym p) (ensure-inherited (string sym) sym p nil))
-            (use-package p package))
-          (loop :for name :being :the :hash-keys :of exported :do
-            (ensure-symbol name t)
-            (ensure-export name package))
-          (dolist (name intern)
-            (ensure-symbol name t))
-          (do-symbols (sym package)
-            (ensure-symbol (symbol-name sym)))
-          (map () 'delete-package* to-delete)
-          (flush-fishy)
-          package)))))
+    (let* ((package-name (string name))
+           (nicknames (mapcar #'string nicknames))
+           (names (cons package-name nicknames))
+           (previous (packages-from-names names))
+           (discarded (cdr previous))
+           (to-delete ())
+           (package (or (first previous) (make-package package-name :nicknames nicknames)))
+           (recycle (packages-from-names recycle))
+           (use (mapcar 'find-package* use))
+           (mix (mapcar 'find-package* mix))
+           (reexport (mapcar 'find-package* reexport))
+           (shadow (mapcar 'string shadow))
+           (export (mapcar 'string export))
+           (intern (mapcar 'string intern))
+           (unintern (mapcar 'string unintern))
+           (shadowed (make-hash-table :test 'equal)) ; string to bool
+           (imported (make-hash-table :test 'equal)) ; string to bool
+           (exported (make-hash-table :test 'equal)) ; string to bool
+           ;; string to list home package and use package:
+           (inherited (make-hash-table :test 'equal)))
+      (when-package-fishiness (record-fishy package-name))
+      #-(or gcl2.6 genera)
+      (when documentation (setf (documentation package t) documentation))
+      (loop :for p :in (set-difference (package-use-list package) (append mix use))
+            :do (note-package-fishiness :over-use name (package-names p))
+                (unuse-package p package))
+      (loop :for p :in discarded
+            :for n = (remove-if #'(lambda (x) (member x names :test 'equal))
+                                (package-names p))
+            :do (note-package-fishiness :nickname name (package-names p))
+                (cond (n (rename-package p (first n) (rest n)))
+                      (t (rename-package-away p)
+                         (push p to-delete))))
+      (rename-package package package-name nicknames)
+      (dolist (name unintern)
+        (multiple-value-bind (existing status) (find-symbol name package)
+          (when status
+            (unless (eq status :inherited)
+              (note-package-fishiness
+               :unintern (package-name package) name (symbol-package-name existing) status)
+              (unintern* name package nil)))))
+      (dolist (name export)
+        (setf (gethash name exported) t))
+      (dolist (p reexport)
+        (do-external-symbols (sym p)
+          (setf (gethash (string sym) exported) t)))
+      (do-external-symbols (sym package)
+        (let ((name (symbol-name sym)))
+          (unless (gethash name exported)
+            (note-package-fishiness
+             :over-export (package-name package) name
+             (or (home-package-p sym package) (symbol-package-name sym)))
+            (unexport sym package))))
+      (dolist (name shadow)
+        (setf (gethash name shadowed) t)
+        (multiple-value-bind (existing status) (find-symbol name package)
+          (multiple-value-bind (recycled previous) (recycle-symbol name recycle exported)
+            (let ((shadowing (and status (symbol-shadowing-p existing package))))
+              (cond
+                ((eq previous package))
+                (previous
+                 (rehome-symbol recycled package))
+                ((or (member status '(nil :inherited))
+                     (home-package-p existing package)))
+                (t
+                 (let ((dummy (make-symbol name)))
+                   (note-package-fishiness
+                    :shadow-imported (package-name package) name
+                    (symbol-package-name existing) status shadowing)
+                   (shadowing-import dummy package)
+                   (import dummy package)))))))
+        (shadow name package))
+      (loop :for (p . syms) :in shadowing-import-from
+            :for pp = (find-package* p) :do
+              (dolist (sym syms) (ensure-shadowing-import (string sym) package pp shadowed imported)))
+      (dolist (p mix)
+        (do-external-symbols (sym p) (ensure-mix (symbol-name sym) sym package p shadowed imported inherited)))
+      (loop :for (p . syms) :in import-from
+            :for pp = (find-package p) :do
+              (dolist (sym syms) (ensure-import (symbol-name sym) package pp shadowed imported)))
+      (dolist (p (append use mix))
+        (do-external-symbols (sym p) (ensure-inherited (string sym) sym package p nil shadowed imported inherited))
+        (use-package p package))
+      (loop :for name :being :the :hash-keys :of exported :do
+        (ensure-symbol name package t recycle shadowed imported inherited exported)
+        (ensure-export name package recycle))
+      (dolist (name intern)
+        (ensure-symbol name package t recycle shadowed imported inherited exported))
+      (do-symbols (sym package)
+        (ensure-symbol (symbol-name sym) package nil recycle shadowed imported inherited exported))
+      (map () 'delete-package* to-delete)
+      package)))
 
 (eval-when (:load-toplevel :compile-toplevel :execute)
   (defun parse-define-package-form (package clauses)
diff --git a/system.lisp b/system.lisp
index 713f8e8fa..91daaa0c2 100644
--- a/system.lisp
+++ b/system.lisp
@@ -72,8 +72,11 @@ in which the system specification (.asd file) is located."
   (subpathname (system-source-directory system) name :type type))
 
 (defmethod component-pathname ((system system))
-  (or (call-next-method)
-      (system-source-directory system)))
+  (let ((pathname (or (call-next-method) (system-source-directory system))))
+    (unless (and (slot-boundp system 'relative-pathname) ;; backward-compatibility with ASDF1-age
+                 (slot-value system 'relative-pathname)) ;; systems that directly access this slot.
+      (setf (slot-value system 'relative-pathname) pathname))
+    pathname))
 
 (defmethod component-relative-pathname ((system system))
   (parse-unix-namestring
diff --git a/test/run-tests.sh b/test/run-tests.sh
index 40d56661d..4adc93094 100755
--- a/test/run-tests.sh
+++ b/test/run-tests.sh
@@ -225,10 +225,6 @@ fi
 
 ASDFDIR="$(cd $(dirname $0)/.. ; /bin/pwd)"
 
-## Make sure testing remains within the confines of this filesystem tree
-export CL_SOURCE_REGISTRY="${ASDFDIR}"
-export ASDF_OUTPUT_TRANSLATIONS="(:output-translations (\"${ASDFDIR}\" (\"${ASDFDIR}/build/fasls\" :implementation)) :ignore-inherited-configuration)"
-
 cmd="$command $flags"
 debugp=
 if [ -z "${DEBUG_ASDF_TEST}" ] ; then
diff --git a/test/script-support.lisp b/test/script-support.lisp
index 24208297f..a70586ede 100644
--- a/test/script-support.lisp
+++ b/test/script-support.lisp
@@ -430,30 +430,6 @@ is bound, write a message and exit on an error.  If
             (cons (format nil "~{~D~^.~}" ver))
             (null "1.0"))))))
 
-(defun test-upgrade (old-method new-method tag) ;; called by run-test
-  (with-test ()
-    (verbose t nil)
-    (when old-method
-      (cond
-        ((string-equal tag "REQUIRE")
-         (format t "Requiring some previous ASDF ~A~%" tag)
-         (ignore-errors (funcall 'require "asdf"))
-         (if (member "ASDF" *modules* :test 'equalp)
-             (format t "Your Lisp implementation provided ASDF ~A~%" (get-asdf-version))
-             (leave-test "Your Lisp implementation does not provide ASDF. Skipping test.~%" 0)))
-        (t
-         (format t "Loading old asdf ~A via ~A~%" tag old-method)
-         (funcall old-method tag))))
-    (when (asym :*asdf-verbose* nil nil) (setf (asymval :*asdf-verbose*) t))
-    (when (asym :*verbose-out* nil nil) (setf (asymval :*verbose-out*) *standard-output*))
-    (format t "Now loading new asdf via method ~A~%" new-method)
-    (funcall new-method)
-    (format t "Testing it~%")
-    (register-directory *test-directory*)
-    (load-test-system :test-module-depend)
-    (assert (eval (intern (symbol-name '#:*file1*) :test-package)))
-    (assert (eval (intern (symbol-name '#:*file3*) :test-package)))))
-
 (defun output-location (&rest sublocation)
   (list* *asdf-directory* "build/fasls" :implementation sublocation))
 (defun resolve-output (&rest sublocation)
@@ -477,27 +453,30 @@ is bound, write a message and exit on an error.  If
   (clean-asdf-system))
 
 (defun configure-asdf ()
-  (setf *debug-asdf* (or *debug-asdf* (acall :getenvp "DEBUG_ASDF_TEST")))
-  (untrace)
+  (when (asym :getenvp nil nil)
+    (setf *debug-asdf* (or *debug-asdf* (acall :getenvp "DEBUG_ASDF_TEST"))))
   (eval `(trace ,@(loop :for s :in *trace-symbols* :collect (asym s))))
-  (acall :initialize-source-registry
-         `(:source-registry :ignore-inherited-configuration))
-  (acall :initialize-output-translations
-         `(:output-translations
-           ((,*asdf-directory* :**/ :*.*.*) ,(output-location "asdf"))
-           (t ,(output-location "root"))
-           :ignore-inherited-configuration))
+  (when (asym :initialize-source-registry nil nil)
+    (acall :initialize-source-registry
+           `(:source-registry :ignore-inherited-configuration)))
+  (when (asym :initialize-output-translations nil nil)
+    (acall :initialize-output-translations
+           `(:output-translations
+             ((,*asdf-directory*) ,(output-location "asdf"))
+             (t ,(output-location "root"))
+             :ignore-inherited-configuration)))
   (set (asym :*central-registry*) `(,*test-directory*))
   (when (asym :*asdf-verbose*) (setf (asymval :*asdf-verbose*) t))
   (when (asym :*verbose-out*) (setf (asymval :*verbose-out*) *standard-output*))
-  (let ((x (acall :system-source-directory :hello-world-example)))
-    (assert-pathname-equal *test-directory* x) ;; not always EQUAL (!)
-    (unless (equal *test-directory* x)
-      (format t "Interestingly, while *test-directory* has components~% ~S~%~
+  (when (asym :system-source-directory nil nil)
+    (let ((x (acall :system-source-directory :test-module-depend)))
+      (assert-pathname-equal *test-directory* x) ;; not always EQUAL (!)
+      (unless (equal *test-directory* x)
+        (format t "Interestingly, while *test-directory* has components~% ~S~%~
                  ASDF finds the ASDs in~% ~S~%Using the latter.~%"
-              (pathname-components *test-directory*)
-              (pathname-components x)))
-    (setf *test-directory* x))
+                (pathname-components *test-directory*)
+                (pathname-components x)))
+      (setf *test-directory* x)))
   t)
 
 (defun load-asdf (&optional tag)
@@ -537,6 +516,31 @@ is bound, write a message and exit on an error.  If
     (acall :load-system sys))
   (format t "~&Done!~%"))
 
+(defun test-upgrade (old-method new-method tag) ;; called by run-test
+  (with-test ()
+    (verbose t nil)
+    (when old-method
+      (cond
+        ((string-equal tag "REQUIRE")
+         (format t "Requiring some previous ASDF ~A~%" tag)
+         (ignore-errors (funcall 'require "asdf"))
+         (if (member "ASDF" *modules* :test 'equalp)
+             (format t "Your Lisp implementation provided ASDF ~A~%" (get-asdf-version))
+             (leave-test "Your Lisp implementation does not provide ASDF. Skipping test.~%" 0)))
+        (t
+         (format t "Loading old asdf ~A via ~A~%" tag old-method)
+         (funcall old-method tag))))
+    (configure-asdf)
+    (when (asym :*asdf-verbose* nil nil) (setf (asymval :*asdf-verbose*) t))
+    (when (asym :*verbose-out* nil nil) (setf (asymval :*verbose-out*) *standard-output*))
+    (format t "Now loading new asdf via method ~A~%" new-method)
+    (funcall new-method)
+    (format t "Testing it~%")
+    (register-directory *test-directory*)
+    (load-test-system :test-module-depend)
+    (assert (eval (intern (symbol-name '#:*file1*) :test-package)))
+    (assert (eval (intern (symbol-name '#:*file3*) :test-package)))))
+
 ;; These are shorthands for interactive debugging of test scripts:
 (!a
  common-lisp-user::debug-asdf debug-asdf
diff --git a/upgrade.lisp b/upgrade.lisp
index ae86a8984..26fbf7e1e 100644
--- a/upgrade.lisp
+++ b/upgrade.lisp
@@ -52,7 +52,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO
          ;; "3.4.5.67" would be a development version in the official upstream of 3.4.5.
          ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5
          ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67
-         (asdf-version "2.26.165")
+         (asdf-version "2.26.166")
          (existing-version (asdf-version)))
     (setf *asdf-version* asdf-version)
     (when (and existing-version (not (equal asdf-version existing-version)))
diff --git a/utility.lisp b/utility.lisp
index ce3fc62f5..12470858e 100644
--- a/utility.lisp
+++ b/utility.lisp
@@ -52,30 +52,29 @@
        #-gcl2.6 (fmakunbound function-spec))
       (t (error "bad function spec ~S" function-spec))))
   (defun undefine-functions (function-spec-list)
-    (map () 'undefine-function function-spec-list)))
-
-(macrolet
-    ((defdef (def* def)
-       `(defmacro ,def* (name formals &rest rest)
-          (destructuring-bind (name &key (supersede t))
-              (if (or (atom name) (eq (car name) 'setf))
-                  (list name :supersede nil)
-                  name)
-            (declare (ignorable supersede))
-            `(progn
-             ;; undefining the previous function is the portable way
-             ;; of overriding any incompatible previous gf, except on CLISP.
-             ;; We usually try to do it only for the functions that need it,
-             ;; which happens in asdf/upgrade - however, for ECL, we need this hammer,
-             ;; (which causes issues in clisp)
-               ,@(when (or #-clisp supersede #+(or ecl gcl2.7) t) ; XXX
-                   `((undefine-function ',name)))
-               #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-(
-               ,@(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl
-                   `((declaim (notinline ,name))))
-               (,',def ,name ,formals ,@rest))))))
-  (defdef defgeneric* defgeneric)
-  (defdef defun* defun))
+    (map () 'undefine-function function-spec-list))
+  (macrolet
+      ((defdef (def* def)
+         `(defmacro ,def* (name formals &rest rest)
+            (destructuring-bind (name &key (supersede t))
+                (if (or (atom name) (eq (car name) 'setf))
+                    (list name :supersede nil)
+                    name)
+              (declare (ignorable supersede))
+              `(progn
+                 ;; undefining the previous function is the portable way
+                 ;; of overriding any incompatible previous gf, except on CLISP.
+                 ;; We usually try to do it only for the functions that need it,
+                 ;; which happens in asdf/upgrade - however, for ECL, we need this hammer,
+                 ;; (which causes issues in clisp)
+                 ,@(when (or #-clisp supersede #+(or ecl gcl2.7) t) ; XXX
+                     `((undefine-function ',name)))
+                 #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-(
+                 ,@(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl
+                     `((declaim (notinline ,name))))
+                 (,',def ,name ,formals ,@rest))))))
+    (defdef defgeneric* defgeneric)
+    (defdef defun* defun)))
 
 
 ;;; Magic debugging help. See contrib/debug.lisp
diff --git a/version.lisp-expr b/version.lisp-expr
index d1c20033f..0211e0c14 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -1 +1 @@
-"2.26.165"
+"2.26.166"
-- 
GitLab