Commit caf89a8a authored by Robert Goldman's avatar Robert Goldman
Browse files

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.
parent 6b0311e1
...@@ -93,7 +93,7 @@ ...@@ -93,7 +93,7 @@
:licence "MIT" :licence "MIT"
:description "Another System Definition Facility" :description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems." :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 () :depends-on ()
:components ((:module "build" :components ((:file "asdf")))) :components ((:module "build" :components ((:file "asdf"))))
. #-asdf3 () #+asdf3 . #-asdf3 () #+asdf3
......
...@@ -3,16 +3,20 @@ cl-asdf (2:3.3.5-1) unstable; urgency=low IN PROGRESS ...@@ -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. * Fix bug in handling combination of :serial and :if-feature dependencies.
* Add support for package local nicknames to UIOP:DEFINE-PACKAGE and * Add support for package local nicknames to UIOP:DEFINE-PACKAGE and
ASDF's package-inferred systems. Extend support for package local 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 * A number of fixes for Lispworks compatibility (thanks to Martin
Simmons). 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 * Add support for source files with different file extensions to
package-inferred-systems. Thanks to Jingtao Xu for identifying package-inferred-systems. Thanks to Jingtao Xu for identifying
the bug and providing a fix. the bug and providing a fix.
* Fixes for UIOP:WITH-TEMPORARY-FILE * 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. * Fix for argument handling in LAUNCH-PROGRAM.
* Fixes for feature handling from Eric Timmons.
cl-asdf (2:3.3.4-1) unstable; urgency=low cl-asdf (2:3.3.4-1) unstable; urgency=low
Bug fix release: Bug fix release:
......
...@@ -65,7 +65,7 @@ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ...@@ -65,7 +65,7 @@ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
@titlepage @titlepage
@title ASDF: Another System Definition Facility @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. @c The following two commands start the copyright page.
@page @page
@vskip 0pt plus 1filll @vskip 0pt plus 1filll
...@@ -82,7 +82,7 @@ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ...@@ -82,7 +82,7 @@ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
@node Top, Introduction, (dir), (dir) @node Top, Introduction, (dir), (dir)
@top ASDF: Another System Definition Facility @top ASDF: Another System Definition Facility
@ifnottex @ifnottex
Manual for Version 3.3.4.11 Manual for Version 3.3.4.12
@end ifnottex @end ifnottex
......
;;; -*- mode: Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; buffer-read-only: t; -*- ;;; -*- 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: ;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>. ;;; please mail to <asdf-devel@common-lisp.net>.
......
...@@ -123,3 +123,19 @@ ...@@ -123,3 +123,19 @@
(sb (find-package +nn-name+))) (sb (find-package +nn-name+)))
(assert (eq cl (find-package :package-local-nicknames-test-2))) (assert (eq cl (find-package :package-local-nicknames-test-2)))
(assert (eq sb (find-package +pkg-name+)))))) (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)))))
...@@ -602,6 +602,17 @@ or when loading the package is optional." ...@@ -602,6 +602,17 @@ or when loading the package is optional."
(unless (eq status :external) (unless (eq status :external)
(ensure-exported name symbol from-package recycle)))) (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 (defun ensure-package (name &key
nicknames documentation use nicknames documentation use
shadow shadowing-import-from shadow shadowing-import-from
...@@ -630,13 +641,17 @@ or when loading the package is optional." ...@@ -630,13 +641,17 @@ or when loading the package is optional."
(exported (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: ;; string to list home package and use package:
(inherited (make-hash-table :test 'equal))) (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)) (when-package-fishiness (record-fishy package-name))
;; if supported, put package documentation
#-genera #-genera
(when documentation (setf (documentation package t) documentation)) (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)) (loop :for p :in (set-difference (package-use-list package) (append mix use))
:do (note-package-fishiness :over-use name (package-names p)) :do (note-package-fishiness :over-use name (package-names p))
(unuse-package p package)) (unuse-package p package))
;; mark unwanted packages for deletion
(loop :for p :in discarded (loop :for p :in discarded
:for n = (remove-if #'(lambda (x) (member x names :test 'equal)) :for n = (remove-if #'(lambda (x) (member x names :test 'equal))
(package-names p)) (package-names p))
...@@ -644,16 +659,12 @@ or when loading the package is optional." ...@@ -644,16 +659,12 @@ or when loading the package is optional."
(cond (n (rename-package p (first n) (rest n))) (cond (n (rename-package p (first n) (rest n)))
(t (rename-package-away p) (t (rename-package-away p)
(push p to-delete)))) (push p to-delete))))
;; give package its desired name
(rename-package package package-name nicknames) (rename-package package package-name nicknames)
;; Handle local nicknames ;; Handle local nicknames
#+package-local-nicknames #+package-local-nicknames
(let* ((existing-nicknames (mapcar #'(lambda (x) (string (car x))) (package-local-nicknames package))) (install-package-local-nicknames package local-nicknames)
(new-nicknames (mapcar #'(lambda (x) (string (first x))) local-nicknames)) ;; handle uninterning unwanted symbols
(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))
(dolist (name unintern) (dolist (name unintern)
(multiple-value-bind (existing status) (find-symbol name package) (multiple-value-bind (existing status) (find-symbol name package)
(when status (when status
...@@ -661,11 +672,14 @@ or when loading the package is optional." ...@@ -661,11 +672,14 @@ or when loading the package is optional."
(note-package-fishiness (note-package-fishiness
:unintern (package-name package) name (symbol-package-name existing) status) :unintern (package-name package) name (symbol-package-name existing) status)
(unintern* name package nil))))) (unintern* name package nil)))))
;; handle exports
(dolist (name export) (dolist (name export)
(setf (gethash name exported) t)) (setf (gethash name exported) t))
;; handle reexportss
(dolist (p reexport) (dolist (p reexport)
(do-external-symbols (sym p) (do-external-symbols (sym p)
(setf (gethash (string sym) exported) t))) (setf (gethash (string sym) exported) t)))
;; unexport symbols not listed in (re)export
(do-external-symbols (sym package) (do-external-symbols (sym package)
(let ((name (symbol-name sym))) (let ((name (symbol-name sym)))
(unless (gethash name exported) (unless (gethash name exported)
...@@ -673,6 +687,7 @@ or when loading the package is optional." ...@@ -673,6 +687,7 @@ or when loading the package is optional."
:over-export (package-name package) name :over-export (package-name package) name
(or (home-package-p sym package) (symbol-package-name sym))) (or (home-package-p sym package) (symbol-package-name sym)))
(unexport sym package)))) (unexport sym package))))
;; handle explicitly listed shadowed ssymbols
(dolist (name shadow) (dolist (name shadow)
(setf (gethash name shadowed) t) (setf (gethash name shadowed) t)
(multiple-value-bind (existing status) (find-symbol name package) (multiple-value-bind (existing status) (find-symbol name package)
...@@ -692,25 +707,31 @@ or when loading the package is optional." ...@@ -692,25 +707,31 @@ or when loading the package is optional."
(shadowing-import* dummy package) (shadowing-import* dummy package)
(import* dummy package))))))) (import* dummy package)))))))
(shadow* name package)) (shadow* name package))
;; handle shadowing imports
(loop :for (p . syms) :in shadowing-import-from (loop :for (p . syms) :in shadowing-import-from
:for pp = (find-package* p) :do :for pp = (find-package* p) :do
(dolist (sym syms) (ensure-shadowing-import (string sym) package pp shadowed imported))) (dolist (sym syms) (ensure-shadowing-import (string sym) package pp shadowed imported)))
;; handle mixed packages
(loop :for p :in mix (loop :for p :in mix
:for pp = (find-package* p) :do :for pp = (find-package* p) :do
(do-external-symbols (sym pp) (ensure-mix (symbol-name sym) sym package pp shadowed imported inherited))) (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 (loop :for (p . syms) :in import-from
:for pp = (find-package p) :do :for pp = (find-package p) :do
(dolist (sym syms) (ensure-import (symbol-name sym) package pp shadowed imported))) (dolist (sym syms) (ensure-import (symbol-name sym) package pp shadowed imported)))
;; handle use-list and mix
(dolist (p (append use mix)) (dolist (p (append use mix))
(do-external-symbols (sym p) (ensure-inherited (string sym) sym package p nil shadowed imported inherited)) (do-external-symbols (sym p) (ensure-inherited (string sym) sym package p nil shadowed imported inherited))
(use-package p package)) (use-package p package))
(loop :for name :being :the :hash-keys :of exported :do (loop :for name :being :the :hash-keys :of exported :do
(ensure-symbol name package t recycle shadowed imported inherited exported) (ensure-symbol name package t recycle shadowed imported inherited exported)
(ensure-export name package recycle)) (ensure-export name package recycle))
;; intern dessired symbols
(dolist (name intern) (dolist (name intern)
(ensure-symbol name package t recycle shadowed imported inherited exported)) (ensure-symbol name package t recycle shadowed imported inherited exported))
(do-symbols (sym package) (do-symbols (sym package)
(ensure-symbol (symbol-name sym) package nil recycle shadowed imported inherited exported)) (ensure-symbol (symbol-name sym) package nil recycle shadowed imported inherited exported))
;; delete now-deceased packages
(map () 'delete-package* to-delete) (map () 'delete-package* to-delete)
package))) package)))
......
...@@ -12,7 +12,7 @@ ...@@ -12,7 +12,7 @@
(in-package :uiop/version) (in-package :uiop/version)
(with-upgradability () (with-upgradability ()
(defparameter *uiop-version* "3.3.4.11") (defparameter *uiop-version* "3.3.4.12")
(defun unparse-version (version-list) (defun unparse-version (version-list)
"From a parsed version (a list of natural numbers), compute the version string" "From a parsed version (a list of natural numbers), compute the version string"
......
...@@ -94,7 +94,7 @@ previously-loaded version of ASDF." ...@@ -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.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.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 ;; "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))) (existing-version (asdf-version)))
(setf *asdf-version* asdf-version) (setf *asdf-version* asdf-version)
(when (and existing-version (not (equal asdf-version existing-version))) (when (and existing-version (not (equal asdf-version existing-version)))
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment