From caf89a8a1aa2279f66dded1453a2afbde1d348d9 Mon Sep 17 00:00:00 2001 From: Robert Goldman <rpgoldman@sift.net> Date: Mon, 22 Mar 2021 18:33:52 +0000 Subject: [PATCH] fix #51; add comments to `ensure-package` Prior to this commit, we were trying to be far too smart when updating a package's package-local-nicknames: we'd only call `remove-package-local-nickname` on the set difference of the old nicknames and the new nicknames; that is, we would not remove and then reinstall a package-local-nickname which was already present and we wanted to keep. The bug which caused #51 was that the set-difference considered only the nickname, not the package to which it referred. But rather than worrying about accurately computing the minimal set of nicknames to remove, this commit just has `ensure-package` remove all package-local-nicknames, then reinstall the ones it wants. This may be either a performance improvement or regression depending on whether computing set differences is more or less expensive than manipulating package data structures, but my suspicion is that no one cares either way. Also, during the course of my debugging, I [Phoebe Goldman] added a few line-comments to the definition of `ensure-package` so that I could tell what various parts of its body were doing. I'd rather not write those comments again, so I'm including them in this commit. Tests incorporated and changelog updated. --- asdf.asd | 2 +- doc/Changelog | 10 +++++-- doc/asdf.texinfo | 4 +-- header.lisp | 2 +- test/test-package-local-nicknames.script | 16 ++++++++++ uiop/package.lisp | 37 +++++++++++++++++++----- uiop/version.lisp | 2 +- upgrade.lisp | 2 +- version.lisp-expr | 2 +- 9 files changed, 59 insertions(+), 18 deletions(-) diff --git a/asdf.asd b/asdf.asd index 932c5d575..218810a0c 100644 --- a/asdf.asd +++ b/asdf.asd @@ -93,7 +93,7 @@ :licence "MIT" :description "Another System Definition Facility" :long-description "ASDF builds Common Lisp software organized into defined systems." - :version "3.3.4.11" ;; to be automatically updated by make bump-version + :version "3.3.4.12" ;; to be automatically updated by make bump-version :depends-on () :components ((:module "build" :components ((:file "asdf")))) . #-asdf3 () #+asdf3 diff --git a/doc/Changelog b/doc/Changelog index 05d61a8fd..898e17565 100644 --- a/doc/Changelog +++ b/doc/Changelog @@ -3,16 +3,20 @@ cl-asdf (2:3.3.5-1) unstable; urgency=low IN PROGRESS * Fix bug in handling combination of :serial and :if-feature dependencies. * Add support for package local nicknames to UIOP:DEFINE-PACKAGE and ASDF's package-inferred systems. Extend support for package local - nicknames to more lisp implementations. + nicknames to more lisp implementations. Initial work by + François-René Rideau, with assists from Phoebe Goldman, MichaÅ‚ + Herda, and Eric Timmons. * A number of fixes for Lispworks compatibility (thanks to Martin Simmons). -* Fixes for SBCL and ECL from Eric Timmons. +* Fixes for SBCL and ECL from Eric Timmons and @pouar. * Add support for source files with different file extensions to package-inferred-systems. Thanks to Jingtao Xu for identifying the bug and providing a fix. * Fixes for UIOP:WITH-TEMPORARY-FILE -* Miscellaneous bug fixes from LuÃs Oliveira. +* Miscellaneous bug fixes from LuÃs Oliveira, Gary Palter, François-René + Rideau, and Eric Schulte. * Fix for argument handling in LAUNCH-PROGRAM. +* Fixes for feature handling from Eric Timmons. cl-asdf (2:3.3.4-1) unstable; urgency=low Bug fix release: diff --git a/doc/asdf.texinfo b/doc/asdf.texinfo index 898659fee..ef3585ae4 100644 --- a/doc/asdf.texinfo +++ b/doc/asdf.texinfo @@ -65,7 +65,7 @@ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. @titlepage @title ASDF: Another System Definition Facility -@subtitle Manual for Version 3.3.4.11 +@subtitle Manual for Version 3.3.4.12 @c The following two commands start the copyright page. @page @vskip 0pt plus 1filll @@ -82,7 +82,7 @@ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. @node Top, Introduction, (dir), (dir) @top ASDF: Another System Definition Facility @ifnottex -Manual for Version 3.3.4.11 +Manual for Version 3.3.4.12 @end ifnottex diff --git a/header.lisp b/header.lisp index b76559454..cd87b0103 100644 --- a/header.lisp +++ b/header.lisp @@ -1,5 +1,5 @@ ;;; -*- mode: Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; buffer-read-only: t; -*- -;;; This is ASDF 3.3.4.11: Another System Definition Facility. +;;; This is ASDF 3.3.4.12: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to <asdf-devel@common-lisp.net>. diff --git a/test/test-package-local-nicknames.script b/test/test-package-local-nicknames.script index 668bbc1f2..06700b87a 100644 --- a/test/test-package-local-nicknames.script +++ b/test/test-package-local-nicknames.script @@ -123,3 +123,19 @@ (sb (find-package +nn-name+))) (assert (eq cl (find-package :package-local-nicknames-test-2))) (assert (eq sb (find-package +pkg-name+)))))) + + +(define-test test-package-local-nicknames-nickname-removal-by-define-package + (reset-test-packages) + (uiop:define-package #:foo + (:local-nicknames (#:u #:uiop))) + (assert + (eq (find-package :uiop) + (let ((*package* (find-package '#:foo))) + (find-package '#:u)))) + (uiop:define-package #:foo + (:local-nicknames (#:u #:asdf))) + (assert + (eq (find-package :asdf) + (let ((*package* (find-package '#:foo))) + (find-package '#:u))))) diff --git a/uiop/package.lisp b/uiop/package.lisp index 3c74c5ff5..285539d97 100644 --- a/uiop/package.lisp +++ b/uiop/package.lisp @@ -602,6 +602,17 @@ or when loading the package is optional." (unless (eq status :external) (ensure-exported name symbol from-package recycle)))) + #+package-local-nicknames + (defun install-package-local-nicknames (destination-package new-nicknames) + ;; First, remove all package-local nicknames. (We'll reinstall any desired ones later.) + (dolist (pair-to-remove (package-local-nicknames destination-package)) + (remove-package-local-nickname (string (car pair-to-remove)) destination-package)) + ;; Then, install all desired nicknames. + (loop :for (nickname package) :in new-nicknames + :do (add-package-local-nickname (string nickname) + (find-package package) + destination-package))) + (defun ensure-package (name &key nicknames documentation use shadow shadowing-import-from @@ -630,13 +641,17 @@ 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))) - (declare (ignorable local-nicknames)) ; if not supported + #-package-local-nicknames + (declare (ignore local-nicknames)) ; if not supported (when-package-fishiness (record-fishy package-name)) + ;; if supported, put package documentation #-genera (when documentation (setf (documentation package t) documentation)) + ;; remove unwanted packages from use list (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)) + ;; mark unwanted packages for deletion (loop :for p :in discarded :for n = (remove-if #'(lambda (x) (member x names :test 'equal)) (package-names p)) @@ -644,16 +659,12 @@ 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)))) + ;; give package its desired name (rename-package package package-name nicknames) ;; Handle local nicknames #+package-local-nicknames - (let* ((existing-nicknames (mapcar #'(lambda (x) (string (car x))) (package-local-nicknames package))) - (new-nicknames (mapcar #'(lambda (x) (string (first x))) local-nicknames)) - (to-remove (set-difference existing-nicknames new-nicknames :test 'equal))) - (mapc #'(lambda (x) (remove-package-local-nickname x package)) to-remove)) - #+package-local-nicknames - (loop :for (nick-str package-str) :in local-nicknames - :do (add-package-local-nickname nick-str package-str package)) + (install-package-local-nicknames package local-nicknames) + ;; handle uninterning unwanted symbols (dolist (name unintern) (multiple-value-bind (existing status) (find-symbol name package) (when status @@ -661,11 +672,14 @@ or when loading the package is optional." (note-package-fishiness :unintern (package-name package) name (symbol-package-name existing) status) (unintern* name package nil))))) + ;; handle exports (dolist (name export) (setf (gethash name exported) t)) + ;; handle reexportss (dolist (p reexport) (do-external-symbols (sym p) (setf (gethash (string sym) exported) t))) + ;; unexport symbols not listed in (re)export (do-external-symbols (sym package) (let ((name (symbol-name sym))) (unless (gethash name exported) @@ -673,6 +687,7 @@ or when loading the package is optional." :over-export (package-name package) name (or (home-package-p sym package) (symbol-package-name sym))) (unexport sym package)))) + ;; handle explicitly listed shadowed ssymbols (dolist (name shadow) (setf (gethash name shadowed) t) (multiple-value-bind (existing status) (find-symbol name package) @@ -692,25 +707,31 @@ or when loading the package is optional." (shadowing-import* dummy package) (import* dummy package))))))) (shadow* name package)) + ;; handle shadowing imports (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))) + ;; handle mixed packages (loop :for p :in mix :for pp = (find-package* p) :do (do-external-symbols (sym pp) (ensure-mix (symbol-name sym) sym package pp shadowed imported inherited))) + ;; handle import-from packages (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))) + ;; handle use-list and mix (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)) + ;; intern dessired symbols (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)) + ;; delete now-deceased packages (map () 'delete-package* to-delete) package))) diff --git a/uiop/version.lisp b/uiop/version.lisp index cb56daa69..a9657284d 100644 --- a/uiop/version.lisp +++ b/uiop/version.lisp @@ -12,7 +12,7 @@ (in-package :uiop/version) (with-upgradability () - (defparameter *uiop-version* "3.3.4.11") + (defparameter *uiop-version* "3.3.4.12") (defun unparse-version (version-list) "From a parsed version (a list of natural numbers), compute the version string" diff --git a/upgrade.lisp b/upgrade.lisp index de0a52504..50e2e20dc 100644 --- a/upgrade.lisp +++ b/upgrade.lisp @@ -94,7 +94,7 @@ previously-loaded version of ASDF." ;; "3.4.5.67" would be a development version in the official branch, on top 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 "3.3.4.11") + (asdf-version "3.3.4.12") (existing-version (asdf-version))) (setf *asdf-version* asdf-version) (when (and existing-version (not (equal asdf-version existing-version))) diff --git a/version.lisp-expr b/version.lisp-expr index b5e50b8fa..84a561bb9 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -1,2 +1,2 @@ -"3.3.4.11" +"3.3.4.12" -- GitLab