2.26.117: fix setf symbol frobbing on CLISP.

Also remove some forgotten debugging statement,
clean the asd somewhat.

diff --git a/asdf.asd b/asdf.asd
index 05d6466..781c63b 100644 (file)
--- a/asdf.asd
+++ b/asdf.asd
@@ -15,7 +15,7 @@
   :licence "MIT"
   :description "Another System Definition Facility"
   :long-description "ASDF builds Common Lisp software organized into defined systems."
-  :version "2.26.116" ;; to be automatically updated by bin/bump-revision
+  :version "2.26.117" ;; to be automatically updated by bin/bump-revision
   :depends-on ()
   :components ((:module "build" :components ((:file "asdf"))))
   :in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op generate-asdf))))
@@ -66,6 +66,7 @@
    (:file "interface")
    (:file "footer" :depends-on ("interface"))))
 
+#+asdf2.27
 (defsystem :asdf/header
   :components
   ((:static-file "header.lisp")))

diff --git a/find-system.lisp b/find-system.lisp
index e50284c..3206de4 100644 (file)
--- a/find-system.lisp
+++ b/find-system.lisp
@@ -284,8 +284,6 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
     (check-type found (or null pathname system))
     (values foundp found-system pathname previous previous-time)))
 
-(asdf-debug)
-
 (defmethod find-system ((name string) &optional (error-p t))
   (with-system-definitions ()
     (loop

diff --git a/footer.lisp b/footer.lisp
index 7c8cb3b..c188b22 100644 (file)
--- a/footer.lisp
+++ b/footer.lisp
@@ -68,6 +68,7 @@
 (when *load-verbose*
   (asdf-message ";; ASDF, version ~a~%" (asdf-version)))
 
+
 ;;; Local Variables:
 ;;; mode: lisp
 ;;; End:

diff --git a/header.lisp b/header.lisp
index d06feab..20d4ef4 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.116: Another System Definition Facility.
+;;; This is ASDF 2.26.117: 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 e2373cf..d07eb9b 100644 (file)
--- a/package.lisp
+++ b/package.lisp
@@ -113,6 +113,24 @@ or when loading the package is optional."
              (make-symbol* symbol-name)))))))
 
 (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*))
