source: trunk/source/tests/ansi-tests/intern.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 12 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 4.8 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sat Apr 25 07:59:10 1998
4;;;; Contains: Tests of INTERN
5
6(in-package :cl-test)
7(declaim (optimize (safety 3)))
8
9;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
10;;; intern
11
12(deftest intern.1
13  (progn
14    (safely-delete-package "TEMP1")
15    (let ((p (make-package "TEMP1" :use nil))
16          (i 0) x y)
17      (multiple-value-bind* (sym1 status1)
18          (find-symbol "FOO" p)
19        (intern (progn (setf x (incf i)) "FOO")
20                (progn (setf y (incf i)) p))
21        (multiple-value-bind* (sym2 status2)
22            (find-symbol "FOO" p)
23          (and (eql i 2)
24               (eql x 1)
25               (eql y 2)
26               (null sym1)
27               (null status1)
28               (string= (symbol-name sym2) "FOO")
29               (eqt (symbol-package sym2) p)
30               (eqt status2 :internal)
31               (progn (delete-package p) t))))))
32  t)
33
34(deftest intern.2
35  (progn
36    (safely-delete-package "TEMP1")
37    (let ((p (make-package "TEMP1" :use nil)))
38      (multiple-value-bind* (sym1 status1)
39          (find-symbol "FOO" "TEMP1")
40        (intern "FOO" "TEMP1")
41        (multiple-value-bind* (sym2 status2)
42            (find-symbol "FOO" p)
43          (and (null sym1)
44               (null status1)
45               (string= (symbol-name sym2) "FOO")
46               (eqt (symbol-package sym2) p)
47               (eqt status2 :internal)
48               (progn (delete-package p) t))))))
49  t)
50
51(deftest intern.3
52  :notes (:nil-vectors-are-strings)
53  (let ((cl-user-package (find-package "CL-USER")))
54    (eqt (intern "" cl-user-package)
55         (intern (make-array 0 :element-type nil) cl-user-package)))
56  t)
57
58(deftest intern.4
59  (let ((cl-user-package (find-package "CL-USER")))
60    (eqt (intern (make-array 5 :element-type 'character
61                             :initial-contents "XYZZY") cl-user-package)
62         (intern (make-array 5 :element-type 'base-char
63                             :initial-contents "XYZZY") cl-user-package)))
64  t)
65
66;;; String is a specialized sequence type
67
68(defmacro def-intern-test (test-name &key (symbol-name "FOO")
69                                     (package-name "TEMP1"))
70  `(deftest ,test-name
71     (let ((sname ,symbol-name)
72           (pname ,package-name))
73       (safely-delete-package pname)
74       (let ((p (make-package pname :use nil)))
75         (multiple-value-bind*
76          (sym1 status1)
77          (find-symbol sname pname)
78          (intern sname pname)
79          (multiple-value-bind*
80           (sym2 status2)
81           (find-symbol sname p)
82           (and (null sym1)
83                (null status1)
84                (string= (symbol-name sym2) sname)
85                (eqt (symbol-package sym2) p)
86                (eqt status2 :internal)
87                (progn (delete-package p) t))))))
88     t))
89
90(def-intern-test intern.5
91  :symbol-name (make-array 3 :element-type 'base-char
92                           :initial-contents "BAR"))
93
94(def-intern-test intern.6
95  :symbol-name (make-array 13 :element-type 'base-char
96                           :fill-pointer 3
97                           :initial-contents "BAR1234567890"))
98
99(def-intern-test intern.7
100  :symbol-name (make-array 13 :element-type 'character
101                           :fill-pointer 3
102                           :initial-contents "BAR1234567890"))
103
104(def-intern-test intern.8
105  :symbol-name (make-array 3 :element-type 'base-char
106                           :adjustable t
107                           :initial-contents "BAR"))
108
109(def-intern-test intern.9
110  :symbol-name (make-array 3 :element-type 'character
111                           :adjustable t
112                           :initial-contents "BAR"))
113
114(def-intern-test intern.10
115  :symbol-name
116  (let* ((etype 'base-char)
117         (name0 (make-array 8 :element-type etype
118                            :initial-contents "XBARYYYY")))
119    (make-array 3 :element-type etype :displaced-to name0
120                :displaced-index-offset 1)))
121
122(def-intern-test intern.11
123  :symbol-name
124  (let* ((etype 'character)
125         (name0 (make-array 8 :element-type etype
126                            :initial-contents "XBARYYYY")))
127    (make-array 3 :element-type etype :displaced-to name0
128                :displaced-index-offset 1)))
129
130(def-intern-test intern.12
131  :package-name (make-array 3 :element-type 'base-char
132                           :initial-contents "BAR"))
133
134(def-intern-test intern.13
135  :package-name (make-array 13 :element-type 'base-char
136                           :fill-pointer 3
137                           :initial-contents "BAR1234567890"))
138
139(def-intern-test intern.14
140  :package-name (make-array 13 :element-type 'character
141                           :fill-pointer 3
142                           :initial-contents "BAR1234567890"))
143
144(def-intern-test intern.15
145  :package-name (make-array 3 :element-type 'base-char
146                           :adjustable t
147                           :initial-contents "BAR"))
148
149(def-intern-test intern.16
150  :package-name (make-array 3 :element-type 'character
151                           :adjustable t
152                           :initial-contents "BAR"))
153
154(def-intern-test intern.17
155  :package-name
156  (let* ((etype 'base-char)
157         (name0 (make-array 8 :element-type etype
158                            :initial-contents "XBARYYYY")))
159    (make-array 3 :element-type etype :displaced-to name0
160                :displaced-index-offset 1)))
161
162(def-intern-test intern.18
163  :package-name
164  (let* ((etype 'character)
165         (name0 (make-array 8 :element-type etype
166                            :initial-contents "XBARYYYY")))
167    (make-array 3 :element-type etype :displaced-to name0
168                :displaced-index-offset 1)))
169
170;;; Error tests
171
172(deftest intern.error.1
173  (signals-error (intern) program-error)
174  t)
175
176(deftest intern.error.2
177  (signals-error (intern "X" "CL" nil) program-error)
178  t)
Note: See TracBrowser for help on using the repository browser.