X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fpackages.impure.lisp;h=fbe8e5b6d8033800715d6e6e54cd4579abe1abb0;hb=7c15c5c42fb392729728d8b3c7eeee734e4375a3;hp=96431a5dd8a992ca380deb83adfa1463fb449a37;hpb=4c81c652cdc32faefee1bccb84c3c9a7854e3edd;p=sbcl.git diff --git a/tests/packages.impure.lisp b/tests/packages.impure.lisp index 96431a5..fbe8e5b 100644 --- a/tests/packages.impure.lisp +++ b/tests/packages.impure.lisp @@ -292,11 +292,362 @@ if a restart was invoked." ;;; MAKE-PACKAGE error in another thread blocking FIND-PACKAGE & FIND-SYMBOL (with-test (:name :bug-511072 :skipped-on '(not :sb-thread)) (let* ((p (make-package :bug-511072)) - (sem (sb-thread:make-semaphore)) - (t2 (sb-thread:make-thread (lambda () - (handler-bind ((error (lambda (c) - (sb-thread:signal-semaphore sem) - (signal c)))) - (make-package :bug-511072)))))) - (sb-thread:wait-on-semaphore sem) - (assert (eq 'cons (read-from-string "CL:CONS"))))) + (sem1 (sb-thread:make-semaphore)) + (sem2 (sb-thread:make-semaphore)) + (t2 (make-join-thread (lambda () + (handler-bind ((error (lambda (c) + (sb-thread:signal-semaphore sem1) + (sb-thread:wait-on-semaphore sem2) + (abort c)))) + (make-package :bug-511072)))))) + (sb-thread:wait-on-semaphore sem1) + (with-timeout 10 + (assert (eq 'cons (read-from-string "CL:CONS")))) + (sb-thread:signal-semaphore sem2))) + +(with-test (:name :quick-name-conflict-resolution-import) + (let (p1 p2) + (unwind-protect + (progn + (setf p1 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-IMPORT.1") + p2 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-IMPORT.2")) + (intern "FOO" p1) + (handler-bind ((name-conflict (lambda (c) + (invoke-restart 'sb-impl::dont-import-it)))) + (import (intern "FOO" p2) p1)) + (assert (not (eq (intern "FOO" p1) (intern "FOO" p2)))) + (handler-bind ((name-conflict (lambda (c) + (invoke-restart 'sb-impl::shadowing-import-it)))) + (import (intern "FOO" p2) p1)) + (assert (eq (intern "FOO" p1) (intern "FOO" p2)))) + (when p1 (delete-package p1)) + (when p2 (delete-package p2))))) + +(with-test (:name :quick-name-conflict-resolution-export.1) + (let (p1 p2) + (unwind-protect + (progn + (setf p1 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-EXPORT.1a") + p2 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-EXPORT.2a")) + (intern "FOO" p1) + (use-package p2 p1) + (handler-bind ((name-conflict (lambda (c) + (invoke-restart 'sb-impl::keep-old)))) + (export (intern "FOO" p2) p2)) + (assert (not (eq (intern "FOO" p1) (intern "FOO" p2))))) + (when p1 (delete-package p1)) + (when p2 (delete-package p2))))) + +(with-test (:name :quick-name-conflict-resolution-export.2) + (let (p1 p2) + (unwind-protect + (progn + (setf p1 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-EXPORT.1b") + p2 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-EXPORT.2b")) + (intern "FOO" p1) + (use-package p2 p1) + (handler-bind ((name-conflict (lambda (c) + (invoke-restart 'sb-impl::take-new)))) + (export (intern "FOO" p2) p2)) + (assert (eq (intern "FOO" p1) (intern "FOO" p2)))) + (when p1 (delete-package p1)) + (when p2 (delete-package p2))))) + +(with-test (:name :quick-name-conflict-resolution-use-package.1) + (let (p1 p2) + (unwind-protect + (progn + (setf p1 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-USE-PACKAGE.1a") + p2 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-USE-PACKAGE.2a")) + (intern "FOO" p1) + (intern "BAR" p1) + (export (intern "FOO" p2) p2) + (export (intern "BAR" p2) p2) + (handler-bind ((name-conflict (lambda (c) + (invoke-restart 'sb-impl::keep-old)))) + (use-package p2 p1)) + (assert (not (eq (intern "FOO" p1) (intern "FOO" p2)))) + (assert (not (eq (intern "BAR" p1) (intern "BAR" p2))))) + (when p1 (delete-package p1)) + (when p2 (delete-package p2))))) + +(with-test (:name :quick-name-conflict-resolution-use-package.2) + (let (p1 p2) + (unwind-protect + (progn + (setf p1 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-USE-PACKAGE.1b") + p2 (make-package "QUICK-NAME-CONFLICT-RESOLUTION-USE-PACKAGE.2b")) + (intern "FOO" p1) + (intern "BAR" p1) + (export (intern "FOO" p2) p2) + (export (intern "BAR" p2) p2) + (handler-bind ((name-conflict (lambda (c) + (invoke-restart 'sb-impl::take-new)))) + (use-package p2 p1)) + (assert (eq (intern "FOO" p1) (intern "FOO" p2))) + (assert (eq (intern "BAR" p1) (intern "BAR" p2)))) + (when p1 (delete-package p1)) + (when p2 (delete-package p2))))) + +(with-test (:name (:package-at-variance-restarts :shadow)) + (let ((p nil) + (*on-package-variance* '(:error t))) + (unwind-protect + (progn + (setf p (eval `(defpackage :package-at-variance-restarts.1 + (:use :cl) + (:shadow "CONS")))) + (handler-bind ((sb-kernel::package-at-variance-error + (lambda (c) + (invoke-restart 'sb-impl::keep-them)))) + (eval `(defpackage :package-at-variance-restarts.1 + (:use :cl)))) + (assert (not (eq 'cl:cons (intern "CONS" p)))) + (handler-bind ((sb-kernel::package-at-variance-error + (lambda (c) + (invoke-restart 'sb-impl::drop-them)))) + (eval `(defpackage :package-at-variance-restarts.1 + (:use :cl)))) + (assert (eq 'cl:cons (intern "CONS" p)))) + (when p (delete-package p))))) + +(with-test (:name (:package-at-variance-restarts :use)) + (let ((p nil) + (*on-package-variance* '(:error t))) + (unwind-protect + (progn + (setf p (eval `(defpackage :package-at-variance-restarts.2 + (:use :cl)))) + (handler-bind ((sb-kernel::package-at-variance-error + (lambda (c) + (invoke-restart 'sb-impl::keep-them)))) + (eval `(defpackage :package-at-variance-restarts.2 + (:use)))) + (assert (eq 'cl:cons (intern "CONS" p))) + (handler-bind ((sb-kernel::package-at-variance-error + (lambda (c) + (invoke-restart 'sb-impl::drop-them)))) + (eval `(defpackage :package-at-variance-restarts.2 + (:use)))) + (assert (not (eq 'cl:cons (intern "CONS" p))))) + (when p (delete-package p))))) + +(with-test (:name (:package-at-variance-restarts :export)) + (let ((p nil) + (*on-package-variance* '(:error t))) + (unwind-protect + (progn + (setf p (eval `(defpackage :package-at-variance-restarts.4 + (:export "FOO")))) + (handler-bind ((sb-kernel::package-at-variance-error + (lambda (c) + (invoke-restart 'sb-impl::keep-them)))) + (eval `(defpackage :package-at-variance-restarts.4))) + (assert (eq :external (nth-value 1 (find-symbol "FOO" p)))) + (handler-bind ((sb-kernel::package-at-variance-error + (lambda (c) + (invoke-restart 'sb-impl::drop-them)))) + (eval `(defpackage :package-at-variance-restarts.4))) + (assert (eq :internal (nth-value 1 (find-symbol "FOO" p))))) + (when p (delete-package p))))) + +(with-test (:name (:package-at-variance-restarts :implement)) + (let ((p nil) + (*on-package-variance* '(:error t))) + (unwind-protect + (progn + (setf p (eval `(defpackage :package-at-variance-restarts.5 + (:implement :sb-int)))) + (handler-bind ((sb-kernel::package-at-variance-error + (lambda (c) + (invoke-restart 'sb-impl::keep-them)))) + (eval `(defpackage :package-at-variance-restarts.5))) + (assert (member p (package-implemented-by-list :sb-int))) + (handler-bind ((sb-kernel::package-at-variance-error + (lambda (c) + (invoke-restart 'sb-impl::drop-them)))) + (eval `(defpackage :package-at-variance-restarts.5))) + (assert (not (member p (package-implemented-by-list :sb-int))))) + (when p (delete-package p))))) + +(with-test (:name (:delete-package :implementation-package)) + (let (p1 p2) + (unwind-protect + (progn + (setf p1 (make-package "DELETE-PACKAGE/IMPLEMENTATION-PACKAGE.1") + p2 (make-package "DELETE-PACKAGE/IMPLEMENTATION-PACKAGE.2")) + (add-implementation-package p2 p1) + (assert (= 1 (length (package-implemented-by-list p1)))) + (delete-package p2) + (assert (= 0 (length (package-implemented-by-list p1))))) + (when p1 (delete-package p1)) + (when p2 (delete-package p2))))) + +(with-test (:name (:delete-package :implementated-package)) + (let (p1 p2) + (unwind-protect + (progn + (setf p1 (make-package "DELETE-PACKAGE/IMPLEMENTED-PACKAGE.1") + p2 (make-package "DELETE-PACKAGE/IMPLEMENTED-PACKAGE.2")) + (add-implementation-package p2 p1) + (assert (= 1 (length (package-implements-list p2)))) + (delete-package p1) + (assert (= 0 (length (package-implements-list p2))))) + (when p1 (delete-package p1)) + (when p2 (delete-package p2))))) + +(with-test (:name :package-local-nicknames) + ;; Clear slate + (without-package-locks + (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 + (:local-nicknames (:l :cl) (:sb :sb-ext)))) + (eval `(defpackage :package-local-nicknames-test-2 + (:export "CONS"))) + ;; Introspection + (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 "SB" (find-package "SB-EXT")) (assoc "SB" alist :test 'string=))) + (assert (eql 2 (length alist)))) + ;; Usage + (let ((*package* (find-package :package-local-nicknames-test-1))) + (let ((cons0 (read-from-string "L:CONS")) + (exit0 (read-from-string "SB:EXIT")) + (cons1 (find-symbol "CONS" :l)) + (exit1 (find-symbol "EXIT" :sb)) + (cl (find-package :l)) + (sb (find-package :sb))) + (assert (eq 'cons cons0)) + (assert (eq 'cons cons1)) + (assert (equal "L:CONS" (prin1-to-string cons0))) + (assert (eq 'sb-ext:exit exit0)) + (assert (eq 'sb-ext:exit exit1)) + (assert (equal "SB:EXIT" (prin1-to-string exit0))) + (assert (eq cl (find-package :common-lisp))) + (assert (eq sb (find-package :sb-ext))))) + ;; 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) + (error () + :oopsie)))) + ;; But same name twice is OK. + (add-package-local-nickname :l :cl :package-local-nicknames-test-1) + ;; Removal. + (assert (remove-package-local-nickname :l :package-local-nicknames-test-1)) + (let ((*package* (find-package :package-local-nicknames-test-1))) + (let ((exit0 (read-from-string "SB:EXIT")) + (exit1 (find-symbol "EXIT" :sb)) + (sb (find-package :sb))) + (assert (eq 'sb-ext:exit exit0)) + (assert (eq 'sb-ext:exit exit1)) + (assert (equal "SB:EXIT" (prin1-to-string exit0))) + (assert (eq sb (find-package :sb-ext))) + (assert (not (find-package :l))))) + ;; Adding back as another package. + (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 "SB:EXIT")) + (cons1 (find-symbol "CONS" :l)) + (exit1 (find-symbol "EXIT" :sb)) + (cl (find-package :l)) + (sb (find-package :sb))) + (assert (eq cons0 cons1)) + (assert (not (eq 'cons cons0))) + (assert (eq (find-symbol "CONS" :package-local-nicknames-test-2) + cons0)) + (assert (equal "L:CONS" (prin1-to-string cons0))) + (assert (eq 'sb-ext:exit exit0)) + (assert (eq 'sb-ext:exit exit1)) + (assert (equal "SB:EXIT" (prin1-to-string exit0))) + (assert (eq cl (find-package :package-local-nicknames-test-2))) + (assert (eq sb (find-package :sb-ext))))) + ;; Interaction with package locks. + (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) + (package-lock-violation () + :package-oopsie)))) + (assert (eq :package-oopsie + (handler-case + (remove-package-local-nickname :l :package-local-nicknames-test-1) + (package-lock-violation () + :package-oopsie)))) + (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))))) + +(with-test (:name (: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))))) + +(with-test (:name (: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))))) + +(with-test (:name :own-name-as-local-nickname) + (with-tmp-packages ((p1 (make-package "OWN-NAME-AS-NICKNAME1")) + (p2 (make-package "OWN-NAME-AS-NICKNAME2"))) + (assert (eq :oops + (handler-case + (add-package-local-nickname :own-name-as-nickname1 p2 p1) + (error () + :oops)))) + (handler-bind ((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)))))) + +(with-test (:name :own-nickname-as-local-nickname) + (with-tmp-packages ((p1 (make-package "OWN-NICKNAME-AS-NICKNAME1" + :nicknames '("OWN-NICKNAME"))) + (p2 (make-package "OWN-NICKNAME-AS-NICKNAME2"))) + (assert (eq :oops + (handler-case + (add-package-local-nickname :own-nickname p2 p1) + (error () + :oops)))) + (handler-bind ((error #'continue)) + (add-package-local-nickname :own-nickname p2 p1)) + (assert (eq (intern "FOO" p2) + (let ((*package* p1)) + (intern "FOO" :own-nickname)))))) + +(with-test (:name :delete-package-restart) + (let* (ok + (result + (handler-bind + ((sb-kernel:simple-package-error + (lambda (c) + (setf ok t) + (continue c)))) + (delete-package (gensym))))) + (assert ok) + (assert (not result))))