source: trunk/tests/ansi-tests/set-syntax-from-char.lsp @ 9045

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

Assorted cleanup:

In infrastructure:

  • add *test-verbose* and :verbose argument to do-test and do-tests. Avoid random output if false, only show failures
  • muffle-wawrnings and/or bind *suppress-compiler-warnings* in some tests that unavoidably generate them (mainly with duplicate typecase/case clauses)
  • Add record-source-file for tests so meta-. can find them
  • If *catch-errors* (or the :catch-errors arg) is :break, enter a breakloop when catch an error
  • Make test fns created by *compile-tests* have names, so can find them in backtraces
  • fix misc compiler warnings
  • Fixed cases of duplicate test numbers
  • Disable note :make-condition-with-compound-name for openmcl.

In tests themselves:

I commented out the following tests with #+bogus-test, because they just seemed wrong to me:

lambda.47
lambda.50
upgraded-array-element-type.8
upgraded-array-element-type.nil.1
pathname-match-p.5
load.17
load.18
macrolet.47
ctypecase.15

In addition, I commented out the following tests with #+bogus-test because I was too lazy to make a note
for "doesn't signal underflow":

exp.error.8 exp.error.9 exp.error.10 exp.error.11 expt.error.8 expt.error.9 expt.error.10 expt.error.11

Finally, I entered bug reports in trac, and then commented out the tests
below with #+known-bug-NNN, where nnn is the ticket number in trac:

ticket#268: encode-universal-time.3 encode-universal-time.3.1
ticket#269: macrolet.36
ticket#270: values.20 values.21
ticket#271: defclass.error.13 defclass.error.22
ticket#272: phase.10 phase.12 asin.5 asin.6 asin.8
ticket#273: phase.18 phase.19 acos.8
ticket#274: exp.error.4 exp.error.5 exp.error.6 exp.error.7
ticket#275: car.error.2 cdr.error.2
ticket#276: map.error.11
ticket#277: subtypep.cons.43
ticket#278: subtypep-function.3
ticket#279: subtypep-complex.8
ticket#280: open.output.19 open.io.19 file-position.8 file-length.4 file-length.5 read-byte.4 stream-element-type.2 stream-element-type.3
ticket#281: open.65
ticket#288: set-syntax-from-char.sharp.1

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