GitLab

at 2025-06-30T07:18:34-07:00

Fix #415:  Add support for package-local-nicknames

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
     $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.git)

+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
 	      (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))
   (: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*"

 	   "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")

 #+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.")

   (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)))

                    (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

 ;;;

 ;;;

   (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)))))

 	 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.

      (: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)

       (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.")))

 		    `(: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.

 				    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))

 	     :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)

 	     (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

 ;;;

     (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)

 			      (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)

 		     (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.

 	    ;; 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))

    #+(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

 "     (: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 ""

 "  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 ""

Raymond Toy pushed to branch master at cmucl / cmucl

Commits:

7 changed files:

Changes: