[armedbear-cvs] r14430 - in trunk/abcl: . test/lisp/abcl
rschlatte at common-lisp.net
rschlatte at common-lisp.net
Sat Mar 9 13:02:46 UTC 2013
Author: rschlatte
Date: Sat Mar 9 05:02:45 2013
New Revision: 14430
Log:
Add tests for package-local nicknames
Added:
trunk/abcl/test/lisp/abcl/package-local-nicknames-tests.lisp
Modified:
trunk/abcl/abcl.asd
Modified: trunk/abcl/abcl.asd
==============================================================================
--- trunk/abcl/abcl.asd Sat Mar 9 05:02:37 2013 (r14429)
+++ trunk/abcl/abcl.asd Sat Mar 9 05:02:45 2013 (r14430)
@@ -61,7 +61,9 @@
(:file "zip")
#+abcl
(:file "pathname-tests" :depends-on
- ("utilities"))))))
+ ("utilities"))
+ #+abcl
+ (:file "package-local-nicknames-tests")))))
(defmethod perform ((o test-op) (c (eql (find-system 'abcl-test-lisp))))
"Invoke tests with (asdf:oos 'asdf:test-op :abcl-test-lisp)."
Added: trunk/abcl/test/lisp/abcl/package-local-nicknames-tests.lisp
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ trunk/abcl/test/lisp/abcl/package-local-nicknames-tests.lisp Sat Mar 9 05:02:45 2013 (r14430)
@@ -0,0 +1,181 @@
+;;; package-local-nicknames-tests.lisp
+;;;
+;;; Copyright (C) 2013 Nikodemus Siivola, Rudolf Schlatte
+;;; $Id$
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License
+;;; as published by the Free Software Foundation; either version 2
+;;; of the License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+;;; Most of these tests are adapted from the SBCL test suite.
+
+(in-package #:abcl.test.lisp)
+
+(defmacro with-tmp-packages (bindings &body body)
+ `(let ,(mapcar #'car bindings)
+ (unwind-protect
+ (progn
+ (setf ,@(apply #'append bindings))
+ , at body)
+ ,@(mapcar (lambda (p)
+ `(when ,p (delete-package ,p)))
+ (mapcar #'car bindings)))))
+
+(defpackage :package-local-nicknames-test-1
+ (:local-nicknames (:l :cl) (:e :ext)))
+
+(defpackage :package-local-nicknames-test-2
+ (:export "CONS"))
+
+(deftest pln-introspect
+ (let ((alist (ext:package-local-nicknames :package-local-nicknames-test-1)))
+ (values
+ (equal (cons "L" (find-package "CL")) (assoc "L" alist :test 'string=))
+ (equal (cons "E" (find-package "EXT")) (assoc "E" alist :test 'string=))
+ (eql 2 (length alist))))
+ t
+ t
+ t)
+
+(deftest pln-usage
+ (let ((*package* (find-package :package-local-nicknames-test-1)))
+ (let ((cons0 (read-from-string "L:CONS"))
+ (exit0 (read-from-string "E:EXIT"))
+ (cons1 (find-symbol "CONS" :l))
+ (exit1 (find-symbol "EXIT" :e))
+ (cl (find-package :l))
+ (ext (find-package :e)))
+ (values
+ (eq 'cons cons0)
+ (eq 'cons cons1)
+ (equal "L:CONS" (prin1-to-string cons0))
+ (eq 'ext:exit exit0)
+ (eq 'ext:exit exit1)
+ (equal "E:EXIT" (prin1-to-string exit0))
+ (eq cl (find-package :common-lisp))
+ (eq ext (find-package :ext)))))
+ T
+ T
+ T
+ T
+ T
+ T
+ T
+ T)
+
+(deftest pln-add-nickname-twice
+ (handler-case
+ (ext:add-package-local-nickname :l :package-local-nicknames-test-2
+ :package-local-nicknames-test-1)
+ (error ()
+ :oopsie))
+ :oopsie)
+
+(deftest pln-add-same-nickname
+ (progn (ext:add-package-local-nickname :l :cl
+ :package-local-nicknames-test-1)
+ :okay)
+ :okay)
+
+(deftest pln-remove-local-nickname
+ (progn
+ (assert (ext:remove-package-local-nickname :l :package-local-nicknames-test-1))
+ (assert (not (ext:remove-package-local-nickname :l :package-local-nicknames-test-1)))
+ (let ((*package* (find-package :package-local-nicknames-test-1)))
+ (let ((exit0 (read-from-string "E:EXIT"))
+ (exit1 (find-symbol "EXIT" :e))
+ (e (find-package :e)))
+ (assert (eq 'ext:exit exit0))
+ (assert (eq 'ext:exit exit1))
+ (assert (equal "E:EXIT" (prin1-to-string exit0)))
+ (assert (eq e (find-package :ext)))
+ (assert (not (find-package :l)))))
+ (assert (eq (find-package :package-local-nicknames-test-1)
+ (ext: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 "E:EXIT"))
+ (cons1 (find-symbol "CONS" :l))
+ (exit1 (find-symbol "EXIT" :e))
+ (cl (find-package :l))
+ (e (find-package :e)))
+ (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 'ext:exit exit0))
+ (assert (eq 'ext:exit exit1))
+ (assert (equal "E:EXIT" (prin1-to-string exit0)))
+ (assert (eq cl (find-package :package-local-nicknames-test-2)))
+ (assert (eq e (find-package :ext)))))
+ :success)
+ :success)
+
+(deftest pln-delete-locally-nicknaming-package
+ (with-tmp-packages ((p1 (make-package "LOCALLY-NICKNAMES-OTHERS"))
+ (p2 (make-package "LOCALLY-NICKNAMED-BY-OTHERS")))
+ (ext:add-package-local-nickname :foo p2 p1)
+ (assert (equal (list p1) (ext:package-locally-nicknamed-by-list p2)))
+ (delete-package p1)
+ (assert (null (ext:package-locally-nicknamed-by-list p2)))
+ :success)
+ :success)
+
+(deftest pln-delete-locally-nicknamed-package
+ (with-tmp-packages ((p1 (make-package "LOCALLY-NICKNAMES-OTHERS"))
+ (p2 (make-package "LOCALLY-NICKNAMED-BY-OTHERS")))
+ (ext:add-package-local-nickname :foo p2 p1)
+ (assert (ext:package-local-nicknames p1))
+ (delete-package p2)
+ (assert (null (ext:package-local-nicknames p1)))
+ :success)
+ :success)
+
+(deftest pln-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
+ (ext:add-package-local-nickname :own-name-as-nickname1 p2 p1)
+ (error ()
+ :oops))))
+ ;; TODO: add continuable errors for this
+ ;; (handler-bind ((error #'continue))
+ ;; (ext:add-package-local-nickname :own-name-as-nickname1 p2 p1))
+ ;; (assert (eq (intern "FOO" p2)
+ ;; (let ((*package* p1))
+ ;; (intern "FOO" :own-name-as-nickname1))))
+ :success)
+ :success)
+
+
+
+(deftest pln-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))))
+ ;; TODO: make errors continuable
+ ;; (handler-bind ((error #'continue))
+ ;; (add-package-local-nickname :own-nickname p2 p1))
+ ;; (assert (eq (intern "FOO" p2)
+ ;; (let ((*package* p1))
+ ;; (intern "FOO" :own-nickname))))
+ :success)
+ :success)
More information about the armedbear-cvs
mailing list