From c295f6b12fc72fa97cf012612830b42084416053 Mon Sep 17 00:00:00 2001 From: Eric Timmons Date: Fri, 14 May 2021 16:16:46 -0400 Subject: [PATCH] Rework package-local-nicknames so that uiop/package package is not modified uiop/package now defines functions in its own package corresponding to the PLN API (that simply call the implementation's native functions). Then, once UIOP:DEFINE-PACKAGE is established, a new package is defined that simply reexports the implementation's native PLN API. --- Makefile | 2 +- make-asdf.bat | 2 +- make-asdf.sh | 2 +- test/test-package-local-nicknames.script | 28 ++++++------- uiop/driver.lisp | 3 +- uiop/package-local-nicknames.lisp | 22 ++++++++++ uiop/package.lisp | 52 +++++++++++++++++------- uiop/uiop.asd | 3 +- 8 files changed, 81 insertions(+), 33 deletions(-) create mode 100644 uiop/package-local-nicknames.lisp diff --git a/Makefile b/Makefile index 6a81b0bc..8a4c5a42 100644 --- a/Makefile +++ b/Makefile @@ -79,7 +79,7 @@ SCL ?= scl XCL ?= xcl header_lisp := header.lisp -driver_lisp := uiop/package.lisp uiop/common-lisp.lisp uiop/utility.lisp uiop/version.lisp uiop/os.lisp uiop/pathname.lisp uiop/filesystem.lisp uiop/stream.lisp uiop/image.lisp uiop/lisp-build.lisp uiop/launch-program.lisp uiop/run-program.lisp uiop/configuration.lisp uiop/backward-driver.lisp uiop/driver.lisp +driver_lisp := uiop/package.lisp uiop/package-local-nicknames.lisp uiop/common-lisp.lisp uiop/utility.lisp uiop/version.lisp uiop/os.lisp uiop/pathname.lisp uiop/filesystem.lisp uiop/stream.lisp uiop/image.lisp uiop/lisp-build.lisp uiop/launch-program.lisp uiop/run-program.lisp uiop/configuration.lisp uiop/backward-driver.lisp uiop/driver.lisp defsystem_lisp := upgrade.lisp session.lisp component.lisp operation.lisp system.lisp system-registry.lisp action.lisp lisp-action.lisp find-component.lisp forcing.lisp plan.lisp operate.lisp find-system.lisp parse-defsystem.lisp bundle.lisp concatenate-source.lisp package-inferred-system.lisp output-translations.lisp source-registry.lisp backward-internals.lisp backward-interface.lisp interface.lisp user.lisp footer.lisp all_lisp := $(header_lisp) $(driver_lisp) $(defsystem_lisp) diff --git a/make-asdf.bat b/make-asdf.bat index 523fbe71..9c4deab0 100644 --- a/make-asdf.bat +++ b/make-asdf.bat @@ -4,7 +4,7 @@ set here=%~dp0 set header_lisp=header.lisp -set driver_lisp=uiop\package.lisp + uiop\common-lisp.lisp + uiop\utility.lisp + uiop\version.lisp + uiop\os.lisp + uiop\pathname.lisp + uiop\filesystem.lisp + uiop\stream.lisp + uiop\image.lisp + uiop\lisp-build.lisp + uiop\launch-program.lisp + uiop\run-program.lisp + uiop\configuration.lisp + uiop\backward-driver.lisp + uiop\driver.lisp +set driver_lisp=uiop\package.lisp + uiop\package-local-nicknames.lisp + uiop\common-lisp.lisp + uiop\utility.lisp + uiop\version.lisp + uiop\os.lisp + uiop\pathname.lisp + uiop\filesystem.lisp + uiop\stream.lisp + uiop\image.lisp + uiop\lisp-build.lisp + uiop\launch-program.lisp + uiop\run-program.lisp + uiop\configuration.lisp + uiop\backward-driver.lisp + uiop\driver.lisp set defsystem_lisp=upgrade.lisp + session.lisp + component.lisp + operation.lisp + system.lisp + system-registry.lisp + action.lisp + lisp-action.lisp + find-component.lisp + forcing.lisp + plan.lisp + operate.lisp + find-system.lisp + parse-defsystem.lisp + bundle.lisp + concatenate-source.lisp + package-inferred-system.lisp + output-translations.lisp + source-registry.lisp + backward-internals.lisp + backward-interface.lisp + interface.lisp + user.lisp + footer.lisp %~d0 diff --git a/make-asdf.sh b/make-asdf.sh index ec429fd2..7c14f2b5 100755 --- a/make-asdf.sh +++ b/make-asdf.sh @@ -5,7 +5,7 @@ here="$(dirname $0)" header_lisp="header.lisp" -driver_lisp="uiop/package.lisp uiop/common-lisp.lisp uiop/utility.lisp uiop/version.lisp uiop/os.lisp uiop/pathname.lisp uiop/filesystem.lisp uiop/stream.lisp uiop/image.lisp uiop/lisp-build.lisp uiop/launch-program.lisp uiop/run-program.lisp uiop/configuration.lisp uiop/backward-driver.lisp uiop/driver.lisp" +driver_lisp="uiop/package.lisp uiop/package-local-nicknames.lisp uiop/common-lisp.lisp uiop/utility.lisp uiop/version.lisp uiop/os.lisp uiop/pathname.lisp uiop/filesystem.lisp uiop/stream.lisp uiop/image.lisp uiop/lisp-build.lisp uiop/launch-program.lisp uiop/run-program.lisp uiop/configuration.lisp uiop/backward-driver.lisp uiop/driver.lisp" defsystem_lisp="upgrade.lisp session.lisp component.lisp operation.lisp system.lisp system-registry.lisp action.lisp lisp-action.lisp find-component.lisp forcing.lisp plan.lisp operate.lisp find-system.lisp parse-defsystem.lisp bundle.lisp concatenate-source.lisp package-inferred-system.lisp output-translations.lisp source-registry.lisp backward-internals.lisp backward-interface.lisp interface.lisp user.lisp footer.lisp" all () { diff --git a/test/test-package-local-nicknames.script b/test/test-package-local-nicknames.script index 06700b87..8b2d7897 100644 --- a/test/test-package-local-nicknames.script +++ b/test/test-package-local-nicknames.script @@ -38,11 +38,11 @@ (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) + (let ((form1 `(uiop: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")))) + (let ((form2 `(uiop:define-package :package-local-nicknames-test-2 (:use) + (:export "CONS")))) (eval form2))) (defmacro define-test (name &rest body) @@ -62,7 +62,7 @@ :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))) + (let ((alist (uiop:package-local-nicknames :package-local-nicknames-test-1))) (assert (equal (cons (case-lisp-string "L") (find-package :cl)) (assoc (case-lisp-string "L") alist :test 'string=))) (assert (equal (cons +nn-sname+ (find-package +pkg-sname+)) @@ -95,29 +95,29 @@ (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)))) + (assert (= 2 (length (uiop:package-local-nicknames :package-local-nicknames-test-1)))) + (assert (uiop:remove-package-local-nickname :l :package-local-nicknames-test-1)) + (assert (= 1 (length (uiop: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 (if (eq (readtable-case *readtable*) :preserve) #\l #\L) - :package-local-nicknames-test-1)) - (assert (= 1 (length (uiop/package:package-local-nicknames :package-local-nicknames-test-1)))) + (assert (= 2 (length (uiop:package-local-nicknames :package-local-nicknames-test-1)))) + (assert (uiop:remove-package-local-nickname (if (eq (readtable-case *readtable*) :preserve) #\l #\L) + :package-local-nicknames-test-1)) + (assert (= 1 (length (uiop: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 (uiop: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))) + (uiop: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+))) diff --git a/uiop/driver.lisp b/uiop/driver.lisp index 9b7807d7..b5033588 100644 --- a/uiop/driver.lisp +++ b/uiop/driver.lisp @@ -13,7 +13,8 @@ :uiop/package :uiop/utility :uiop/version :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image :uiop/launch-program :uiop/run-program - :uiop/lisp-build :uiop/configuration :uiop/backward-driver)) + :uiop/lisp-build :uiop/configuration :uiop/backward-driver + :uiop/package-local-nicknames)) ;; Provide both lowercase and uppercase, to satisfy more people. (provide "uiop") (provide "UIOP") diff --git a/uiop/package-local-nicknames.lisp b/uiop/package-local-nicknames.lisp new file mode 100644 index 00000000..95a12124 --- /dev/null +++ b/uiop/package-local-nicknames.lisp @@ -0,0 +1,22 @@ +;;; ------------------------------------------------------------------------- +;;; Export the package-local-nicknames API. This cannot be done from +;;; uiop/package due to different ways implementations handle package variance. + +(uiop/package:define-package :uiop/package-local-nicknames + (:use :common-lisp) + ;; Hack to make sure uiop/package is loaded first (to portably get + ;; :PACKAGE-LOCAL-NICKNAMES onto *FEATURES*) + (:import-from :uiop/package) + #+package-local-nicknames + (:import-from #+allegro #:excl + #+sbcl #:sb-ext + #+(or clasp abcl ecl) #:ext + #+ccl #:ccl + #+lispworks #:hcl + #-(or allegro sbcl clasp abcl ccl lispworks ecl) + (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) + #+package-local-nicknames + (:export #:add-package-local-nickname #:remove-package-local-nickname #:package-local-nicknames)) + +(in-package :uiop/package-local-nicknames) diff --git a/uiop/package.lisp b/uiop/package.lisp index 61a48a01..2212f8cb 100644 --- a/uiop/package.lisp +++ b/uiop/package.lisp @@ -28,15 +28,6 @@ ;; 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 ecl) #:ext - #+ccl #:ccl - #+lispworks #:hcl - #-(or allegro sbcl clasp abcl ccl lispworks ecl) - (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* @@ -47,11 +38,7 @@ #: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 - #+package-local-nicknames #:add-package-local-nickname - #+package-local-nicknames #:remove-package-local-nickname - #+package-local-nicknames #:package-local-nicknames - )) + #:ensure-package #:define-package)) (in-package :uiop/package) @@ -364,6 +351,43 @@ or when loading the package is optional." ,@(when-relevant :intern (and internp (sort-names intern))))))))) +;;; package-local-nicknames +;;; +;;; These symbols cannot be imported to (or exported from) the uiop/package +;;; package, as its definition is frozen forever. So we create our own +;;; functions mirroring the p-l-n API here that just dispatch to the +;;; implementation's own functions. We then create another package (once +;;; UIOP:DEFINE-PACKAGE is in place) that is used to export the API from the +;;; UIOP package. +#+package-local-nicknames +(eval-when (:load-toplevel :compile-toplevel :execute) + #-(or allegro sbcl clasp abcl ecl ccl lispworks) + (error "Don't know from which package this lisp supplies the local-package-nicknames API.") + + (defun add-package-local-nickname (local-nickname actual-package &optional (package-designator *package*)) + (#+allegro excl:add-package-local-nickname + #+sbcl sb-ext:add-package-local-nickname + #+(or clasp abcl ecl) ext:add-package-local-nickname + #+ccl ccl:add-package-local-nickname + #+lispworks hcl:add-package-local-nickname + local-nickname actual-package package-designator)) + + (defun remove-package-local-nickname (old-nickname &optional (package-designator *package*)) + (#+allegro excl:remove-package-local-nickname + #+sbcl sb-ext:remove-package-local-nickname + #+(or clasp abcl ecl) ext:remove-package-local-nickname + #+ccl ccl:remove-package-local-nickname + #+lispworks hcl:remove-package-local-nickname + old-nickname package-designator)) + + (defun package-local-nicknames (package-designator) + (#+allegro excl:package-local-nicknames + #+sbcl sb-ext:package-local-nicknames + #+(or clasp abcl ecl) ext:package-local-nicknames + #+ccl ccl:package-local-nicknames + #+lispworks hcl:package-local-nicknames + package-designator))) + ;;; ensure-package, define-package (eval-when (:load-toplevel :compile-toplevel :execute) (defun ensure-shadowing-import (name to-package from-package shadowed imported) diff --git a/uiop/uiop.asd b/uiop/uiop.asd index 72fffb0d..962f40e0 100644 --- a/uiop/uiop.asd +++ b/uiop/uiop.asd @@ -30,6 +30,7 @@ you already have a matching UIOP loaded." :components ((:static-file "contrib/debug.lisp") (:file "package") + (:file "package-local-nicknames" :depends-on ("package")) (:file "common-lisp" :depends-on ("package")) (:file "utility" :depends-on ("common-lisp")) (:file "version" :depends-on ("utility")) @@ -43,7 +44,7 @@ you already have a matching UIOP loaded." (:file "run-program" :depends-on ("launch-program" "version")) (:file "configuration" :depends-on ("image")) (:file "backward-driver" :depends-on ("lisp-build" "run-program" "configuration" "version")) - (:file "driver" :depends-on ("backward-driver"))) + (:file "driver" :depends-on ("backward-driver" "package-local-nicknames"))) . #-asdf3 () #+asdf3 (:encoding :utf-8 :around-compile call-without-redefinition-warnings -- GitLab