From d4e32c39ff9c8d5a2d6f46e0c3c6b1d18bbb1157 Mon Sep 17 00:00:00 2001 From: Karsten Poeck Date: Sun, 10 May 2020 22:56:29 +0200 Subject: [PATCH 1/2] Add tests for package local nicknames --- ansi-tests/package-local-nicknames.lisp | 344 ++++++++++++++++++++++++ load.lisp | 1 + 2 files changed, 345 insertions(+) create mode 100644 ansi-tests/package-local-nicknames.lisp diff --git a/ansi-tests/package-local-nicknames.lisp b/ansi-tests/package-local-nicknames.lisp new file mode 100644 index 00000000..8e2a361f --- /dev/null +++ b/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 +|# + +;;; 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))))) diff --git a/load.lisp b/load.lisp index 06533a74..9ed6209a 100644 --- a/load.lisp +++ b/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")))) From 0db91226fd258d16b1232905bd54f3e0fe2066d9 Mon Sep 17 00:00:00 2001 From: Karsten Poeck Date: Mon, 11 May 2020 00:01:53 +0200 Subject: [PATCH 2/2] Moved package-local-nicknames.lisp to beyond-ansi --- .../beyond-ansi/package-local-nicknames.lisp | 0 ansi-tests/package-local-nicknames.lisp | 344 ------------------ load.lisp | 2 +- 3 files changed, 1 insertion(+), 345 deletions(-) create mode 100644 ansi-tests/beyond-ansi/package-local-nicknames.lisp delete mode 100644 ansi-tests/package-local-nicknames.lisp diff --git a/ansi-tests/beyond-ansi/package-local-nicknames.lisp b/ansi-tests/beyond-ansi/package-local-nicknames.lisp new file mode 100644 index 00000000..e69de29b diff --git a/ansi-tests/package-local-nicknames.lisp b/ansi-tests/package-local-nicknames.lisp deleted file mode 100644 index 8e2a361f..00000000 --- a/ansi-tests/package-local-nicknames.lisp +++ /dev/null @@ -1,344 +0,0 @@ -(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 -|# - -;;; 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))))) diff --git a/load.lisp b/load.lisp index 9ed6209a..86151489 100644 --- a/load.lisp +++ b/load.lisp @@ -13,7 +13,7 @@ (load "gclload1.lsp") (when ansi (load "gclload2.lsp")) - (load "tests:ansi-tests;package-local-nicknames.lisp") + (load "tests:ansi-tests;beyond-ansi;package-local-nicknames.lisp") (when ccl (load "ccl.lsp"))))