Raymond Toy pushed to branch master at cmucl / cmucl Commits: aeab122e by Raymond Toy at 2025-06-30T07:18:34-07:00 Fix #415: Add support for package-local-nicknames - - - - - 32b15538 by Raymond Toy at 2025-06-30T07:18:34-07:00 Merge branch 'issue-415-add-package-local-nicknames' into 'master' Fix #415: Add support for package-local-nicknames Closes #415 See merge request cmucl/cmucl!305 - - - - - 7 changed files: - bin/run-unit-tests.sh - src/bootfiles/21e/boot-2024-08.lisp - src/code/exports.lisp - src/code/package.lisp - src/code/print.lisp - src/contrib/asdf/asdf.lisp - src/i18n/locale/cmucl.pot Changes: ===================================== bin/run-unit-tests.sh ===================================== @@ -76,3 +76,24 @@ else $LISP -nositeinit -noinit -load "$TESTDIR"/run-tests.lisp -eval "(progn (cmucl-test-runner:load-test-files) (cmucl-test-runner:run-test $result))" fi +## Now run tests for trivial-package-local-nicknames +REPO=trivial-package-local-nicknames-mirror +BRANCH=cmucl-updates + +set -x +if [ -d ../$REPO ]; then + (cd ../$REPO || exit 1; git stash; git checkout $BRANCH; git pull --rebase) +else + (cd ..; git clone https://gitlab.common-lisp.net/cmucl/trivial-package-local-nicknames-mirror....) +fi + +LISP=$PWD/$LISP +cd ../$REPO || exit 1 +git checkout $BRANCH + +# Run the tests. Exits with a non-zero code if there's a failure. +$LISP -noinit -nositeinit -batch <<'EOF' +(require :asdf) +(push (default-directory) asdf:*central-registry*) +(asdf:test-system :trivial-package-local-nicknames) +EOF ===================================== src/bootfiles/21e/boot-2024-08.lisp ===================================== @@ -8,3 +8,125 @@ (declare (ignore c)) (invoke-restart 'continue)))) (defconstant +ef-max+ 14)) + +;;; Bootstrap for adding %local-nicknames to package structure. +(in-package :lisp) + +(intern "PACKAGE-LOCAL-NICKNAMES" "LISP") +(intern "ADD-PACKAGE-LOCAL-NICKNAME" "LISP") +(intern "REMOVE-PACKAGE-LOCAL-NICKNAME" "LISP") +(intern "PACKAGE-LOCALLY-NICKNAMED-BY-LIST" "LISP") + +;; Make sure we don't accidentally load fasls from somewhere. +(setf (ext:search-list "target:") + '("src/")) + +;; Ensure all packages have been set up, since package definition is broken +;; once this file has been loaded: +(load "target:code/exports-errno" :if-does-not-exist nil) +(load "target:code/exports") + +(setf *enable-package-locked-errors* nil) + +;;; +;;; Like DEFSTRUCT, but silently clobber old definitions. +;;; +(defmacro defstruct! (name &rest stuff) + `(handler-bind ((error (lambda (c) + (declare (ignore c)) + (invoke-restart 'kernel::clobber-it)))) + (defstruct ,name ,@stuff))) + + +(defstruct! (package + (:constructor internal-make-package) + (:predicate packagep) + (:print-function %print-package) + (:make-load-form-fun + (lambda (package) + (values `(package-or-lose ',(package-name package)) + nil)))) + (tables (list nil)) ; A list of all the hashtables for inherited symbols. + (%name nil :type (or simple-string null)) + (%nicknames () :type list) + (%use-list () :type list) + (%used-by-list () :type list) + (internal-symbols (required-argument) :type package-hashtable) + (external-symbols (required-argument) :type package-hashtable) + (%shadowing-symbols () :type list) + (lock nil :type boolean) + (definition-lock nil :type boolean) + (%local-nicknames () :type list) + (doc-string nil :type (or simple-string null))) + +;; Need to define this with the extra arg because compiling pcl uses +;; defpackage and we need this defined. This isn't the actual +;; implementation; we just added the extra arg. +(defun %defpackage (name nicknames size shadows shadowing-imports + use imports interns exports doc-string &optional local-nicknames) + (declare (type simple-base-string name) + (type list nicknames local-nicknames shadows shadowing-imports + imports interns exports) + (type (or list (member :default)) use) + (type (or simple-base-string null) doc-string)) + (let ((package (or (find-package name) + (progn + (when (eq use :default) + (setf use *default-package-use-list*)) + (make-package name + :use nil + :internal-symbols (or size 10) + :external-symbols (length exports)))))) + (unless (string= (the string (package-name package)) name) + (error 'simple-package-error + :package name + :format-control (intl:gettext "~A is a nick-name for the package ~A") + :format-arguments (list name (package-name name)))) + (enter-new-nicknames package nicknames) + ;; Shadows and Shadowing-imports. + (let ((old-shadows (package-%shadowing-symbols package))) + (shadow shadows package) + (dolist (sym-name shadows) + (setf old-shadows (remove (find-symbol sym-name package) old-shadows))) + (dolist (simports-from shadowing-imports) + (let ((other-package (package-or-lose (car simports-from)))) + (dolist (sym-name (cdr simports-from)) + (let ((sym (find-or-make-symbol sym-name other-package))) + (shadowing-import sym package) + (setf old-shadows (remove sym old-shadows)))))) + (when old-shadows + (warn (intl:gettext "~A also shadows the following symbols:~% ~S") + name old-shadows))) + ;; Use + (unless (eq use :default) + (let ((old-use-list (package-use-list package)) + (new-use-list (mapcar #'package-or-lose use))) + (use-package (set-difference new-use-list old-use-list) package) + (let ((laterize (set-difference old-use-list new-use-list))) + (when laterize + (unuse-package laterize package) + (warn (intl:gettext "~A previously used the following packages:~% ~S") + name + laterize))))) + ;; Import and Intern. + (dolist (sym-name interns) + (intern sym-name package)) + (dolist (imports-from imports) + (let ((other-package (package-or-lose (car imports-from)))) + (dolist (sym-name (cdr imports-from)) + (import (list (find-or-make-symbol sym-name other-package)) + package)))) + ;; Exports. + (let ((old-exports nil) + (exports (mapcar #'(lambda (sym-name) (intern sym-name package)) + exports))) + (do-external-symbols (sym package) + (push sym old-exports)) + (export exports package) + (let ((diff (set-difference old-exports exports))) + (when diff + (warn (intl:gettext "~A also exports the following symbols:~% ~S") + name diff)))) + ;; Documentation + (setf (package-doc-string package) doc-string) + package)) ===================================== src/code/exports.lisp ===================================== @@ -1857,6 +1857,11 @@ (:import-from "KERNEL" "*ANSI-DEFSTRUCT-OPTIONS-P*") (:import-from "SYSTEM" "MAKE-INDENTING-STREAM" "INDENTING-STREAM-P" "BINARY-TEXT-STREAM") + (:import-from "LISP" + "PACKAGE-LOCAL-NICKNAMES" + "ADD-PACKAGE-LOCAL-NICKNAME" + "REMOVE-PACKAGE-LOCAL-NICKNAME" + "PACKAGE-LOCALLY-NICKNAMED-BY-LIST") #+double-double (:import-from "KERNEL" "DOUBLE-DOUBLE-FLOAT" "DD-PI") (:export "*AFTER-GC-HOOKS*" "*AFTER-SAVE-INITIALIZATIONS*" @@ -2109,7 +2114,12 @@ "DESCRIBE-EXTERNAL-FORMAT" "LIST-ALL-EXTERNAL-FORMATS" "STRING-ENCODE" "STRING-DECODE" - "SET-SYSTEM-EXTERNAL-FORMAT")) + "SET-SYSTEM-EXTERNAL-FORMAT") + ;; Package-local-nicknames + (:export "PACKAGE-LOCAL-NICKNAMES" + "ADD-PACKAGE-LOCAL-NICKNAME" + "REMOVE-PACKAGE-LOCAL-NICKNAME" + "PACKAGE-LOCALLY-NICKNAMED-BY-LIST")) (defpackage "STREAM" (:import-from "SYSTEM" "LISP-STREAM") ===================================== src/code/package.lisp ===================================== @@ -41,6 +41,8 @@ #+relative-package-names (sys:register-lisp-feature :relative-package-names) +(sys:register-lisp-feature :package-local-nicknames) + (defvar *default-package-use-list* '("COMMON-LISP") "The list of packages to use by default of no :USE argument is supplied to MAKE-PACKAGE or other package creation forms.") @@ -91,6 +93,9 @@ (lock nil :type boolean) (definition-lock nil :type boolean) + ;; Package local nicknames + (%local-nicknames () :type list) + ;; Documentation string for this package (doc-string nil :type (or simple-string null))) @@ -397,6 +402,12 @@ (setq package tmp)) (relative-to package name)))))))) +(defun local-nickname-to-package (name) + ;; Skip all of this if we're doing package-init! + (unless *in-package-init* + (cdr (assoc name (package-%local-nicknames *package*) + :test #'string=)))) + ;;; find-package -- Public ;;; ;;; @@ -405,7 +416,8 @@ (if (packagep name) name (let ((name (package-namify name))) - (or (package-name-to-package name) + (or (local-nickname-to-package name) + (package-name-to-package name) #+relative-package-names (relative-package-name-to-package name))))) @@ -420,7 +432,8 @@ thing) (t (let ((thing (package-namify thing))) - (cond ((package-name-to-package thing)) + (cond ((local-nickname-to-package thing)) + ((package-name-to-package thing)) (t ;; ANSI spec's type-error where this is called. But, ;; but the resulting message is somewhat unclear. @@ -923,8 +936,10 @@ (:EXPORT {symbol-name}*) (:INTERN {symbol-name}*) (:SIZE <integer>) + (:LOCAL-NICKNAMES {({nickname package}*)}) All options except :SIZE and :DOCUMENTATION can be used multiple times." (let ((nicknames nil) + (local-nicknames nil) (size nil) (shadows nil) (shadowing-imports nil) @@ -940,6 +955,11 @@ (case (car option) (:nicknames (setf nicknames (stringify-names (cdr option) "package"))) + (:local-nicknames + (setf local-nicknames + (mapcar #'(lambda (o) + (stringify-names o "package")) + (cdr option)))) (:size (cond (size (simple-program-error (intl:gettext "Can't specify :SIZE twice."))) @@ -994,9 +1014,9 @@ `(:shadowing-import-from ,@(apply #'append (mapcar #'rest shadowing-imports)))) `(eval-when (compile load eval) - (%defpackage ,(stringify-name package "package") ',nicknames ',size - ',shadows ',shadowing-imports ',(if use-p use :default) - ',imports ',interns ',exports ',doc)))) + (%defpackage ,(stringify-name package "package") ',nicknames + ',size ',shadows ',shadowing-imports ',(if use-p use :default) + ',imports ',interns ',exports ',doc ',local-nicknames)))) (defun check-disjoint (&rest args) ;; Check whether all given arguments specify disjoint sets of symbols. @@ -1014,9 +1034,9 @@ key1 key2 common)))) (defun %defpackage (name nicknames size shadows shadowing-imports - use imports interns exports doc-string) + use imports interns exports doc-string &optional local-nicknames) (declare (type simple-base-string name) - (type list nicknames shadows shadowing-imports + (type list nicknames local-nicknames shadows shadowing-imports imports interns exports) (type (or list (member :default)) use) (type (or simple-base-string null) doc-string)) @@ -1034,6 +1054,7 @@ :format-control (intl:gettext "~A is a nick-name for the package ~A") :format-arguments (list name (package-name name)))) (enter-new-nicknames package nicknames) + (enter-new-local-nicknames package local-nicknames) ;; Shadows and Shadowing-imports. (let ((old-shadows (package-%shadowing-symbols package))) (shadow shadows package) @@ -1128,6 +1149,12 @@ (setf (gethash n *package-names*) package) (push n (package-%nicknames package))))))) +(defun enter-new-local-nicknames (package local-nicknames) + (dolist (entry local-nicknames) + (destructuring-bind (nick actual) + entry + (add-package-local-nickname nick actual package)))) + ;;; Make-Package -- Public ;;; @@ -1225,6 +1252,14 @@ (enter-new-nicknames package new-nicknames) package)) +;; Given a package designator, convert it to the corresponding package +;; object. +(declaim (inline designator-package)) +(defun designator-package (designator) + (if (packagep designator) + designator + (package-name-to-package (package-namify designator)))) + ;;; Delete-Package -- Public ;;; (defun delete-package (package-or-name) @@ -1254,6 +1289,13 @@ (mapcar #'package-name use-list)))) (dolist (p use-list) (unuse-package package p)))) + ;; Find all the packages that have a local nickname to this + ;; package and remove the local nickname entry. + (dolist (pkg (package-locally-nicknamed-by-list package)) + (setf (package-%local-nicknames pkg) + (delete package + (package-%local-nicknames pkg) + :key #'cdr))) (dolist (used (package-use-list package)) (unuse-package used package)) (do-symbols (sym package) @@ -1928,7 +1970,128 @@ (result symbol)) string package) (result))) - + +;;;; Support for package local nicknames + +;;; PACKAGE-LOCAL-NICKNAMES -- public. +;;; +(defun package-local-nicknames (package) + "Returns an alist of (local-nickname . actual-package) describing the + nicknames local to Package." + ;; Should we return a new list? + (copy-list (package-%local-nicknames (designator-package package)))) + +;;; ADD-PACKAGE-LOCAL-NICKNAME -- public. +;;; +(defun add-package-local-nickname (local-nickname actual-package &optional (package *package*)) + "For the designated package Package (defaulting to *PACKAGE*), add + Local-Nickname as a package local nickname to the package + Actual-Package. Actual-Package and Package must be an package + designator. Local-Nickname should be a string designator. + + Returns the designated package. + + Signals a continuable error if any of the following are true: + - Local-Nickname is already a local nickname for a different package + - Local-Nickname is one of \"CL\", \"COMMON-LISP\", or \"KEYWORD\" + - Local-Nickname is a global name or nickname for designated package" + + (let* ((pkg (designator-package package)) + (actual-pkg (designator-package actual-package)) + (nicks (package-%local-nicknames pkg)) + (local-nickname (package-namify local-nickname))) + (when (member local-nickname '("CL" "COMMON-LISP" "KEYWORD") + :test #'string=) + (cerror "Add nickname anyway" + 'simple-package-error + :package pkg + :format-control (intl:gettext "Local nickname cannot be \"CL\", \"COMMON-LISP\" or \"KEYWORD\"") + :format-arguments (list local-nickname))) + (let ((found-it (find-if #'(lambda (nick) + (string= nick local-nickname)) + nicks :key #'car))) + (when found-it + ;; If the local nickname alread exists and it's the same + ;; package, there's nothing to do. + (when (eq (cdr found-it) actual-pkg) + (return-from add-package-local-nickname pkg)) + ;; Otherwise, signal an error that the packages don't match. + (restart-case + (error 'simple-package-error + :package pkg + :format-control (intl:gettext "~A is already a local nickname for the package ~A in ~A") + :format-arguments (list local-nickname actual-pkg pkg)) + (keep-old-nickname () + :report (lambda (stream) + (format stream "Keep ~A as a local nickname for ~A~%" + local-nickname (cdr found-it))) + (return-from add-package-local-nickname (cdr found-it))) + (use-new-nickname () + :report (lambda (stream) + (format stream "Use ~A as a local nickname for ~A instead~%" + local-nickname actual-pkg)) + (setf (cdr found-it) actual-pkg) + (return-from add-package-local-nickname actual-pkg))))) + + ;; The new LOCAL-NICKNAME can't be the same as PACKAGE. + (when (string= local-nickname (package-name pkg)) + (cerror "Add nickname anyway" + 'simple-package-error + :package pkg + :format-control (intl:gettext "~A cannot be a package local nickname for the global package~_ ~A with the same name") + :format-arguments (list local-nickname pkg))) + + ;; Can't be a local nickname for any of the nicknames + (let ((found-it (find local-nickname + (package-nicknames pkg) + :test #'string=))) + (when found-it + (cerror "Use it as a local nickname anyway" + 'simple-package-error + :format-control (intl:gettext "~A cannot be a package local nickname for the global package~_ ~A with nickname ~A") + :format-arguments (list local-nickname pkg found-it)))) + + (setf (package-%local-nicknames pkg) + (push (cons local-nickname + (designator-package actual-package)) + nicks)) + pkg)) + +;;; REMOVE-PACKAGE-LOCAL-NICKNAME -- public. +;;; +(defun remove-package-local-nickname (old-nickname &optional (package *package*)) + "If Package has Old-Nickname as a local nickname, it is removed. + Returns true if the nickname existed and was removed. Otherwise + returns NIL." + (let* ((old-nick (if (packagep old-nickname) + (package-namestring old-nickname) + (package-namify old-nickname))) + (pkg (designator-package package)) + (nicks (package-%local-nicknames pkg)) + deletedp) + (setf (package-%local-nicknames pkg) + (delete-if #'(lambda (local-nick) + (when (string= local-nick old-nick) + (setf deletedp t))) + nicks :key #'car)) + deletedp)) + +;;; PACKAGE-LOCALLY-NICKNAMED-BY-LIST -- public +;;; +;;; FIXME: This is pretty inefficient because we have list all the +;;; packages and look throught the %local-nicknames to find the +;;; packages. We could probably make it faster if we added a new slot +;;; to the package structure similar to how we have %use-list and +;;; %used-by-list. +(defun package-locally-nicknamed-by-list (package) + "Returns a list of packages which have a local nickname for Package." + (let ((pkg (designator-package package))) + (loop for p in (list-all-packages) + when (find pkg + (package-%local-nicknames p) + :key #'cdr + :test #'eq) + collect p)))  ;;; Initialization. ===================================== src/code/print.lisp ===================================== @@ -696,7 +696,15 @@ ;; qualified. This can happen if the symbol has been inherited ;; from a package other than its home package. (unless (and accessible (eq symbol object)) - (output-symbol-name (package-name package) stream) + ;; If the actual symbol package has a local nickname in + ;; *package*, use that as the package name instead of the + ;; actual symbol package name. + (let ((local-nicks (package-%local-nicknames *package*)) + (pkg-name (package-name package))) + (when local-nicks + (setf pkg-name (or (car (rassoc package local-nicks)) + pkg-name))) + (output-symbol-name pkg-name stream)) (multiple-value-bind (symbol externalp) (find-external-symbol name package) (declare (ignore symbol)) ===================================== src/contrib/asdf/asdf.lisp ===================================== @@ -138,7 +138,7 @@ #+(or clasp abcl ecl cmu) #:ext #+ccl #:ccl #+lispworks #:hcl - #-(or allegro sbcl clasp abcl ccl lispworks ecl) + #-(or allegro sbcl clasp abcl ccl lispworks ecl cmu) (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 ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -8208,6 +8208,7 @@ msgid "" " (:EXPORT {symbol-name}*)\n" " (:INTERN {symbol-name}*)\n" " (:SIZE <integer>)\n" +" (:LOCAL-NICKNAMES {({nickname package}*)})\n" " All options except :SIZE and :DOCUMENTATION can be used multiple times." msgstr "" @@ -8551,6 +8552,58 @@ msgid "" " found instead of describing them." msgstr "" +#: src/code/package.lisp +msgid "" +"Returns an alist of (local-nickname . actual-package) describing the\n" +" nicknames local to Package." +msgstr "" + +#: src/code/package.lisp +msgid "" +"For the designated package Package (defaulting to *PACKAGE*), add\n" +" Local-Nickname as a package local nickname to the package\n" +" Actual-Package. Actual-Package and Package must be an package\n" +" designator. Local-Nickname should be a string designator.\n" +"\n" +" Returns the designated package.\n" +"\n" +" Signals a continuable error if any of the following are true:\n" +" - Local-Nickname is already a local nickname for a different package\n" +" - Local-Nickname is one of \"CL\", \"COMMON-LISP\", or \"KEYWORD\"\n" +" - Local-Nickname is a global name or nickname for designated package" +msgstr "" + +#: src/code/package.lisp +msgid "Local nickname cannot be \"CL\", \"COMMON-LISP\" or \"KEYWORD\"" +msgstr "" + +#: src/code/package.lisp +msgid "~A is already a local nickname for the package ~A in ~A" +msgstr "" + +#: src/code/package.lisp +msgid "" +"~A cannot be a package local nickname for the global package~_ ~A with the " +"same name" +msgstr "" + +#: src/code/package.lisp +msgid "" +"~A cannot be a package local nickname for the global package~_ ~A with " +"nickname ~A" +msgstr "" + +#: src/code/package.lisp +msgid "" +"If Package has Old-Nickname as a local nickname, it is removed.\n" +" Returns true if the nickname existed and was removed. Otherwise\n" +" returns NIL." +msgstr "" + +#: src/code/package.lisp +msgid "Returns a list of packages which have a local nickname for Package." +msgstr "" + #: src/code/reader.lisp msgid "Float format for 1.0E1" msgstr "" View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/9e6d1350be52233897d7024... -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/9e6d1350be52233897d7024... You're receiving this email because of your account on gitlab.common-lisp.net.