source: trunk/source/tests/ansi-tests/reader-test.lsp @ 8991

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

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

File size: 7.9 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Wed Apr  8 20:03:45 1998
4;;;; Contains: Tests on readtables (just started, very incomplete)
5
6(in-package :cl-test)
7
8(compile-and-load "reader-aux.lsp")
9
10(def-syntax-test read-symbol.1
11  (read-from-string "a")
12  a 1)
13
14(def-syntax-test read-symbol.2
15  (read-from-string "|a|")
16  |a| 3)
17
18(def-syntax-test read-symbol.3
19  (multiple-value-bind (s n)
20      (read-from-string "#:abc")
21    (not
22     (and (symbolp s)
23          (eql n 5)
24          (not (symbol-package s))
25          (string-equal (symbol-name s) "abc"))))
26  nil)
27
28(def-syntax-test read-symbol.4
29  (multiple-value-bind (s n)
30      (read-from-string "#:|abc|")
31    (not
32     (and (symbolp s)
33          (eql n 7)
34          (not (symbol-package s))
35          (string= (symbol-name s) "abc"))))
36  nil)
37
38(def-syntax-test read-symbol.5
39  (multiple-value-bind (s n)
40      (read-from-string "#:||")
41    (if (not (symbolp s))
42        s
43      (not (not
44            (and (eql n 4)
45                 (not (symbol-package s))
46                 (string= (symbol-name s) ""))))))
47  t)
48
49(def-syntax-test read-symbol.6
50  (let ((str "cl-test::abcd0123"))
51    (multiple-value-bind (s n)
52        (read-from-string str)
53      (if (not (symbolp s))
54          s
55        (not (not
56              (and (eql n (length str))
57                   (eqt (symbol-package s) (find-package :cl-test))
58                   (string-equal (symbol-name s)
59                                 "abcd0123")))))))
60  t)
61
62(def-syntax-test read-symbol.7
63  (multiple-value-bind (s n)
64      (read-from-string ":ABCD")
65    (if (not (symbolp s))
66        s
67      (not (not
68            (and (eql n 5)
69                 (eqt (symbol-package s) (find-package "KEYWORD"))
70                 (string-equal (symbol-name s)
71                               "ABCD"))))))
72  t)
73             
74(defun read-symbol.9-body (natoms maxlen &optional (chars +standard-chars+))
75  (loop
76   repeat natoms
77   count
78   (let* ((len (random (1+ maxlen)))
79          (actual-len 0)
80          (s (make-string (+ 2 (* 2 len))))
81          (s2 (make-string len)))
82     (loop for j from 0 to (1- len) do
83           (let ((c (random-from-seq chars)))
84             (when (member c '(#\| #\\))
85               (setf (elt s actual-len) #\\)
86               (incf actual-len))
87             (setf (elt s actual-len) c)
88             (setf (elt s2 j) c)
89             (incf actual-len)))
90     (let ((actual-string (subseq s 0 actual-len)))
91       (multiple-value-bind (sym nread)
92           (read-from-string
93            (concatenate 'string "#:|" actual-string "|"))
94         (unless (and (symbolp sym)
95                      (eql nread (+ 4 actual-len))
96                      (string-equal s2 (symbol-name sym)))
97           (let ((*print-readably* t))
98             (format t "Symbol read failed: ~S (~S) read as ~S~%"
99                     actual-string s2 sym))
100           t))))))
101
102(def-syntax-test read-symbol.9
103  (read-symbol.9-body 1000 100)
104  0)
105
106(def-syntax-test read-symbol.9a
107  (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)
115
116(def-syntax-test read-symbol.9b
117  (let ((chars (coerce (loop for i below (min 65536 char-code-limit)
118                             for c = (code-char i)
119                             when c collect c)
120                       'string)))
121    (if (> (length chars) 0)
122        (read-symbol.9-body 1000 100)
123      0))
124  0)
125
126(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)
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
285  (eqlt -0.0 (- 0.0))
286  t)
Note: See TracBrowser for help on using the repository browser.