/[gcl]/gcl/ansi-tests/intern.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/intern.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by pfdietz, Sun Feb 22 13:33:58 2004 UTC revision 1.2 by pfdietz, Sun Aug 29 22:03:24 2004 UTC
# Line 12  Line 12 
12  (deftest intern.1  (deftest intern.1
13    (progn    (progn
14      (safely-delete-package "TEMP1")      (safely-delete-package "TEMP1")
15      (let ((p (make-package "TEMP1"))      (let ((p (make-package "TEMP1" :use nil))
16            (i 0) x y)            (i 0) x y)
17        (multiple-value-bind* (sym1 status1)        (multiple-value-bind* (sym1 status1)
18            (find-symbol "FOO" p)            (find-symbol "FOO" p)
# Line 34  Line 34 
34  (deftest intern.2  (deftest intern.2
35    (progn    (progn
36      (safely-delete-package "TEMP1")      (safely-delete-package "TEMP1")
37      (let ((p (make-package "TEMP1")))      (let ((p (make-package "TEMP1" :use nil)))
38        (multiple-value-bind* (sym1 status1)        (multiple-value-bind* (sym1 status1)
39            (find-symbol "FOO" "TEMP1")            (find-symbol "FOO" "TEMP1")
40          (intern "FOO" "TEMP1")          (intern "FOO" "TEMP1")
# Line 63  Line 63 
63                               :initial-contents "XYZZY") cl-user-package)))                               :initial-contents "XYZZY") cl-user-package)))
64    t)    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  (deftest intern.error.1
173    (signals-error (intern) program-error)    (signals-error (intern) program-error)
174    t)    t)

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26