diff --git a/package-inferred-system.lisp b/package-inferred-system.lisp index fe62af8831d26cb9175f40d81f4e6e064dd431cd..a15454509cc4d633db140fee3a96cd3cedf4001c 100644 --- a/package-inferred-system.lisp +++ b/package-inferred-system.lisp @@ -75,9 +75,9 @@ the DEFPACKAGE-FORM uses it or imports a symbol from it." (dolist (p arguments) (dep (string p)))) ((:import-from :shadowing-import-from) (dep (string (first arguments)))) - #+sbcl + #+package-local-nicknames ((:local-nicknames) - (loop* :for (local-nickname actual-package-name) :in arguments :do + (loop* :for (nil actual-package-name) :in arguments :do (dep (string actual-package-name)))) ((:nicknames :documentation :shadow :export :intern :unintern :recycle))))) :from-end t :test 'equal)) diff --git a/test/package-inferred-system-test.script b/test/package-inferred-system-test.script index b2eb4195b9c032eea4f6337d61697044d4c90d3f..335aa00d2f764a198f6e295e6b3df3a735bd31c6 100644 --- a/test/package-inferred-system-test.script +++ b/test/package-inferred-system-test.script @@ -17,8 +17,11 @@ ;; package-inferred-system object. (assert-equal "package-inferred-system-test" (primary-system-name (find-system :package-inferred-system-test/a/x))) -;; Test that SBCL's :local-nicknames are recognized -#+sbcl +;; Test that :local-nicknames are recognized on relevant implementations +;; NB: requires ABCL >= ? (old 1.5.0 works), CCL >= 1.12 (unreleased as of Dec 2019), +;; CLASP >= ??? (no less released than anything else?), ECL >= 1.6.4 (unreleased as of Dec 2019), +;; SBCL >= ? (old 1.5.0 works) +#+package-local-nicknames (progn (load-system :package-inferred-system-test/local-nicknames-1) (assert-equal "g" (symbol-call :package-inferred-system-test/local-nicknames-1 :f))) diff --git a/test/test-package-local-nicknames.script b/test/test-package-local-nicknames.script new file mode 100644 index 0000000000000000000000000000000000000000..a092fc57186b1e89a507e82b0ce3e992f8aed55d --- /dev/null +++ b/test/test-package-local-nicknames.script @@ -0,0 +1,114 @@ +;;; -*- mode:common-lisp; -*- + +(in-package :asdf-test) + +;;; these tests for DEFINE-PACKAGE support of package-local-nicknames were adapted from +;;; the trivial-package-local-nicknames system, to test UIOP's support for package local +;;; nicknames + +(progn + (defparameter +test-data+ + #+sbcl '(:sb-ext :sb :exit) + #+ccl '(:ccl :cc :quit) + #+ecl '(:ext :ex :exit) + #+abcl '(:ext :ex :quit) + #+clasp '(:core :ex :quit) + #+lispworks '(:lispworks :ex :quit) + #+allegro '(:excl :ex :exit)) + + (defparameter +pkg-name+ (first +test-data+)) + (defparameter +nn-name+ (second +test-data+)) + (defparameter +sym-name+ (third +test-data+)) + + (defparameter +pkg-sname+ (string +pkg-name+)) + (defparameter +nn-sname+ (string +nn-name+)) + (defparameter +sym-sname+ (string +sym-name+)) + (defparameter +sym-fullname+ (concatenate 'string +pkg-sname+ ":" +sym-sname+)) + (defparameter +sym-fullnickname+ (concatenate 'string +nn-sname+ ":" +sym-sname+)) + (defparameter +sym+ (or (find-symbol +sym-sname+ +pkg-name+) + (error "Symbol not found while loading tests: check +SYM+ binding.")))) + +(defun reset-test-packages () + (#+sbcl sb-ext:without-package-locks + #-sbcl progn + (when (find-package :package-local-nicknames-test-1) + (delete-package :package-local-nicknames-test-1)) + (when (find-package :package-local-nicknames-test-2) + (delete-package :package-local-nicknames-test-2))) + (let ((form1 `(uiop/package:define-package :package-local-nicknames-test-1 (:use) + (:local-nicknames (:l :cl) (,+nn-name+ ,+pkg-name+))))) + (eval form1)) + (let ((form2 `(uiop/package:define-package :package-local-nicknames-test-2 (:use) + (:export "CONS")))) + (eval form2))) + +(defmacro define-test (name &rest body) + `(progn + (DBG ,(symbol-name name)) + ,@body)) + +(define-test test-package-local-nicknames-introspection + (reset-test-packages) + (dolist (p '("KEYWORD" "COMMON-LISP" "COMMON-LISP-USER" + :package-local-nicknames-test-1 + :package-local-nicknames-test-2)) + (let ((*package* (find-package p))) + (let ((alist (uiop/package:package-local-nicknames :package-local-nicknames-test-1))) + (assert (equal (cons "L" (find-package "CL")) (assoc "L" alist :test 'string=))) + (assert (equal (cons +nn-sname+ (find-package +pkg-sname+)) + (assoc +nn-sname+ alist :test 'string=))) + (assert (eql 2 (length alist))))))) + +(define-test test-package-local-nicknames-symbol-equality + (reset-test-packages) + (let ((*package* (find-package :package-local-nicknames-test-1))) + (let ((cons0 (read-from-string "L:CONS")) + (cons1 (find-symbol "CONS" :l)) + (cons1s (find-symbol "CONS" #\L)) + (exit0 (read-from-string +sym-fullname+)) + (exit1 (find-symbol +sym-sname+ +nn-name+))) + (assert (eq 'cons cons0)) + (assert (eq 'cons cons1)) + (assert (eq 'cons cons1s)) + (assert (eq +sym+ exit0)) + (assert (eq +sym+ exit1))))) + +(define-test test-package-local-nicknames-package-equality + (reset-test-packages) + (let ((*package* (find-package :package-local-nicknames-test-1))) + (let ((cl (find-package :l)) + (cls (find-package #\L)) + (sb (find-package +nn-name+))) + (assert (eq cl (find-package :common-lisp))) + (assert (eq cls (find-package :common-lisp))) + (assert (eq sb (find-package +pkg-name+)))))) + +(define-test test-package-local-nicknames-nickname-removal + (reset-test-packages) + (assert (= 2 (length (uiop/package:package-local-nicknames :package-local-nicknames-test-1)))) + (assert (uiop/package:remove-package-local-nickname :l :package-local-nicknames-test-1)) + (assert (= 1 (length (uiop/package:package-local-nicknames :package-local-nicknames-test-1)))) + (let ((*package* (find-package :package-local-nicknames-test-1))) + (assert (not (find-package :l))))) + +(define-test test-package-local-nicknames-nickname-removal-char + #+ignore (declare (optimize (debug 3) (speed 0))) + (reset-test-packages) + (assert (= 2 (length (uiop/package:package-local-nicknames :package-local-nicknames-test-1)))) + (assert (uiop/package:remove-package-local-nickname #\L :package-local-nicknames-test-1)) + (assert (= 1 (length (uiop/package:package-local-nicknames :package-local-nicknames-test-1)))) + (let ((*package* (find-package :package-local-nicknames-test-1))) + (assert (not (find-package :l))))) + + +(define-test test-package-local-nicknames-nickname-removal-readd-another-package-equality + (reset-test-packages) + (assert (uiop/package:remove-package-local-nickname :l :package-local-nicknames-test-1)) + (assert (eq (find-package :package-local-nicknames-test-1) + (uiop/package:add-package-local-nickname :l :package-local-nicknames-test-2 + :package-local-nicknames-test-1))) + (let ((*package* (find-package :package-local-nicknames-test-1))) + (let ((cl (find-package :l)) + (sb (find-package +nn-name+))) + (assert (eq cl (find-package :package-local-nicknames-test-2))) + (assert (eq sb (find-package +pkg-name+)))))) diff --git a/uiop/common-lisp.lisp b/uiop/common-lisp.lisp index f16ebe6eebaac3a578593a7d9cd828d06274c13d..e0e2ddcc1cf1bd0f63264fa54036893b7ac1b698 100644 --- a/uiop/common-lisp.lisp +++ b/uiop/common-lisp.lisp @@ -140,6 +140,7 @@ (unless (member :lispworks6 *features*) (pushnew :lispworks7+ *features*))))) + #.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl, so we use this trick (read-from-string "(eval-when (:load-toplevel :compile-toplevel :execute) diff --git a/uiop/package.lisp b/uiop/package.lisp index c2dd14da88c2553d0e64693cd99b6408e0869414..4be9a7f876b2893ff0d834e718ae557e1659f302 100644 --- a/uiop/package.lisp +++ b/uiop/package.lisp @@ -4,6 +4,22 @@ ;; See https://bugs.launchpad.net/asdf/+bug/485687 ;; + +;;; package local nicknames feature. Can't be deferred until common-lisp.lisp, +;;; where most such features are set. +;;; ABCL and CCL already define this feature appropriately. +;;; Seems to be unconditionally present for SBCL, ACL, and clasp +;;; Don't know about ecl, or others + (eval-when (:load-toplevel :compile-toplevel :execute) + ;; abcl pushes :package-local-nicknames without UIOP interfering, + ;; and Lispworks will do so + #+(or sbcl clasp) + (pushnew :package-local-nicknames *features*) + #+allegro + (let ((fname (find-symbol (symbol-name '#:add-package-local-nickname) '#:excl))) + (when (and fname (fboundp fname)) + (pushnew :package-local-nicknames *features*)))) + (defpackage :uiop/package ;; CAUTION: we must handle the first few packages specially for hot-upgrade. ;; This package definition MUST NOT change unless its name too changes; @@ -12,6 +28,15 @@ ;; import and export the same exact symbols as for ASDF 2.27. ;; Any other symbol must be import-from'ed and re-export'ed in a different package. (:use :common-lisp) + #+package-local-nicknames + (:import-from #+allegro #:excl + #+sbcl #:sb-ext + #+(or clasp abcl) #:ext + #+ccl #:ccl + #+lispworks #:hcl + #-(or allegro sbcl clasp abcl ccl lispworks) + (error "Don't know from which package this lisp supplies the local-package-nicknames API.") + #:remove-package-local-nickname #:package-local-nicknames #:add-package-local-nickname) (:export #:find-package* #:find-symbol* #:symbol-call #:intern* #:export* #:import* #:shadowing-import* #:shadow* #:make-symbol* #:unintern* @@ -22,7 +47,11 @@ #:ensure-package-unused #:delete-package* #:package-names #:packages-from-names #:fresh-package-name #:rename-package-away #:package-definition-form #:parse-define-package-form - #:ensure-package #:define-package)) + #:ensure-package #:define-package + #+package-local-nicknames #:add-package-local-nickname + #+package-local-nicknames #:remove-package-local-nickname + #+package-local-nicknames #:package-local-nicknames + )) (in-package :uiop/package) @@ -572,12 +601,13 @@ or when loading the package is optional." (multiple-value-bind (symbol status) (find-symbol* name from-package) (unless (eq status :external) (ensure-exported name symbol from-package recycle)))) + (defun ensure-package (name &key nicknames documentation use shadow shadowing-import-from import-from export intern recycle mix reexport - unintern) + unintern local-nicknames) #+genera (declare (ignore documentation)) (let* ((package-name (string name)) (nicknames (mapcar #'string nicknames)) @@ -594,11 +624,13 @@ or when loading the package is optional." (export (mapcar 'string export)) (intern (mapcar 'string intern)) (unintern (mapcar 'string unintern)) + (local-nicknames (mapcar #'(lambda (pair) (mapcar 'string pair)) local-nicknames)) (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 ;; string to list home package and use package: (inherited (make-hash-table :test 'equal))) + (declare (ignorable local-nicknames)) ; if not supported (when-package-fishiness (record-fishy package-name)) #-genera (when documentation (setf (documentation package t) documentation)) @@ -613,6 +645,15 @@ or when loading the package is optional." (t (rename-package-away p) (push p to-delete)))) (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)) (dolist (name unintern) (multiple-value-bind (existing status) (find-symbol name package) (when status @@ -673,6 +714,7 @@ or when loading the package is optional." (map () 'delete-package* to-delete) package))) + (eval-when (:load-toplevel :compile-toplevel :execute) (defun parse-define-package-form (package clauses) (loop @@ -699,6 +741,13 @@ or when loading the package is optional." :when (eq kw :mix-reexport) :append args :into mix :and :append args :into reexport :and :do (setf use-p t) :else :when (eq kw :unintern) :append args :into unintern :else + :when (eq kw :local-nicknames) + :if (symbol-call '#:uiop '#:featurep :package-local-nicknames) + :append args :into local-nicknames + :else + :do (error ":LOCAL-NICKAMES option is not supported on this lisp implementation.") + :end + :else :do (error "unrecognized define-package keyword ~S" kw) :finally (return `(',package :nicknames ',nicknames :documentation ',documentation @@ -706,7 +755,8 @@ or when loading the package is optional." :shadow ',shadow :shadowing-import-from ',shadowing-import-from :import-from ',import-from :export ',export :intern ',intern :recycle ',(if recycle-p recycle (cons package nicknames)) - :mix ',mix :reexport ',reexport :unintern ',unintern))))) + :mix ',mix :reexport ',reexport :unintern ',unintern + :local-nicknames ',local-nicknames))))) (defmacro define-package (package &rest clauses) "DEFINE-PACKAGE takes a PACKAGE and a number of CLAUSES, of the form @@ -730,7 +780,11 @@ an error if there is a conflict with an explicitly :IMPORT-FROM symbol. REEXPORT -- Takes a list of package designators. For each package, p, in the list, export symbols with the same name as those exported from p. Note that in the case of shadowing, etc. the symbols with the same name may not be the same symbols. -UNINTERN -- Remove symbols here from PACKAGE." +UNINTERN -- Remove symbols here from PACKAGE. +LOCAL-NICKNAMES -- If the host implementation supports package local nicknames +\(check for the :PACKAGE-LOCAL-NICKNAMES feature\), then this should be a list of +nickname and package name pairs. Using this option will cause an error if the +host CL implementation does not support it." (let ((ensure-form `(prog1 (funcall 'ensure-package ,@(parse-define-package-form package clauses))