Add tests for package local nicknames

ansi-tests/package-local-nicknames.lisp

@@ -0,0 +1,344 @@
+(in-package :cl-test)
+
+(import '(ccl:package-local-nicknames
+          ccl:package-locally-nicknamed-by-list
+          ccl:add-package-local-nickname
+          ccl:remove-package-local-nickname)
+        (find-package :cl-test))
+
+;;; https://github.com/phoe/trivial-package-local-nicknames/blob/master/trivial-package-local-nicknames.lisp
+;;; License https://github.com/phoe/trivial-package-local-nicknames/blob/master/LICENSE
+#|
+This is free and unencumbered software released into the public domain.
+
+Anyone is free to copy, modify, publish, use, compile, sell, or
+distribute this software, either in source code form or as a compiled
+binary, for any purpose, commercial or non-commercial, and by any
+means.
+
+In jurisdictions that recognize copyright laws, the author or authors
+of this software dedicate any and all copyright interest in the
+software to the public domain. We make this dedication for the benefit
+of the public at large and to the detriment of our heirs and
+successors. We intend this dedication to be an overt act of
+relinquishment in perpetuity of all present and future rights to this
+software under copyright law.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR
+OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
+ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
+OTHER DEALINGS IN THE SOFTWARE.
+
+For more information, please refer to <http://unlicense.org>
+|#
+
+;;; Test data
+
+(progn
+  (defparameter +test-data+
+    #+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."))))
+
+;;; Test runner
+#|
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defvar *tests* '()))
+
+(defmacro define-test (name &body body)
+  `(progn
+     (defun ,name () ,@body)
+     (pushnew ',name *tests*)
+     ',name))
+
+(defun run (&optional (ignore-errors t))
+  (let ((errors '()))
+    (dolist (test *tests*)
+      (if ignore-errors
+          (handler-case (funcall test)
+            (error (e)
+              (format t ";; ~A:~%;;;; ~A~%" test e)
+              (push e errors)))
+          (funcall test)))
+    (format t ";;~%;; ~D tests run, ~D failures."
+            (length *tests*) (length errors))
+    (null errors)))
+|#
+
+(defmacro define-test (name &body body)
+  `(rt:deftest ,name
+     (let ()
+       ,@body
+       nil)
+     nil))
+
+;;; Test code
+
+(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)))
+  (eval `(defpackage :package-local-nicknames-test-1 (:use)
+                     (:local-nicknames (:l :cl) (,+nn-name+ ,+pkg-name+))))
+  (eval `(defpackage :package-local-nicknames-test-2 (:use)
+                     (:export "CONS"))))
+
+
+(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 (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-symbol-printing
+  (reset-test-packages)
+  (let ((*package* (find-package :package-local-nicknames-test-1)))
+    (let ((cons0 (read-from-string "L:CONS"))
+          (exit0 (read-from-string +sym-fullname+)))
+      (assert (equal "L:CONS" (prin1-to-string cons0)))
+      (assert (equal +sym-fullnickname+ (prin1-to-string exit0))))))
+
+(define-test test-package-local-nicknames-nickname-collision
+  (reset-test-packages)
+  ;; Can't add same name twice for different global names.
+  (assert (eq :oopsie
+              (handler-case
+                  (add-package-local-nickname :l :package-local-nicknames-test-2
+                                              :package-local-nicknames-test-1)
+                (package-error () :oopsie))))
+  ;; ...but same name twice is OK.
+  (add-package-local-nickname :l :cl :package-local-nicknames-test-1)
+  (add-package-local-nickname #\L :cl :package-local-nicknames-test-1))
+
+(define-test test-package-local-nicknames-nickname-removal
+  (reset-test-packages)
+  (assert (= 2 (length (package-local-nicknames :package-local-nicknames-test-1))))
+  (assert (remove-package-local-nickname :l :package-local-nicknames-test-1))
+  (assert (= 1 (length (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
+  (declare (optimize (debug 3) (speed 0)))
+  (reset-test-packages)
+  (assert (= 2 (length (package-local-nicknames :package-local-nicknames-test-1))))
+  (assert (remove-package-local-nickname #\L :package-local-nicknames-test-1))
+  (assert (= 1 (length (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-remaining
+  (reset-test-packages)
+  (remove-package-local-nickname :l :package-local-nicknames-test-1)
+  (let ((*package* (find-package :package-local-nicknames-test-1)))
+    (let ((exit0 (read-from-string +sym-fullname+))
+          (exit1 (find-symbol +sym-sname+ +nn-name+))
+          (sb (find-package +nn-name+)))
+      (assert (eq +sym+ exit0))
+      (assert (eq +sym+ exit1))
+      (assert (equal +sym-fullnickname+ (prin1-to-string exit0)))
+      (assert (eq sb (find-package +pkg-name+))))))
+
+(define-test test-package-local-nicknames-nickname-removal-readd-another-symbol-equality
+  (reset-test-packages)
+  (assert (remove-package-local-nickname :l :package-local-nicknames-test-1))
+  (assert (eq (find-package :package-local-nicknames-test-1)
+              (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 ((cons0 (read-from-string "L:CONS"))
+          (cons1 (find-symbol "CONS" :l))
+          (exit0 (read-from-string +sym-fullnickname+))
+          (exit1 (find-symbol +sym-sname+ +nn-name+)))
+      (assert (eq cons0 cons1))
+      (assert (not (eq 'cons cons0)))
+      (assert (eq (find-symbol "CONS" :package-local-nicknames-test-2)
+                  cons0))
+      (assert (eq +sym+ exit0))
+      (assert (eq +sym+ exit1)))))
+
+(define-test test-package-local-nicknames-nickname-removal-readd-another-package-equality
+  (reset-test-packages)
+  (assert (remove-package-local-nickname :l :package-local-nicknames-test-1))
+  (assert (eq (find-package :package-local-nicknames-test-1)
+              (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+))))))
+
+(define-test test-package-local-nicknames-nickname-removal-readd-another-symbol-printing
+  (reset-test-packages)
+  (assert (remove-package-local-nickname :l :package-local-nicknames-test-1))
+  (assert (eq (find-package :package-local-nicknames-test-1)
+              (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 ((cons0 (read-from-string "L:CONS"))
+          (exit0 (read-from-string +sym-fullnickname+)))
+      (assert (equal "L:CONS" (prin1-to-string cons0)))
+      (assert (equal +sym-fullnickname+ (prin1-to-string exit0))))))
+
+#+sbcl
+(define-test test-package-local-nicknames-package-locks
+  ;; TODO Support for other implementations with package locks.
+  (reset-test-packages)
+  (progn
+    (sb-ext:lock-package :package-local-nicknames-test-1)
+    (assert (eq :package-oopsie
+                (handler-case
+                    (add-package-local-nickname :c :sb-c :package-local-nicknames-test-1)
+                  (sb-ext:package-lock-violation ()
+                    :package-oopsie))))
+    (assert (eq :package-oopsie
+                (handler-case
+                    (remove-package-local-nickname :l :package-local-nicknames-test-1)
+                  (sb-ext:package-lock-violation ()
+                    :package-oopsie))))
+    (sb-ext:unlock-package :package-local-nicknames-test-1)
+    (add-package-local-nickname :c :sb-c :package-local-nicknames-test-1)
+    (remove-package-local-nickname :l :package-local-nicknames-test-1)))
+
+(defmacro with-tmp-packages (bindings &body body)
+  `(let ,(mapcar #'car bindings)
+     (unwind-protect
+          (progn
+            (setf ,@(apply #'append bindings))
+            ,@body)
+       ,@(mapcar (lambda (p)
+                   `(when ,p (delete-package ,p)))
+                 (mapcar #'car bindings)))))
+
+(define-test test-delete-package-locally-nicknames-others
+  (with-tmp-packages ((p1 (make-package "LOCALLY-NICKNAMES-OTHERS"))
+                      (p2 (make-package "LOCALLY-NICKNAMED-BY-OTHERS")))
+    (add-package-local-nickname :foo p2 p1)
+    (assert (equal (list p1) (package-locally-nicknamed-by-list p2)))
+    (delete-package p1)
+    (assert (not (package-locally-nicknamed-by-list p2)))))
+
+(define-test test-delete-package-locally-nicknamed-by-others
+  (with-tmp-packages ((p1 (make-package "LOCALLY-NICKNAMES-OTHERS"))
+                      (p2 (make-package "LOCALLY-NICKNAMED-BY-OTHERS")))
+    (add-package-local-nickname :foo p2 p1)
+    (assert (package-local-nicknames p1))
+    (delete-package p2)
+    (assert (not (package-local-nicknames p1)))))
+
+(define-test test-own-name-as-local-nickname-cerror
+  (with-tmp-packages ((p1 (make-package "OWN-NAME-AS-NICKNAME1"))
+                      (p2 (make-package "OWN-NAME-AS-NICKNAME2")))
+    (assert (eq :oopsie
+                (handler-case
+                    (add-package-local-nickname :own-name-as-nickname1 p2 p1)
+                  (package-error () :oopsie))))
+    (handler-bind ((package-error #'continue))
+      (add-package-local-nickname :own-name-as-nickname1 p2 p1))))
+
+(define-test test-own-name-as-local-nickname-intern
+  (with-tmp-packages ((p1 (make-package "OWN-NAME-AS-NICKNAME1"))
+                      (p2 (make-package "OWN-NAME-AS-NICKNAME2")))
+    (handler-bind ((package-error #'continue))
+      (add-package-local-nickname :own-name-as-nickname1 p2 p1))
+    (assert (eq (intern "FOO" p2)
+                (let ((*package* p1))
+                  (intern "FOO" :own-name-as-nickname1))))
+    (let ((sym (intern "BAR" p2))
+          (lam '(lambda (x) (intern x :own-name-as-nickname1))))
+      (dolist (p '("COMMON-LISP" "KEYWORD" "COMMON-LISP-USER"
+                   "OWN-NAME-AS-NICKNAME1"
+                   "OWN-NAME-AS-NICKNAME2"))
+        (let ((*package* p1))
+          (assert (eq sym (funcall
+                           (let ((*package* (find-package p))) (compile nil lam))
+                           "BAR"))
+                  ()
+                  "test-own-name-as-local-nickname-intern failed for p = ~s"
+                  p))))))
+
+(define-test test-own-nickname-as-local-nickname-cerror
+  (with-tmp-packages ((p1 (make-package "OWN-NICKNAME-AS-NICKNAME1"
+                                        :nicknames '("OWN-NICKNAME")))
+                      (p2 (make-package "OWN-NICKNAME-AS-NICKNAME2")))
+    (assert (eq :oopsie
+                (handler-case
+                    (add-package-local-nickname :own-nickname p2 p1)
+                  (package-error () :oopsie))))
+    (handler-bind ((package-error #'continue))
+      (add-package-local-nickname :own-nickname p2 p1))))
+
+(define-test test-own-nickname-as-local-nickname-intern
+  (with-tmp-packages ((p1 (make-package "OWN-NICKNAME-AS-NICKNAME1"
+                                        :nicknames '("OWN-NICKNAME")))
+                      (p2 (make-package "OWN-NICKNAME-AS-NICKNAME2")))
+    (handler-bind ((package-error #'continue))
+      (add-package-local-nickname :own-nickname p2 p1))
+    (assert (eq (intern "FOO" p2)
+                (let ((*package* p1))
+                  (intern "FOO" :own-nickname))))
+    (let ((sym (intern "BAR" p2))
+          (lam '(lambda (x) (intern x :own-nickname)))
+          (*package* p1))
+      (dolist (p '("COMMON-LISP" "KEYWORD" "COMMON-LISP-USER"
+                   "OWN-NICKNAME-AS-NICKNAME1"
+                   "OWN-NICKNAME-AS-NICKNAME2"))
+        (assert (eq sym
+                    (funcall
+                     (let ((*package* (find-package p))) (compile nil lam))
+                     "BAR"))
+                ()
+                "test-own-nickname-as-local-nickname-intern failed on p = ~s"
+                p)))))

load.lisp

@@ -13,6 +13,7 @@
     (load "gclload1.lsp")
     (when ansi
       (load "gclload2.lsp"))
+    (load "tests:ansi-tests;package-local-nicknames.lisp")
     (when ccl
       (load "ccl.lsp"))))