source: trunk/source/tests/ansi-tests/set-syntax-from-char.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: 13.6 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sat Jan 29 06:37:18 2005
4;;;; Contains: Tests of SET-SYNTAX-FROM-CHAR
5
6(in-package :cl-test)
7
8(compile-and-load "reader-aux.lsp")
9
10(defmacro def-set-syntax-from-char-test (name form &body expected-values)
11  `(deftest ,name
12     (with-standard-io-syntax
13      (let ((*readtable* (copy-readtable nil)))
14        (setf (readtable-case *readtable*) :preserve)
15        ,form))
16     ,@expected-values))
17
18;;; Test that constituent traits are not altered when a constituent character
19;;; syntax type is set
20
21(defmacro def-set-syntax-from-char-trait-test (c test-form expected-value)
22  (setq c (typecase c
23            (character c)
24            ((or string symbol) (name-char (string c)))
25            (t nil)))
26  (when c
27    ;; (format t "~A ~A~%" c (char-name c))
28    `(def-set-syntax-from-char-test
29       ,(intern (concatenate 'string "SET-SYNTAX-FROM-CHAR-TRAIT-X-" (or (char-name c)
30                                                                         (string c)))
31                :cl-test)
32       (let ((c ,c))
33         (values
34          (set-syntax-from-char c #\X)
35          ,test-form))
36       t ,expected-value)))
37
38(defmacro def-set-syntax-from-char-alphabetic-trait-test (c)
39  `(def-set-syntax-from-char-trait-test ,c
40     (let* ((*package* (find-package "CL-TEST"))
41            (sym (read-from-string (string c))))
42       (list (let ((sym2 (find-symbol (string c))))
43               (or (eqt sym sym2)
44                   (list sym sym2)))
45             (or (equalt (symbol-name sym) (string c))
46                 (list (symbol-name sym) (string c)))))
47     (t t)))
48
49(loop for c across "\\|!\"#$%&'()*,;<=>?@[]^_`~{}+-/abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
50      do (eval `(def-set-syntax-from-char-alphabetic-trait-test ,c)))
51
52;;; The invalid constituent character trait of invalid and whitespace characters
53;;; is exposed when they are turned into constituent characters
54
55(defmacro def-set-syntax-from-char-invalid-trait-test (c)
56  `(def-set-syntax-from-char-trait-test ,c
57     (handler-case
58      (let* ((*package* (find-package "CL-TEST"))
59             (sym (read-from-string (concatenate 'string (string c) "Z"))))
60        sym)
61      (reader-error (c) (declare (ignore c)) :good))
62     :good))
63
64(loop for name in '("Backspace" "Tab" "Newline" "Linefeed" "Page" "Return" "Space" "Rubout")
65      do (eval `(def-set-syntax-from-char-invalid-trait-test ,name)))
66
67;;; Turning characters into single escape characters
68
69(deftest set-syntax-from-char.single-escape.1
70  (loop for c across +standard-chars+
71        nconc
72        (with-standard-io-syntax
73         (let ((*readtable* (copy-readtable nil))
74               (*package* (find-package "CL-TEST")))
75           (let ((results
76                  (list
77                   (set-syntax-from-char c #\\)
78                   (read-from-string (concatenate 'string (list c #\Z))))))
79             (unless (equal results '(t |Z|))
80               (list (list c results)))))))
81  nil)
82
83(deftest set-syntax-from-char.single-escape.2
84  (loop for c across +standard-chars+
85        unless (eql c #\")
86        nconc
87        (with-standard-io-syntax
88         (let ((*readtable* (copy-readtable nil))
89               (*package* (find-package "CL-TEST")))
90           (let ((results
91                  (list
92                   (set-syntax-from-char c #\\)
93                   (read-from-string (concatenate 'string
94                                                  (list #\" c #\" #\"))))))
95             (unless (equal results '(t "\""))
96               (list (list c results)))))))
97  nil)
98
99
100(deftest set-syntax-from-char.multiple-escape
101  (loop for c across +standard-chars+
102        nconc
103        (with-standard-io-syntax
104         (let ((*readtable* (copy-readtable nil))
105               (*package* (find-package "CL-TEST")))
106           (let ((results
107                  (list
108                   (set-syntax-from-char c #\|)
109                   (handler-case
110                    (read-from-string (concatenate 'string (list c #\Z c)))
111                    (error (c) c))
112                   (handler-case
113                    (read-from-string (concatenate 'string (list c #\z #\|)))
114                    (error (c) c))
115                   (handler-case
116                    (read-from-string (concatenate 'string (list #\| #\Z c)))
117                    (error (c) c)))))
118             (unless (or (eql c #\Z) (eql c #\z) (equal results '(t |Z| |z| |Z|)))
119               (list (list c results)))))))
120  nil)
121
122(deftest set-syntax-from-char.semicolon
123  (loop for c across +standard-chars+
124        nconc
125        (with-standard-io-syntax
126         (let ((*readtable* (copy-readtable nil))
127               (*package* (find-package "CL-TEST"))
128               (expected (if (eql c #\0) '1 '0))
129               (c2 (if (eql c #\0) #\1 #\0)))
130           (let ((results
131                  (list
132                   (set-syntax-from-char c #\;)
133                   (handler-case
134                    (read-from-string (concatenate 'string (list c2 c #\2)))
135                    (error (c) c))
136                   (handler-case
137                    (read-from-string (concatenate 'string (list c2 c #\2 #\Newline #\3)))
138                    (error (c) c))
139                   (handler-case
140                    (read-from-string (concatenate 'string (list c #\2 #\Newline c2)))
141                    (error (c) c)))))
142             (unless (equal results (list t expected expected expected))
143               (list (list c results)))))))
144  nil)
145
146(deftest set-syntax-from-char.left-paren
147  (loop for c across +standard-chars+
148        unless (find c ")")
149        nconc
150        (with-standard-io-syntax
151         (let ((*readtable* (copy-readtable nil))
152               (*package* (find-package "CL-TEST"))
153               (expected (if (eql c #\0) '(1) '(0)))
154               (c2 (if (eql c #\0) #\1 #\0)))
155           (let ((results
156                  (list
157                   (set-syntax-from-char c #\()
158                   (handler-case
159                    (read-from-string (concatenate 'string (list c) ")"))
160                    (error (c) c))
161                   (handler-case
162                    (read-from-string (concatenate 'string (list c c2) ")2" (list #\Newline #\3)))
163                    (error (c) c))
164                   (handler-case
165                    (read-from-string (concatenate 'string (list c c2) ")"))
166                    (error (c) c)))))
167             (unless (equal results (list t nil expected expected))
168               (list (list c results)))))))
169  nil)
170
171(deftest set-syntax-from-char.right-paren
172  (loop for c across +standard-chars+
173        nconc
174        (with-standard-io-syntax
175         (let ((*readtable* (copy-readtable nil))
176               (*package* (find-package "CL-TEST")))
177           (let ((results
178                  (list
179                   (set-syntax-from-char c #\))
180                   (handler-case
181                    (read-from-string (string c) nil nil)
182                    (reader-error (c) :good)
183                    (error (c) c)))))
184             (unless (equal results '(t :good))
185               (list (list c results)))))))
186  nil)
187
188(deftest set-syntax-from-char.single-quote
189  (loop for c across +standard-chars+
190        nconc
191        (with-standard-io-syntax
192         (let ((*readtable* (copy-readtable nil))
193               (*package* (find-package "CL-TEST"))
194               (expected (if (eql c #\0) ''1 ''0))
195               (c2 (if (eql c #\0) #\1 #\0)))
196           (let ((results
197                  (list
198                   (set-syntax-from-char c #\')
199                   (handler-case
200                    (read-from-string (concatenate 'string (list c c2)))
201                    (error (c) c))
202                   (handler-case
203                    (read-from-string (concatenate 'string (list c c2) " 2"))
204                    (error (c) c))
205                   (handler-case
206                    (read-from-string (concatenate 'string (list c c2) ")"))
207                    (error (c) c)))))
208             (unless (equal results (list t expected expected expected))
209               (list (list c results)))))))
210  nil)
211
212;;; I do not test that setting syntax from #\" allows the character to be
213;;; used as the terminator of a double quoted string.  It is not clear that
214;;; the standard implies this.
215
216(deftest set-syntax-from-char.double-quote
217  (loop for c across +standard-chars+
218        nconc
219        (with-standard-io-syntax
220         (let ((*readtable* (copy-readtable nil))
221               (*package* (find-package "CL-TEST"))
222               (expected (if (eql c #\0) "1" "0"))
223               (c2 (if (eql c #\0) #\1 #\0)))
224           (let ((results
225                  (list
226                   (set-syntax-from-char c #\")
227                   (handler-case
228                    (read-from-string
229                     (concatenate 'string (list c c2 c)))
230                    (error (c) c))
231                   (handler-case
232                    (read-from-string
233                     (concatenate 'string (list c c2 c #\2)))
234                    (error (c) c))
235                   (handler-case
236                    (read-from-string (concatenate 'string (list c c2 c) ")"))
237                    (error (c) c)))))
238             (unless (equal results (list t expected expected expected))
239               (list (list c results)))))))
240  nil)
241
242(deftest set-syntax-from-char.backquote
243  (loop for c across +standard-chars+
244        unless (find c ",x")
245        nconc
246        (with-standard-io-syntax
247         (let* ((*readtable* (copy-readtable nil))
248                (*package* (find-package "CL-TEST"))
249                (c2 (if (eql c #\Space) #\Newline #\Space))
250                (results
251                 (list
252                  (set-syntax-from-char c #\`)
253                  (handler-case
254                   (eval `(let ((x 0))
255                            ,(read-from-string
256                              (concatenate 'string (list c #\, #\x)))))
257                   (error (c) c))
258                  (handler-case
259                   (eval `(let ((x 0))
260                            ,(read-from-string
261                              (concatenate 'string (list c #\, #\x c2)))))
262                   (error (c) c))
263                  (handler-case
264                   (eval `(let ((x 0))
265                            ,(read-from-string
266                              (concatenate 'string (list c c2 #\, #\x c2)))))
267                   (error (c) c)))))
268           (unless (equal results '(t 0 0 0))
269             (list (list c results))))))
270  nil)
271
272(deftest set-syntax-from-char.comma
273  (loop for c across +standard-chars+
274        unless (find c "`x")
275        nconc
276        (with-standard-io-syntax
277         (let* ((*readtable* (copy-readtable nil))
278                (*package* (find-package "CL-TEST"))
279                (c2 (if (eql c #\Space) #\Newline #\Space))
280                (results
281                 (list
282                  (set-syntax-from-char c #\,)
283                  (handler-case
284                   (read-from-string (string c))
285                   (reader-error (c) :good)
286                   (error (c) c))
287                  (handler-case
288                   (eval `(let ((x 0))
289                            ,(read-from-string
290                              (concatenate 'string "`" (list c) "x"))))
291                   (error (c) c)))))
292           (unless (equal results '(t :good 0))
293             (list (list c results))))))
294  nil)
295               
296;;; Tests of set-syntax-from-char on #\#
297
298(deftest set-syntax-from-char.sharp.1
299  (loop for c across +standard-chars+
300        nconc
301        (with-standard-io-syntax
302         (let* ((*readtable* (copy-readtable nil))
303                (*package* (find-package "CL-TEST"))
304                (results
305                 (list
306                  (set-syntax-from-char c #\#)
307                  (if (not (eql c #\Space))
308                      (handler-case
309                       (read-from-string
310                        (concatenate 'string (list c #\Space)))
311                       (reader-error () :good)
312                       (error (c) c))
313                    :good)
314                  (if (not (find c "'X"))
315                      (handler-case
316                       (read-from-string
317                        (concatenate 'string (list c) "'X"))
318                       (error (c) c))
319                    '#'|X|)
320                  (if (not (find c "(X)"))
321                      (handler-case
322                       (read-from-string
323                        (concatenate 'string (list c) "(X)"))
324                       (error (c) c))
325                    #(|X|))
326                  (if (not (find c ")"))
327                      (handler-case
328                       (read-from-string
329                        (concatenate 'string (list c) ")"))
330                       (reader-error (c) :good)
331                       (error (c) c))
332                    :good)
333                  (if (not (find c "*"))
334                      (handler-case
335                       (read-from-string
336                        (concatenate 'string (list c #\*)))
337                       (error (c) c))
338                    #*)
339                  (if (not (find c ":|"))
340                      (handler-case
341                       (let ((sym (read-from-string
342                                   (concatenate 'string (list c) ":||"))))
343                         (and (symbolp sym)
344                              (null (symbol-package sym))
345                              (symbol-name sym)))
346                       (error (c) c))
347                    "")
348                  (handler-case
349                   (read-from-string
350                    (concatenate 'string (list c #\<)))
351                   (reader-error (c) :good)
352                   (error (c) c))
353                  (handler-case
354                   (read-from-string
355                    (concatenate 'string (list c #\\ #\X)))
356                   (error (c) c))
357                  (if (not (find c "1"))
358                      (handler-case
359                       (read-from-string
360                        (concatenate 'string (list c) "|1111|#1"))
361                       (error (c) c))
362                    1)
363                  (if (not (find c "1"))
364                      (handler-case
365                       (read-from-string
366                        (concatenate 'string (list c) "|11#|111|#11|#1"))
367                       (error (c) c))
368                    1)
369                  )))
370           (unless (equalp results '(t :good #'|X| #(|X|) :good #* "" :good #\X 1 1))
371             (list (list c results))))))
372  nil)
373
374(deftest set-syntax-from-char.sharp.2
375  (loop for c across +standard-chars+
376        nconc
377        (with-standard-io-syntax
378         (let* ((*readtable* (copy-readtable nil))
379                (*package* (find-package "CL-TEST"))
380                (results
381                 (list
382                  (set-syntax-from-char c #\#)
383                  (if (not (find c "+XC "))
384                      (handler-case
385                       (let ((*features* (cons ':X *features*)))
386                         (read-from-string
387                          (concatenate 'string (list c) "+X C")))
388                       (error (c) c))
389                    'c)
390                  (if (not (find c "-(OR)"))
391                      (handler-case
392                       (read-from-string
393                        (concatenate 'string (list c) "-(OR)R"))
394                       (error (c) c))
395                    'r)
396                  (if (not (find c ".1"))
397                      (handler-case
398                       (read-from-string
399                        (concatenate 'string (list c) ".1"))
400                       (error (c) c))
401                    1)
402                  (if (not (find c "01aA"))
403                      (handler-case
404                       (list
405                        (read-from-string
406                         (concatenate 'string (list c) "0a1"))
407                        (read-from-string
408                         (concatenate 'string (list c) "0A1")))
409                       (error (c) c))
410                    '(#0a1 #0a1))
411                  (if (not (find c "01bB"))
412                      (handler-case
413                       (list
414                        (read-from-string
415                         (concatenate 'string (list c) "b101"))
416                        (read-from-string
417                         (concatenate 'string (list c) "B011")))
418                       (error (c) c))
419                    '(5 3))
420                  (if (not (find c "cC()12 "))
421                      (handler-case
422                       (list
423                        (read-from-string
424                         (concatenate 'string (list c) "c(1 2)"))
425                        (read-from-string
426                         (concatenate 'string (list c) "C(2 1)")))
427                       (error (c) c))
428                    '(#c(1 2) #c(2 1)))
429                  (if (not (find c "oO0127"))
430                      (handler-case
431                       (list
432                        (read-from-string
433                         (concatenate 'string (list c) "o172"))
434                        (read-from-string
435                         (concatenate 'string (list c) "O7721")))
436                       (error (c) c))
437                    '(#o172 #o7721))
438                  (if (not (find c "pP\""))
439                      (handler-case
440                       (list
441                        (read-from-string
442                         (concatenate 'string (list c) "p\"\""))
443                        (read-from-string
444                         (concatenate 'string (list c) "P\"\"")))
445                       (error (c) c))
446                    '(#p"" #p""))
447                  (if (not (find c "rR0123"))
448                      (handler-case
449                       (list
450                        (read-from-string
451                         (concatenate 'string (list c) "3r210"))
452                        (read-from-string
453                         (concatenate 'string (list c) "3R1111")))
454                       (error (c) c))
455                    '(#3r210 #3r1111))
456                  ;;; Add #s test here
457                  (if (not (find c "xX04dF"))
458                      (handler-case
459                       (list
460                        (read-from-string
461                         (concatenate 'string (list c) "x40Fd"))
462                        (read-from-string
463                         (concatenate 'string (list c) "XFd04")))
464                       (error (c) c))
465                    '(#x40fd #xfd04))
466                  )))
467           (unless (equalp results
468                           '(t c r 1 (#0a1 #0a1) (5 3) (#c(1 2) #c(2 1))
469                               (#o172 #o7721) (#p"" #p"") (#3r210 #3r1111)
470                               (#x40fd #xfd04)))
471             (list (list c results)))
472           )))
473  nil)
Note: See TracBrowser for help on using the repository browser.