source: trunk/abcl/test/lisp/abcl/package-local-nicknames-tests.lisp

Last change on this file was 15332, checked in by Mark Evenson, 4 years ago

Revisions for the long neglected ABCL/TEST/LISP suite

Restore loading under SBCL and CCL.

FIXME: package-local-nicknames-tests only runs once in the same
process, causing a mysterious failure on the second time.
File size: 6.8 KB
Line 
1;;; package-local-nicknames-tests.lisp
2;;;
3;;; Copyright (C) 2013 Nikodemus Siivola, Rudolf Schlatte
4;;; $Id$
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
19
20;;; Most of these tests are adapted from the SBCL test suite.
21
22;;;; FIXME:  re-running these tests in the same process fails the second time due to interactions
23;;;          with the problems with DEFPACKAGE "only being run once"
24
25(in-package #:abcl.test.lisp)
26
27(defmacro with-tmp-packages (bindings &body body)
28  `(let ,(mapcar #'car bindings)
29     (unwind-protect
30          (progn
31            (setf ,@(apply #'append bindings))
32            ,@body)
33       ,@(mapcar (lambda (p)
34                   `(when ,p (delete-package ,p)))
35                 (mapcar #'car bindings)))))
36
37(defpackage :package-local-nicknames-test-1
38           (:local-nicknames (:l :cl) (:e :ext)))
39
40(defpackage :package-local-nicknames-test-2
41           (:export "CONS"))
42
43(deftest pln-introspect
44    (let ((alist (ext:package-local-nicknames :package-local-nicknames-test-1)))
45      (values
46       (equal (cons "L" (find-package "CL")) (assoc "L" alist :test 'string=))
47       (equal (cons "E" (find-package "EXT")) (assoc "E" alist :test 'string=))
48       (eql 2 (length alist))))
49  t
50  t
51  t)
52
53(deftest pln-usage
54    (let ((*package* (find-package :package-local-nicknames-test-1)))
55      (let ((cons0 (read-from-string "L:CONS"))
56            (exit0 (read-from-string "E:EXIT"))
57            (cons1 (find-symbol "CONS" :l))
58            (exit1 (find-symbol "EXIT" :e))
59            (cl (find-package :l))
60            (ext (find-package :e)))
61        (values
62         (eq 'cons cons0)
63         (eq 'cons cons1)
64         (equal "L:CONS" (prin1-to-string cons0))
65         (eq 'ext:exit exit0)
66         (eq 'ext:exit exit1)
67         (equal "E:EXIT" (prin1-to-string exit0))
68         (eq cl (find-package :common-lisp))
69         (eq ext (find-package :ext)))))
70  T
71  T
72  T
73  T
74  T
75  T
76  T
77  T)
78
79(deftest pln-add-nickname-twice
80    (handler-case
81        (ext:add-package-local-nickname :l :package-local-nicknames-test-2
82                                        :package-local-nicknames-test-1)
83      (error ()
84        :oopsie))
85  :oopsie)
86
87(deftest pln-add-same-nickname
88    (progn (ext:add-package-local-nickname :l :cl
89                                           :package-local-nicknames-test-1)
90           :okay)
91  :okay)
92
93(deftest pln-remove-local-nickname
94    (progn
95      (assert (ext:remove-package-local-nickname :l :package-local-nicknames-test-1))
96      (assert (not (ext:remove-package-local-nickname :l :package-local-nicknames-test-1)))
97      (let ((*package* (find-package :package-local-nicknames-test-1)))
98        (let ((exit0 (read-from-string "E:EXIT"))
99              (exit1 (find-symbol "EXIT" :e))
100              (e (find-package :e)))
101          (assert (eq 'ext:exit exit0))
102          (assert (eq 'ext:exit exit1))
103          (assert (equal "E:EXIT" (prin1-to-string exit0)))
104          (assert (eq e (find-package :ext)))
105          (assert (not (find-package :l)))))
106      (assert (eq (find-package :package-local-nicknames-test-1)
107                  (ext:add-package-local-nickname :l :package-local-nicknames-test-2
108                                              :package-local-nicknames-test-1)))
109      (let ((*package* (find-package :package-local-nicknames-test-1)))
110        (let ((cons0 (read-from-string "L:CONS"))
111              (exit0 (read-from-string "E:EXIT"))
112              (cons1 (find-symbol "CONS" :l))
113              (exit1 (find-symbol "EXIT" :e))
114              (cl (find-package :l))
115              (e (find-package :e)))
116          (assert (eq cons0 cons1))
117          (assert (not (eq 'cons cons0)))
118          (assert (eq (find-symbol "CONS" :package-local-nicknames-test-2)
119                      cons0))
120          (assert (equal "L:CONS" (prin1-to-string cons0)))
121          (assert (eq 'ext:exit exit0))
122          (assert (eq 'ext:exit exit1))
123          (assert (equal "E:EXIT" (prin1-to-string exit0)))
124          (assert (eq cl (find-package :package-local-nicknames-test-2)))
125          (assert (eq e (find-package :ext)))))
126      :success)
127  :success)
128
129(deftest pln-delete-locally-nicknaming-package
130    (with-tmp-packages ((p1 (make-package "LOCALLY-NICKNAMES-OTHERS"))
131                        (p2 (make-package "LOCALLY-NICKNAMED-BY-OTHERS")))
132      (ext:add-package-local-nickname :foo p2 p1)
133      (assert (equal (list p1) (ext:package-locally-nicknamed-by-list p2)))
134      (delete-package p1)
135      (assert (null (ext:package-locally-nicknamed-by-list p2)))
136      :success)
137  :success)
138
139(deftest pln-delete-locally-nicknamed-package
140    (with-tmp-packages ((p1 (make-package "LOCALLY-NICKNAMES-OTHERS"))
141                        (p2 (make-package "LOCALLY-NICKNAMED-BY-OTHERS")))
142      (ext:add-package-local-nickname :foo p2 p1)
143      (assert (ext:package-local-nicknames p1))
144      (delete-package p2)
145      (assert (null (ext:package-local-nicknames p1)))
146      :success)
147  :success)
148
149(deftest pln-own-name-as-local-nickname
150    (with-tmp-packages ((p1 (make-package "OWN-NAME-AS-NICKNAME1"))
151                        (p2 (make-package "OWN-NAME-AS-NICKNAME2")))
152      (assert (eq :oops
153                  (handler-case
154                      (ext:add-package-local-nickname :own-name-as-nickname1 p2 p1)
155                    (error ()
156                      :oops))))
157      (handler-bind ((error #'continue))
158        (ext:add-package-local-nickname :own-name-as-nickname1 p2 p1))
159      (assert (eq (intern "FOO" p2)
160                  (let ((*package* p1))
161                    (intern "FOO" :own-name-as-nickname1))))
162      :success)
163  :success)
164
165
166
167(deftest pln-own-nickname-as-local-nickname
168    (with-tmp-packages ((p1 (make-package "OWN-NICKNAME-AS-NICKNAME1"
169                                          :nicknames '("OWN-NICKNAME")))
170                        (p2 (make-package "OWN-NICKNAME-AS-NICKNAME2")))
171      (assert (eq :oops
172                  (handler-case
173                      (ext:add-package-local-nickname :own-nickname p2 p1)
174                    (error ()
175                      :oops))))
176      (handler-bind ((error #'continue))
177        (ext:add-package-local-nickname :own-nickname p2 p1))
178      (assert (eq (intern "FOO" p2)
179                  (let ((*package* p1))
180                    (intern "FOO" :own-nickname))))
181      :success)
182  :success)
Note: See TracBrowser for help on using the repository browser.