+  (defmacro when-package-fishiness (&body body)
+    `(when *all-package-fishiness* ,@body))
+  (defmacro note-package-fishiness (&rest info)
+    `(when-package-fishiness (record-fishy (list ,@info)))))
+
+(eval-when (:load-toplevel :compile-toplevel :execute)
   #+(or clisp clozure)
   (defun get-setf-function-symbol (symbol)
     #+clisp (let ((sym (get symbol 'system::setf-function)))
@@ -133,7 +151,9 @@ or when loading the package is optional."
       ((eq kind :setf-function)
        (setf (get symbol 'system::setf-function) new-setf-symbol))
       ((eq kind :setf-expander)
-       (setf (get symbol 'system::setf-expander) new-setf-symbol)))
+       (setf (get symbol 'system::setf-expander) new-setf-symbol))
+      (t (error "invalid kind of setf-function ~S for ~S to be set to ~S"
+                kind symbol new-setf-symbol)))
     #+clozure
     (progn
       (gethash symbol ccl::%setf-function-names%) new-setf-symbol
@@ -181,6 +201,10 @@ or when loading the package is optional."
           (let ((overwritten-symbol-shadowing-p
                   (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)
             (when old-package
               (if shadowing
                   (shadowing-import shadowing old-package))
@@ -201,8 +225,15 @@ or when loading the package is optional."
               (when kind
                 (let* ((setf-function (fdefinition setf-symbol))
                        (new-setf-symbol (create-setf-function-symbol symbol)))
+                  (note-package-fishiness
+                   :setf-function
+                   name (package-name package)
+                   (symbol-name setf-symbol) (symbol-package-name setf-symbol)
+                   (symbol-name new-setf-symbol) (symbol-package-name new-setf-symbol))
+                  (when (symbol-package setf-symbol)
+                    (unintern setf-symbol (symbol-package setf-symbol)))
                   (setf (fdefinition new-setf-symbol) setf-function)
-                  (set-setf-function-symbol symbol new-setf-symbol kind))))
+                  (set-setf-function-symbol new-setf-symbol symbol kind))))
             #+(or clisp clozure)
             (multiple-value-bind (overwritten-setf foundp)
                 (get-setf-function-symbol overwritten-symbol)
@@ -299,34 +330,21 @@ or when loading the package is optional."
 ;;; ensure-package, define-package
 
 (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)
-    (push info *package-fishiness*))
   (defun ensure-package (name &key
                                 nicknames documentation use
                                 shadow shadowing-import-from
                                 import-from export intern
                                 recycle mix reexport
                                 unintern)
-    (macrolet ((when-fishy (&body body)
-                 `(when *all-package-fishiness* ,@body))
-               (fishy (&rest info)
-                 `(when-fishy (record-fishy (list ,@info)))))
-      (let* ((name (string name))
+    (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 name nicknames))
+             (names (cons package-name nicknames))
              (previous (packages-from-names names))
              (discarded (cdr previous))
              (to-delete ())
-             (package (or (first previous) (make-package name :nicknames nicknames)))
+             (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))
@@ -340,7 +358,7 @@ or when loading the package is optional."
              (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 name))
+        (when-fishy (record-fishy package-name))
         (labels
             ((ensure-shadowing-import (name p)
                (let ((import-me (find-symbol* name p)))
@@ -375,9 +393,9 @@ or when loading the package is optional."
                       (setf (gethash name imported) t)
                       (unless (and status (eq import-me existing))
                         (when status
-                          (unintern* existing package)
                           (fishy :import name (package-name p) (symbol-package-name import-me)
-                                 (and status (symbol-package-name existing)) status))
+                                 (and status (symbol-package-name existing)) status)
+                          (unintern* existing package))
                         (import import-me package)))))))
              (ensure-mix (name symbol p)
                (unless (gethash name shadowed)
@@ -424,16 +442,17 @@ or when loading the package is optional."
                           (if shadowing (ensure-shadowing-import name p)
                               (unintern* existing package)))))))))
              (recycle-symbol (name)
-               (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))))))))
+               (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)
@@ -450,10 +469,10 @@ or when loading the package is optional."
                        ((and status (eq package (symbol-package existing))))
                        (t
                         (when status
-                          (unintern existing)
                           (fishy :ensure-symbol name
                                  (reify-package (symbol-package existing) package)
-                                 status intern))
+                                 status intern)
+                          (unintern existing))
                         (when intern
                           (intern* name package))))))))
              (ensure-export (name p)
@@ -483,7 +502,7 @@ or when loading the package is optional."
                        (ensure-exported name sym u)))))))
           #-gcl (setf (documentation package t) documentation) #+gcl documentation
           (loop :for p :in (set-difference (package-use-list package) (append mix use))
-                :do (unuse-package p package) (fishy :use (package-names p)))
+                :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))
@@ -491,13 +510,13 @@ or when loading the package is optional."
                     (cond (n (rename-package p (first n) (rest n)))
                           (t (rename-package-away p)
                              (push p to-delete))))
