diff --git a/asdf.asd b/asdf.asd index 05d646690cf045bb00e8e54a6e1d57c318bbdd27..781c63b354fe5fca55226298d251c260100cbe27 100644 --- 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 e50284c7702e333ae6bfd45e88c294875663a97b..3206de4e11530463ea99e982b809dace298b120c 100644 --- 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 7c8cb3b0d343f15c4846907807a68000eeb4f3aa..c188b22f431b8fa671ebe8d82908ec2a53331e4f 100644 --- 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 d06feab8cbcf649285aa2951ed1bcc8be129a7d7..20d4ef4b5ed64fb9bc56d12094b6d375a4102d5e 100644 --- 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 e2373cfc7a37de5ea69fbd22b48098561576e813..d07eb9bac38891a6e6393e0be1310b59747ea757 100644 --- a/package.lisp +++ b/package.lisp @@ -112,6 +112,24 @@ or when loading the package is optional." (if package (intern* symbol-name package) (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) @@ -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 82904dfda3e2f62c33b82c4f821808816cb3bd55..3463d2abfe00a7547308bfe8fcf70804e7c4a635 100755 --- 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 5b997e38bf01595ff828d90438505678118d519f..2a2770c3f4c50923f29e0897611f1d3f89d79eba 100644 --- 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 a43243cfde700ec4dd7b94f07455609a08b89c29..409c3274a62b59c07ac3aebadd82fab0d1b418e1 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -1 +1 @@ -"2.26.116" +"2.26.117"