2.26.69: Victory! test-upgrade now works with CCL and SBCL.

Had to fix a few more issues in package update,
add support for frobbing CCL setf function names,
and fix upgrade detection for the new package world.

diff --git a/asdf.asd b/asdf.asd
index 827f181..ba0f23e 100644 (file)
--- a/asdf.asd
+++ b/asdf.asd
@@ -14,7 +14,7 @@
   :licence "MIT"
   :description "Another System Definition Facility"
   :long-description "ASDF builds Common Lisp software organized into defined systems."
-  :version "2.26.68" ;; to be automatically updated by bin/bump-revision
+  :version "2.26.69" ;; to be automatically updated by bin/bump-revision
   :depends-on ()
   :components
   ((:file "asdf")))

diff --git a/header.lisp b/header.lisp
index 2a95609..e55e325 100644 (file)
--- a/header.lisp
+++ b/header.lisp
@@ -1,5 +1,5 @@
 ;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
-;;; This is ASDF 2.26.68: Another System Definition Facility.
+;;; This is ASDF 2.26.69: 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 38089b2..c908700 100644 (file)
--- a/package.lisp
+++ b/package.lisp
@@ -75,6 +75,53 @@ when the symbol is not found."
               (error (error "symbol ~A not present in package ~A"
                             (string symbol) (package-name package))))))
         (values nil nil))))