-          (rename-package package name nicknames)
+          (rename-package package package-name nicknames)
           (dolist (name unintern)
             (multiple-value-bind (existing status) (find-symbol name package)
               (when status
                 (unless (eq status :inherited)
-                  (unintern* name package nil))
-                (fishy :unintern name (symbol-package-name existing) status))))
+                  (fishy :unintern name (symbol-package-name existing) status)
+                  (unintern* name package nil)))))
           (dolist (name export)
             (setf (gethash name exported) t))
           (dolist (p reexport)
@@ -516,8 +535,6 @@ or when loading the package is optional."
                   (cond
                     ((eq previous package))
                     (previous
-                     (fishy :shadow-recycled name (package-name previous)
-                            (and status (symbol-package-name existing)) status shadowing)
                      (rehome-symbol recycled package))
                     ((or (member status '(nil :inherited))
                          (home-package-p existing package)))

diff --git a/test/run-tests.sh b/test/run-tests.sh
index 82904df..3463d2a 100755 (executable)
--- a/test/run-tests.sh
+++ b/test/run-tests.sh
@@ -201,9 +201,9 @@ export CL_SOURCE_REGISTRY="${ASDFDIR}"
 export ASDF_OUTPUT_TRANSLATIONS="(:output-translations (\"${ASDFDIR}\" (\"${ASDFDIR}/build/fasls\" :implementation)) :ignore-inherited-configuration)"
 
 
-command="$command $flags"
+cmd="$command $flags"
 if [ -z "${DEBUG_ASDF_TEST}" ] ; then
-  command="$command $nodebug"
+  cmd="$cmd $nodebug"
 fi
 
 
@@ -282,12 +282,16 @@ run_upgrade_tests () {
             if valid_upgrade_test_p $lisp $tag $method ; then
                 echo "Testing ASDF upgrade from ${tag} using method $method"
                 extract_tagged_asdf $tag
-                $command $eval \
+                $cmd $eval \
                 "'(#.(load\"$su\")#.(in-package :asdf-test)#.(test-upgrade $method \"$tag\"))" ||
                 { echo "upgrade FAILED for $lisp from $tag using method $method" ;
                   echo "you can retry just that test with:" ;
                   echo ASDF_UPGRADE_TEST_TAGS=\"$tag\" ADSF_UPGRADE_TEST_METHODS=\"$method\" ./test/run-tests.sh -u $lisp ;
-                    exit 1 ;}
+                  echo "or more interactively (and maybe with rlwrap or in emacs), start with:"
+                  echo "$command"
+                  echo "then copy/paste:"
+                  echo "(load\"$su\") (da) (test-upgrade $method \"$tag\")"
+                  exit 1 ;}
     fi ; done ; done 2>&1 | tee build/results/${lisp}-upgrade.text
 }
 run_tests () {
@@ -296,7 +300,7 @@ run_tests () {
   mkdir -p ../build/results
   echo failure > ../build/results/status
     thedate=`date "+%Y-%m-%d"`
-    do_tests "$command" "$eval" 2>&1 | \
+    do_tests "$cmd" "$eval" 2>&1 | \
        tee "../build/results/${lisp}.text" "../build/results/${lisp}-${thedate}.save"
     read a < ../build/results/status
   clean_up
@@ -317,10 +321,10 @@ test_clean_load () {
     esac
     nop=build/results/${lisp}-nop.text
     load=build/results/${lisp}-load.text
-    ${command} ${eval} \
+    ${cmd} ${eval} \
       '(or #.(setf *load-verbose* nil) #.(load "test/script-support.lisp") #.(asdf-test::exit-lisp 0))' \
         > $nop 2>&1
-    ${command} ${eval} \
+    ${cmd} ${eval} \
       '(or #.(setf *load-verbose* nil) #.(load "build/asdf.lisp") #.(asdf/image:quit 0))' \
         > $load 2>&1
     if diff $nop $load ; then
@@ -330,7 +334,7 @@ test_clean_load () {
     fi
 }
 
-if [ -z "$command" ] ; then
+if [ -z "$cmd" ] ; then
     echo "Error: cannot find or do not know how to run Lisp named $lisp"
 elif [ -n "$clean_load" ] ; then
     test_clean_load

diff --git a/upgrade.lisp b/upgrade.lisp
index 5b997e3..2a2770c 100644 (file)
--- a/upgrade.lisp
+++ b/upgrade.lisp
@@ -45,7 +45,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.26.116")
+         (asdf-version "2.26.117")
          (existing-asdf (find-class (find-symbol* :component :asdf nil) nil))
          (existing-version *asdf-version*)
          (already-there (equal asdf-version existing-version)))

diff --git a/version.lisp-expr b/version.lisp-expr
index a43243c..409c327 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -1 +1 @@
-"2.26.116"
+"2.26.117"