/[gcl]/gcl/ansi-tests/reader-test.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/reader-test.lsp

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

revision 1.9 by pfdietz, Tue Jan 4 15:29:02 2005 UTC revision 1.10 by pfdietz, Mon Jan 17 13:50:18 2005 UTC
# Line 5  Line 5 
5    
6  (in-package :cl-test)  (in-package :cl-test)
7    
8  (deftest read-symbol.1  (compile-and-load "reader-aux.lsp")
9      (let ((*package* (find-package "CL-TEST")))  
10        (ignore-errors (read-from-string "a")))  (def-syntax-test read-symbol.1
11      (read-from-string "a")
12    a 1)    a 1)
13    
14  (deftest read-symbol.2  (def-syntax-test read-symbol.2
15      (let ((*package* (find-package "CL-TEST")))    (read-from-string "|a|")
       (ignore-errors (read-from-string "|a|")))  
16    |a| 3)    |a| 3)
17    
18  (deftest read-symbol.3  (def-syntax-test read-symbol.3
19    (multiple-value-bind (s n)    (multiple-value-bind (s n)
20        (let () (ignore-errors (read-from-string "#:abc")))        (read-from-string "#:abc")
21      (not      (not
22       (and (symbolp s)       (and (symbolp s)
23            (eql n 5)            (eql n 5)
# Line 25  Line 25 
25            (string-equal (symbol-name s) "abc"))))            (string-equal (symbol-name s) "abc"))))
26    nil)    nil)
27    
28  (deftest read-symbol.4  (def-syntax-test read-symbol.4
29    (multiple-value-bind (s n)    (multiple-value-bind (s n)
30        (let () (ignore-errors (read-from-string "#:|abc|")))        (read-from-string "#:|abc|")
31      (not      (not
32       (and (symbolp s)       (and (symbolp s)
33            (eql n 7)            (eql n 7)
# Line 35  Line 35 
35            (string= (symbol-name s) "abc"))))            (string= (symbol-name s) "abc"))))
36    nil)    nil)
37    
38  (deftest read-symbol.5  (def-syntax-test read-symbol.5
39    (multiple-value-bind (s n)    (multiple-value-bind (s n)
40        (let () (ignore-errors (read-from-string "#:||")))        (read-from-string "#:||")
41      (if (not (symbolp s))      (if (not (symbolp s))
42          s          s
43        (not (not        (not (not
# Line 46  Line 46 
46                   (string= (symbol-name s) ""))))))                   (string= (symbol-name s) ""))))))
47    t)    t)
48    
49  (deftest read-symbol.6  (def-syntax-test read-symbol.6
50    (let ((str "cl-test::abcd0123"))    (let ((str "cl-test::abcd0123"))
51      (multiple-value-bind (s n)      (multiple-value-bind (s n)
52          (ignore-errors (read-from-string str))          (read-from-string str)
53        (if (not (symbolp s))        (if (not (symbolp s))
54            s            s
55          (not (not          (not (not
# Line 59  Line 59 
59                                   "abcd0123")))))))                                   "abcd0123")))))))
60    t)    t)
61    
62  (deftest read-symbol.7  (def-syntax-test read-symbol.7
63    (multiple-value-bind (s n)    (multiple-value-bind (s n)
64        (let () (ignore-errors (read-from-string ":ABCD")))        (read-from-string ":ABCD")
65      (if (not (symbolp s))      (if (not (symbolp s))
66          s          s
67        (not (not        (not (not
# Line 71  Line 71 
71                                 "ABCD"))))))                                 "ABCD"))))))
72    t)    t)
73                            
74  (defun read-symbol.9-body (natoms maxlen)  (defun read-symbol.9-body (natoms maxlen &optional (chars +standard-chars+))
75    (let* ((chars (concatenate 'string    (loop
76                    "abcdefghijklmnopqrstuvwxyz"     repeat natoms
77                    "ABCDEFGHIJKLMNOPQRSTUVWXYZ"     count
78                    "0123456789"     (let* ((len (random (1+ maxlen)))
79                    "<,>.?/\"':;[{]}~`!@#$%^&*()_-+= \\|"))            (actual-len 0)
80           (nchars (length chars)))            (s (make-string (+ 2 (* 2 len))))
81      (loop            (s2 (make-string len)))
82          for i from 1 to natoms       (loop for j from 0 to (1- len) do
83          count             (let ((c (random-from-seq chars)))
84            (let* ((len (random (1+ maxlen)))               (when (member c '(#\| #\\))
85                   (actual-len 0)                 (setf (elt s actual-len) #\\)
86                   (s (make-string (+ 2 (* 2 len))))                 (incf actual-len))
87                   (s2 (make-string len)))               (setf (elt s actual-len) c)
88              (loop for j from 0 to (1- len) do               (setf (elt s2 j) c)
89                    (let ((c (elt chars (random (max 1 (1- nchars))))))               (incf actual-len)))
90                      (when (member c '(#\| #\\))       (let ((actual-string (subseq s 0 actual-len)))
91                        (setf (elt s actual-len) #\\)         (multiple-value-bind (sym nread)
92                        (incf actual-len))             (read-from-string
93                      (setf (elt s actual-len) c)              (concatenate 'string "#:|" actual-string "|"))
94                      (setf (elt s2 j) c)           (unless (and (symbolp sym)
95                      (incf actual-len)))                        (eql nread (+ 4 actual-len))
96              (let ((actual-string (subseq s 0 actual-len)))                        (string-equal s2 (symbol-name sym)))
97                (multiple-value-bind (sym nread)             (let ((*print-readably* t))
98                    (ignore-errors (read-from-string               (format t "Symbol read failed: ~S (~S) read as ~S~%"
99                          (concatenate 'string                       actual-string s2 sym))
100                            "#:|" actual-string "|")))             t))))))
101                  (unless (and (symbolp sym)  
102                               (eql nread (+ 4 actual-len))  (def-syntax-test read-symbol.9
103                               (string-equal s2 (symbol-name sym)))    (read-symbol.9-body 1000 100)
104                    (let ((*print-readably* t))    0)
                     (format t "Symbol read failed: ~S (~S) read as ~S~%"  
                             actual-string s2 sym))  
                   t)))))))  
105    
106  (deftest read-symbol.9  (def-syntax-test read-symbol.9a
107      (read-symbol.9-body 1000 100)    (let ((chars (coerce (loop for i below (min 256 char-code-limit)
108                                 for c = (code-char i)
109                                 when c collect c)
110                           'string)))
111        (if (> (length chars) 0)
112            (read-symbol.9-body 1000 100)
113          0))
114    0)    0)
115    
116  (deftest read-symbol.10  (def-syntax-test read-symbol.9b
117    (handler-case    (let ((chars (coerce (loop for i below (min 65536 char-code-limit)
118     (not (not                               for c = (code-char i)
119           (equal (symbol-name                               when c collect c)
120                   (read-from-string                         'string)))
121                    (with-output-to-string (s)      (if (> (length chars) 0)
122                                           (write (make-symbol ":")          (read-symbol.9-body 1000 100)
123                                                  :readably t        0))
124                                                  :stream s))))    0)
125                  ":")))  
126     (error (c) c))  (def-syntax-test read-symbol.10
127      (equalt (symbol-name
128               (read-from-string
129                (with-output-to-string (s)
130                                       (write (make-symbol ":")
131                                              :readably t
132                                              :stream s))))
133              ":")
134    t)    t)
135    
136    (def-syntax-test read-symbol.11
137      (loop for c across +standard-chars+
138            for str = (make-array 2 :element-type 'character :initial-contents (list #\\ c))
139            for sym = (read-from-string str)
140            unless (and (symbolp sym)
141                        (eql sym (find-symbol (string c)))
142                        (equal (symbol-name sym) (string c)))
143            collect (list c str sym))
144      nil)
145    
146    (def-syntax-test read-symbol.12
147      (loop for c across +standard-chars+
148            for str = (make-array 2 :element-type 'base-char :initial-contents (list #\\ c))
149            for sym = (read-from-string str)
150            unless (and (symbolp sym)
151                        (eql sym (find-symbol (string c)))
152                        (equal (symbol-name sym) (string c)))
153            collect (list c str sym))
154      nil)
155    
156    (def-syntax-test read-symbol.13
157      (loop for i below (min 65536 char-code-limit)
158            for c = (code-char i)
159            for str = (and c (make-array 2 :element-type 'character :initial-contents (list #\\ c)))
160            for sym = (and c (read-from-string str))
161            unless (or (not c)
162                       (and (symbolp sym)
163                            (eql sym (find-symbol (string c)))
164                            (equal (symbol-name sym) (string c))))
165            collect (list c str sym))
166      nil)
167    
168    (def-syntax-test read-symbol.14
169      (loop for i = (random (min (ash 1 24) char-code-limit))
170            for c = (code-char i)
171            for str = (and c (make-array 2 :element-type 'character :initial-contents (list #\\ c)))
172            for sym = (and c (read-from-string str))
173            repeat 1000
174            unless (or (not c)
175                       (and (symbolp sym)
176                            (eql sym (find-symbol (string c)))
177                            (equal (symbol-name sym) (string c))))
178            collect (list c str sym))
179      nil)
180    
181    (def-syntax-test read-symbol.15
182      (loop for c across "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ!@$%^&*_-+={}[]<>?/~"
183            for str = (string c)
184            for sym = (read-from-string str)
185            unless (eql sym (find-symbol (string (char-upcase c))))
186            collect (list c str sym))
187      nil)
188    
189    (def-syntax-test read-symbol.16
190      (let ((*readtable* (copy-readtable)))
191        (setf (readtable-case *readtable*) :downcase)
192        (loop for c across "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ!@$%^&*_-+={}[]<>?/~"
193              for str = (string c)
194              for sym = (read-from-string str)
195              unless (eql sym (find-symbol (string (char-downcase c))))
196              collect (list c str sym)))
197      nil)
198    
199    (def-syntax-test read-symbol.17
200      (let ((*readtable* (copy-readtable)))
201        (setf (readtable-case *readtable*) :preserve)
202        (loop for c across "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ!@$%^&*_-+={}[]<>?/~"
203              for str = (string c)
204              for sym = (read-from-string str)
205              unless (eql sym (find-symbol str))
206              collect (list c str sym)))
207      nil)
208    
209    (def-syntax-test read-symbol.18
210      (let ((*readtable* (copy-readtable)))
211        (setf (readtable-case *readtable*) :invert)
212        (loop for c across "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ!@$%^&*_-+={}[]<>?/~"
213              for str = (string c)
214              for sym = (read-from-string str)
215              for c2 = (cond ((upper-case-p c) (char-downcase c))
216                             ((lower-case-p c) (char-upcase c))
217                             (t c))
218              unless (eql sym (find-symbol (string c2)))
219              collect (list c c2 str sym)))
220      nil)
221    
222    (def-syntax-test read-symbol.19
223      (read-from-string "123||")
224      |123| 5)
225    
226    (def-syntax-test read-symbol.20
227      (read-from-string "123\\4")
228      |1234| 5)
229    
230    (def-syntax-test read-symbol.21
231      (read-from-string "\\:1234")
232      |:1234| 6)
233    
234    (def-syntax-test read-symbol.22
235      (read-from-string "||")
236      #.(intern "" (find-package "CL-TEST")) 2)
237    
238    (def-syntax-test read-symbol.23
239      (loop for c across +standard-chars+
240            for s = (concatenate 'string (string c) ".")
241            for sym = (intern (string-upcase s))
242            when (alpha-char-p c)
243            nconc
244            (let ((sym2 (let ((*read-base* 36))
245                          (read-from-string s))))
246              (if (eq sym sym2)
247                  nil
248                (list c s sym sym2))))
249      nil)
250    
251    (def-syntax-test read-symbol.24
252      (loop for c1 = (random-from-seq +alpha-chars+)
253            for c2 = (random-from-seq +alpha-chars+)
254            for d1 = (loop repeat (random 4) collect (random-from-seq +digit-chars+))
255            for d2 = (loop repeat (random 4) collect (random-from-seq +digit-chars+))
256            for s = (concatenate 'string d1 (list c1 c2) d2)
257            for sym = (intern (string-upcase s))
258            repeat 1000
259            nconc
260            (let ((sym2 (read-from-string s)))
261              (if (eq sym sym2)
262                  nil
263                (list c1 c2 d1 d2 s sym sym2))))
264      nil)
265    
266    (def-syntax-test read-symbol.25
267      (let ((potential-chars "01234567890123456789+-esdlf_^/")
268            (*readtable* (copy-readtable)))
269        (setf (readtable-case *readtable*) :preserve)
270        (loop for d1 = (loop repeat (random 6)
271                             collect (random-from-seq potential-chars))
272              for c = (random-from-seq potential-chars)
273              for d2 = (loop repeat (random 6)
274                             collect (random-from-seq potential-chars))
275              for s1 = (concatenate 'string d1 (list c) d2)
276              for sym1 = (intern s1)
277              for s2 = (concatenate 'string d1 (list #\\ c) d2)
278              for sym2 = (read-from-string s2)
279              repeat 1000
280              unless (eql sym1 sym2)
281              collect (list d1 c d2 s1 sym1 s2 sym2)))
282      nil)
283    
284  (deftest read-float.1  (deftest read-float.1
285    (eqlt -0.0 (- 0.0))    (eqlt -0.0 (- 0.0))
286    t)    t)

Legend:
Removed from v.1.9  
changed lines
  Added in v.1.10

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