+  (defun symbol-shadowing-p (symbol package)
+    (member symbol (package-shadowing-symbols package)))
+  (defun rehome-symbol (symbol package-designator)
+    "Changes the home package of a symbol, also leaving it present in its old home if any"
+    (let* ((name (symbol-name symbol))
+           (package (find-package* package-designator))
+           (old-package (symbol-package symbol))
+           (old-status (and old-package (nth-value 1 (find-symbol name old-package))))
+           (shadowing (and old-package (symbol-shadowing-p symbol old-package) (make-symbol name))))
+      (multiple-value-bind (overwritten-symbol overwritten-symbol-status) (find-symbol name package)
+        (unless (eq package old-package)
+          (let ((overwritten-symbol-shadowing-p
+                  (and overwritten-symbol-status
+                       (symbol-shadowing-p overwritten-symbol package))))
+            (when old-package
+              (if shadowing
+                  (shadowing-import shadowing old-package))
+                  (unintern symbol old-package))
+            (cond
+              (overwritten-symbol-shadowing-p
+               (shadowing-import symbol package))
+              (t
+               (when overwritten-symbol-status
+                 (unintern overwritten-symbol package))
+               (import symbol package)))
+            (if shadowing
+                (shadowing-import symbol old-package)
+                (import symbol old-package))
+            #+ccl
+            (multiple-value-bind (setf-name foundp)
+                (gethash symbol ccl::%setf-function-names%)
+              (when foundp
+                (let* ((setf-function (fdefinition setf-name))
+                       (new-setf-name (ccl::construct-setf-function-name symbol)))
+                  (setf (fdefinition new-setf-name) setf-function
+                        (gethash symbol ccl::%setf-function-names%) new-setf-name
+                        (gethash new-setf-name ccl::%setf-function-name-inverses%) symbol))))
+            #+ccl
+            (multiple-value-bind (overwritten-setf foundp)
+                (gethash overwritten-symbol ccl::%setf-function-names%)
+              (when foundp
+                (unintern overwritten-setf)))
+            (when (eq old-status :external)
+              (export symbol old-package))
+            (when (eq overwritten-symbol-status :external)
+              (export symbol package))))
+        (values overwritten-symbol overwritten-symbol-status))))
   (defun symbol-name-package (symbol)
     (cons (symbol-name symbol) (package-name (symbol-package symbol))))
   (defun package-names (package)
@@ -125,6 +172,8 @@ when the symbol is not found."
     (loop :for name :in symbols
           :for sym = (find-symbol* name package nil)
           :when sym :do #-gcl (fmakunbound `(setf ,sym))))
+  (defun packages-from-names (names)
+    (remove-duplicates (remove nil (mapcar #'find-package names)) :from-end t))
   (defun ensure-package (name &key
                                 upgrade
                                 nicknames documentation use
@@ -132,29 +181,17 @@ when the symbol is not found."
                                 import-from export intern
                                 recycle mix reexport
                                 unintern fmakunbound fmakunbound-setf)
-    (DBG :ensure-package name nicknames upgrade documentation use
-         shadow shadowing-import-from
-         import-from export intern
-         recycle mix reexport
-         unintern fmakunbound fmakunbound-setf)
-    (let* ((nicknames (mapcar #'string nicknames))
-           (shadow (mapcar #'string shadow))
-           (shadowing-import-from (loop :for sif :in shadowing-import-from
-                                        :collect (mapcar #'string sif)))
-           (import-from (loop :for if :in import-from
-                              :collect (mapcar #'string if)))
-           (export (mapcar #'string export))
-           (recycle (remove nil (mapcar #'find-package recycle)))
-           (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
-           (inherited (make-hash-table :test 'equal)) ; string to package name
-           (name (string name))
+    (let* ((name (string name))
            (nicknames (mapcar #'string nicknames))
            (names (cons name nicknames))
-           (previous (remove-duplicates (remove nil (mapcar #'find-package names)) :from-end t))
+           (previous (packages-from-names names))
            (discarded (cdr previous))
-           (package (DBG :xxx names previous discarded (or (first previous) (make-package name :nicknames nicknames)))))
+           (package (or (first previous) (make-package name :nicknames nicknames)))
+           (recycle (packages-from-names recycle))
+           (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
+           (inherited (make-hash-table :test 'equal))) ; string to package name
       (labels
           ((ensure-shadowing-import (sym p)
              (let* ((name (string sym))
@@ -166,7 +203,7 @@ when the symbol is not found."
                  (t
                     (setf (gethash name shadowed) t)
                     (setf (gethash name imported) t)
-                    (shadowing-import package)))))
+                    (shadowing-import i package)))))
            (ensure-import (sym p)
              (let* ((name (string sym))
                     (i (find-symbol* name p)))
@@ -218,12 +255,12 @@ when the symbol is not found."
                     (when xp
                       (unintern* x package)))))))
            (recycle-symbol (name)
-             (loop :for r :in recycle
-                   :for s = (find-symbol* name r nil)
-                   :when s :do (return (values s r))))
+             (dolist (r recycle (values nil nil))
+               (multiple-value-bind (symbol status) (find-symbol name r)
+                 (when (and status (eq r (symbol-package symbol)))
+                   (return (values symbol r))))))
            (symbol-recycled-p (sym)
-             (loop :for r :in recycle
-                   :thereis (multiple-value-bind (s sp) (find-symbol* sym r nil) (and sp (eq sym s)))))
+             (member (symbol-package sym) recycle))
            (ensure-symbol (name &optional intern)
              (unless (or (gethash name shadowed)
                          (gethash name imported)
@@ -233,7 +270,7 @@ when the symbol is not found."
                    ((eq previous package))
                    ((or (not previous) (not (member (symbol-package recycled) recycle)))
                     (when intern (intern* name package)))
-                   (t (unintern* name package nil) (unintern* recycled previous) (import recycled package))))))
+                   (t (rehome-symbol recycled package))))))
            (ensure-export (name p)
              (multiple-value-bind (symbol status) (find-symbol name p)
                (assert status)
@@ -258,34 +295,24 @@ when the symbol is not found."
                        (ensure-exported name sym u))))))))
         (assert (soft-upgrade-p upgrade))
         (setf (documentation package t) documentation)
-        ;;#+DBG (untrace)(trace find-symbol make-package delete-package use-package unuse-package import export intern shadow shadowing-import unintern unexport)
-        (DBG :names names package previous discarded (package-data package :name-package t))
         (loop :for p :in discarded
               :for n = (remove-if #'(lambda (x) (member x names :test 'equal))
                                   (package-names p))
-              :do (DBG :baz (package-names p) n)
               :do (if n (rename-package discarded (first n) (rest n))
                       (delete-package* discarded)))
         (rename-package package name nicknames)
-        (DBG :unuse)
         (loop :for p :in (set-difference (package-use-list package) (append mix use))
               :do (unuse-package p package))
-        (DBG :unintern)
         (dolist (name unintern) (unintern* name package nil))
-        (DBG :export?)
         (loop :for sym :in export :for name = (string sym) :do
           (setf (gethash name exported) t))
-        (DBG :reexport)
         (loop :for p :in reexport :do
           (do-external-symbols (sym p)
             (let ((name (string sym)))
               (export (find-symbol* name package) package) (setf (gethash name exported) t))))
-        (DBG :unexport)
         (do-external-symbols (sym package)
           (unless (gethash (symbol-name sym) exported) (unexport sym package)))
-        (DBG :shadow)
         (loop :for s :in shadow :for name = (string s) :do
-          (DBG :sha name)
           (setf (gethash name shadowed) t)
           (multiple-value-bind (recycled previous) (recycle-symbol name)
             (cond
@@ -294,36 +321,28 @@ when the symbol is not found."
                  ((nil :inherited) (shadow name package))
                  ((:internal :external) (shadowing-import (make-symbol name) package))))
               ((eq previous package) (shadow recycled package))
-              (t (unintern* recycled previous) (shadowing-import recycled package)))))
+              (t (rehome-symbol recycled package)))))
         (loop :for (p . syms) :in shadowing-import-from :do
-          (DBG :shaif p syms)
           (dolist (sym syms) (ensure-shadowing-import sym p)))
         (loop :for p :in mix :do
-          (DBG :mix p)
           (do-external-symbols (sym p) (ensure-mix sym p)))
         (loop :for (p . syms) :in import-from :do
-          (DBG :if p syms)
           (dolist (sym syms) (ensure-import sym p)))
         (loop :for p :in use :for sp = (string p) :for pp = (find-package sp) :do
-          (DBG :use p sp pp)
           (do-external-symbols (sym pp) (ensure-inherited sym sp))
           (use-package pp package))
-        (DBG :intern)
         (loop :for name :being :the :hash-keys :of exported :do
           (ensure-symbol name t))
         (dolist (name (append intern fmakunbound fmakunbound-setf))
           (ensure-symbol (string name) t))
-        (DBG :cleanup)
         (do-symbols (sym package)
           (ensure-symbol (symbol-name sym)))
-        (DBG :export)
         (loop :for name :being :the :hash-keys :of exported :do
           (ensure-export name package))
         ;; do away with packages with conflicting (nick)names
         ;; note from ASDF 2.26: ECL might not be liking an early fmakunbound (below #-ecl'ed)
         (ensure-package-fmakunbound package fmakunbound)
         (ensure-package-fmakunbound-setf package fmakunbound-setf)
-        ;;#+DBG (untrace)
         package))))
 
 (eval-when (:load-toplevel :compile-toplevel :execute)

diff --git a/upgrade.lisp b/upgrade.lisp
index de3e005..0c09862 100644 (file)
--- a/upgrade.lisp
+++ b/upgrade.lisp
@@ -24,19 +24,18 @@
          ;; "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.26.68")
-         (existing-asdf (find-class 'component nil))
+         (asdf-version "2.26.69")
+         (existing-asdf (find-class (find-symbol* :component :asdf nil) nil))
          (existing-version *asdf-version*)
          (already-there (equal asdf-version existing-version)))
     (unless (and existing-asdf already-there)
-      (when (and existing-asdf *asdf-verbose*)
-        (format *trace-output*
-                "~&; Upgrading ASDF ~@[from version ~A ~]to version ~A~%"
-                existing-version asdf-version))
-      (setf *asdf-version* asdf-version
-            *upgraded-p* (if existing-version
-                             (cons existing-version *upgraded-p*)
-                             *upgraded-p*)))))
+      (when existing-asdf
+        (asdf-message "~&; Upgrading ASDF ~@[from version ~A ~]to version ~A~%"
+                      existing-version asdf-version))
+      (unless already-there
+        (push existing-version *upgraded-p*))
+      (setf *asdf-version* asdf-version))))
+
 
 ;;;; User interface