source: trunk/source/tests/ansi-tests/print-symbols.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: 21.5 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sat Mar  6 11:47:55 2004
4;;;; Contains: Tests of symbol printing
5
6(in-package :cl-test)
7
8(compile-and-load "printer-aux.lsp")
9
10;;; Symbol printing when escaping is off
11
12(defun princ.symbol.fn (sym case *print-case* expected)
13  (setf (readtable-case *readtable*) case)
14  (let ((str (with-output-to-string (s) (princ sym s))))
15    (or (equalt str expected)
16        (list str expected))))
17
18(defun prin1.symbol.fn (sym case *print-case* expected)
19  (setf (readtable-case *readtable*) case)
20  (let ((str (with-output-to-string (s) (prin1 sym s))))
21    (or (and (member str expected :test #'string=) t)
22        (list str expected))))
23
24(deftest print.symbol.1
25  (with-standard-io-syntax
26   (let ((*print-readably* nil)
27         (*readtable* (copy-readtable nil)))
28     (flet ((%p (&rest args) (apply #'princ.symbol.fn args)))
29       (values
30        (%p '|XYZ| :upcase :upcase "XYZ")
31        (%p '|XYZ| :upcase :downcase "xyz")
32        (%p '|XYZ| :upcase :capitalize "Xyz")
33        (%p '|XYZ| :downcase :upcase "XYZ")
34        (%p '|XYZ| :downcase :downcase "XYZ")
35        (%p '|XYZ| :downcase :capitalize "XYZ")
36        (%p '|XYZ| :preserve :upcase "XYZ")
37        (%p '|XYZ| :preserve :downcase "XYZ")
38        (%p '|XYZ| :preserve :capitalize "XYZ")
39        (%p '|XYZ| :invert :upcase "xyz")
40        (%p '|XYZ| :invert :downcase "xyz")
41        (%p '|XYZ| :invert :capitalize "xyz")))))
42  t t t t t t t t t t t t)
43
44(deftest print.symbol.2
45  (with-standard-io-syntax
46   (let ((*print-readably* nil)
47         (*readtable* (copy-readtable nil)))
48     (flet ((%p (&rest args) (apply #'princ.symbol.fn args)))
49       (values
50        (%p '|xyz| :upcase :upcase "xyz")
51        (%p '|xyz| :upcase :downcase "xyz")
52        (%p '|xyz| :upcase :capitalize "xyz")
53        (%p '|xyz| :downcase :upcase "XYZ")
54        (%p '|xyz| :downcase :downcase "xyz")
55        (%p '|xyz| :downcase :capitalize "Xyz")
56        (%p '|xyz| :preserve :upcase "xyz")
57        (%p '|xyz| :preserve :downcase "xyz")
58        (%p '|xyz| :preserve :capitalize "xyz")
59        (%p '|xyz| :invert :upcase "XYZ")
60        (%p '|xyz| :invert :downcase "XYZ")
61        (%p '|xyz| :invert :capitalize "XYZ")))))
62  t t t t t t t t t t t t)
63
64(deftest print.symbol.3
65  (with-standard-io-syntax
66   (let ((*print-readably* nil)
67         (*readtable* (copy-readtable nil)))
68     (flet ((%p (&rest args) (apply #'princ.symbol.fn args)))
69       (values
70        (%p '|Xyz| :upcase :upcase "Xyz")
71        (%p '|Xyz| :upcase :downcase "xyz")
72        (%p '|Xyz| :upcase :capitalize "Xyz")
73        (%p '|Xyz| :downcase :upcase "XYZ")
74        (%p '|Xyz| :downcase :downcase "Xyz")
75        (%p '|Xyz| :downcase :capitalize "Xyz")
76        (%p '|Xyz| :preserve :upcase "Xyz")
77        (%p '|Xyz| :preserve :downcase "Xyz")
78        (%p '|Xyz| :preserve :capitalize "Xyz")
79        (%p '|Xyz| :invert :upcase "Xyz")
80        (%p '|Xyz| :invert :downcase "Xyz")
81        (%p '|Xyz| :invert :capitalize "Xyz")))))
82  t t t t t t t t t t t t)
83
84(deftest print.symbol.4
85  (with-standard-io-syntax
86   (let ((*print-readably* nil)
87         (*readtable* (copy-readtable nil)))
88     (flet ((%p (&rest args) (apply #'princ.symbol.fn args)))
89       (values
90        (%p '|xYZ| :upcase :upcase "xYZ")
91        (%p '|xYZ| :upcase :downcase "xyz")
92        (%p '|xYZ| :upcase :capitalize "xyz")
93        (%p '|xYZ| :downcase :upcase "XYZ")
94        (%p '|xYZ| :downcase :downcase "xYZ")
95        (%p '|xYZ| :downcase :capitalize "XYZ")
96        (%p '|xYZ| :preserve :upcase "xYZ")
97        (%p '|xYZ| :preserve :downcase "xYZ")
98        (%p '|xYZ| :preserve :capitalize "xYZ")
99        (%p '|xYZ| :invert :upcase "xYZ")
100        (%p '|xYZ| :invert :downcase "xYZ")
101        (%p '|xYZ| :invert :capitalize "xYZ")))))
102  t t t t t t t t t t t t)
103
104(deftest print.symbol.5
105  (with-standard-io-syntax
106   (let ((*print-readably* nil)
107         (*readtable* (copy-readtable nil)))
108     (flet ((%p (&rest args) (apply #'princ.symbol.fn args)))
109       (values
110        (%p '|X1Z| :upcase :upcase "X1Z")
111        (%p '|X1Z| :upcase :downcase "x1z")
112        (%p '|X1Z| :upcase :capitalize "X1z")
113        (%p '|X1Z| :downcase :upcase "X1Z")
114        (%p '|X1Z| :downcase :downcase "X1Z")
115        (%p '|X1Z| :downcase :capitalize "X1Z")
116        (%p '|X1Z| :preserve :upcase "X1Z")
117        (%p '|X1Z| :preserve :downcase "X1Z")
118        (%p '|X1Z| :preserve :capitalize "X1Z")
119        (%p '|X1Z| :invert :upcase "x1z")
120        (%p '|X1Z| :invert :downcase "x1z")
121        (%p '|X1Z| :invert :capitalize "x1z")))))
122  t t t t t t t t t t t t)
123
124(deftest print.symbol.6
125  (with-standard-io-syntax
126   (let ((*print-readably* nil)
127         (*readtable* (copy-readtable nil)))
128     (flet ((%p (&rest args) (apply #'princ.symbol.fn args)))
129       (values
130        (%p '|x1z| :upcase :upcase "x1z")
131        (%p '|x1z| :upcase :downcase "x1z")
132        (%p '|x1z| :upcase :capitalize "x1z")
133        (%p '|x1z| :downcase :upcase "X1Z")
134        (%p '|x1z| :downcase :downcase "x1z")
135        (%p '|x1z| :downcase :capitalize "X1z")
136        (%p '|x1z| :preserve :upcase "x1z")
137        (%p '|x1z| :preserve :downcase "x1z")
138        (%p '|x1z| :preserve :capitalize "x1z")
139        (%p '|x1z| :invert :upcase "X1Z")
140        (%p '|x1z| :invert :downcase "X1Z")
141        (%p '|x1z| :invert :capitalize "X1Z")))))
142  t t t t t t t t t t t t)
143
144(deftest print.symbol.7
145  (with-standard-io-syntax
146   (let ((*print-readably* nil)
147         (*readtable* (copy-readtable nil)))
148     (flet ((%p (&rest args) (apply #'princ.symbol.fn args)))
149       (values
150        (%p '|X1z| :upcase :upcase "X1z")
151        (%p '|X1z| :upcase :downcase "x1z")
152        (%p '|X1z| :upcase :capitalize "X1z")
153        (%p '|X1z| :downcase :upcase "X1Z")
154        (%p '|X1z| :downcase :downcase "X1z")
155        (%p '|X1z| :downcase :capitalize "X1z")
156        (%p '|X1z| :preserve :upcase "X1z")
157        (%p '|X1z| :preserve :downcase "X1z")
158        (%p '|X1z| :preserve :capitalize "X1z")
159        (%p '|X1z| :invert :upcase "X1z")
160        (%p '|X1z| :invert :downcase "X1z")
161        (%p '|X1z| :invert :capitalize "X1z")))))
162  t t t t t t t t t t t t)
163
164(deftest print.symbol.8
165  (with-standard-io-syntax
166   (let ((*print-readably* nil)
167         (*readtable* (copy-readtable nil)))
168     (flet ((%p (&rest args) (apply #'princ.symbol.fn args)))
169       (values
170        (%p '|x1Z| :upcase :upcase "x1Z")
171        (%p '|x1Z| :upcase :downcase "x1z")
172        (%p '|x1Z| :upcase :capitalize "x1z")
173        (%p '|x1Z| :downcase :upcase "X1Z")
174        (%p '|x1Z| :downcase :downcase "x1Z")
175        (%p '|x1Z| :downcase :capitalize "X1Z")
176        (%p '|x1Z| :preserve :upcase "x1Z")
177        (%p '|x1Z| :preserve :downcase "x1Z")
178        (%p '|x1Z| :preserve :capitalize "x1Z")
179        (%p '|x1Z| :invert :upcase "x1Z")
180        (%p '|x1Z| :invert :downcase "x1Z")
181        (%p '|x1Z| :invert :capitalize "x1Z")))))
182  t t t t t t t t t t t t)
183
184(deftest print.symbol.9
185  (with-standard-io-syntax
186   (let ((*print-readably* nil)
187         (*readtable* (copy-readtable nil)))
188     (flet ((%p (&rest args) (apply #'princ.symbol.fn args)))
189       (values
190        (%p '|X Z| :upcase :upcase "X Z")
191        (%p '|X Z| :upcase :downcase "x z")
192        (%p '|X Z| :upcase :capitalize "X Z")
193        (%p '|X Z| :downcase :upcase "X Z")
194        (%p '|X Z| :downcase :downcase "X Z")
195        (%p '|X Z| :downcase :capitalize "X Z")
196        (%p '|X Z| :preserve :upcase "X Z")
197        (%p '|X Z| :preserve :downcase "X Z")
198        (%p '|X Z| :preserve :capitalize "X Z")
199        (%p '|X Z| :invert :upcase "x z")
200        (%p '|X Z| :invert :downcase "x z")
201        (%p '|X Z| :invert :capitalize "x z")))))
202  t t t t t t t t t t t t)
203
204(deftest print.symbol.10
205  (with-standard-io-syntax
206   (let ((*print-readably* nil)
207         (*readtable* (copy-readtable nil)))
208     (flet ((%p (&rest args) (apply #'princ.symbol.fn args)))
209       (values
210        (%p '|x z| :upcase :upcase "x z")
211        (%p '|x z| :upcase :downcase "x z")
212        (%p '|x z| :upcase :capitalize "x z")
213        (%p '|x z| :downcase :upcase "X Z")
214        (%p '|x z| :downcase :downcase "x z")
215        (%p '|x z| :downcase :capitalize "X Z")
216        (%p '|x z| :preserve :upcase "x z")
217        (%p '|x z| :preserve :downcase "x z")
218        (%p '|x z| :preserve :capitalize "x z")
219        (%p '|x z| :invert :upcase "X Z")
220        (%p '|x z| :invert :downcase "X Z")
221        (%p '|x z| :invert :capitalize "X Z")))))
222  t t t t t t t t t t t t)
223
224(deftest print.symbol.11
225  (with-standard-io-syntax
226   (let ((*print-readably* nil)
227         (*readtable* (copy-readtable nil)))
228     (flet ((%p (&rest args) (apply #'princ.symbol.fn args)))
229       (values
230        (%p '|X z| :upcase :upcase "X z")
231        (%p '|X z| :upcase :downcase "x z")
232        (%p '|X z| :upcase :capitalize "X z")
233        (%p '|X z| :downcase :upcase "X Z")
234        (%p '|X z| :downcase :downcase "X z")
235        (%p '|X z| :downcase :capitalize "X Z")
236        (%p '|X z| :preserve :upcase "X z")
237        (%p '|X z| :preserve :downcase "X z")
238        (%p '|X z| :preserve :capitalize "X z")
239        (%p '|X z| :invert :upcase "X z")
240        (%p '|X z| :invert :downcase "X z")
241        (%p '|X z| :invert :capitalize "X z")))))
242  t t t t t t t t t t t t)
243
244(deftest print.symbol.12
245  (with-standard-io-syntax
246   (let ((*print-readably* nil)
247         (*readtable* (copy-readtable nil)))
248     (flet ((%p (&rest args) (apply #'princ.symbol.fn args)))
249       (values
250        (%p '|x Z| :upcase :upcase "x Z")
251        (%p '|x Z| :upcase :downcase "x z")
252        (%p '|x Z| :upcase :capitalize "x Z")
253        (%p '|x Z| :downcase :upcase "X Z")
254        (%p '|x Z| :downcase :downcase "x Z")
255        (%p '|x Z| :downcase :capitalize "X Z")
256        (%p '|x Z| :preserve :upcase "x Z")
257        (%p '|x Z| :preserve :downcase "x Z")
258        (%p '|x Z| :preserve :capitalize "x Z")
259        (%p '|x Z| :invert :upcase "x Z")
260        (%p '|x Z| :invert :downcase "x Z")
261        (%p '|x Z| :invert :capitalize "x Z")))))
262  t t t t t t t t t t t t)
263
264;;; Randomized printing tests
265
266(deftest print.symbol.random.1
267  (let ((pkg-name "PRINT-SYMBOL-TEST-PACKAGE"))
268    (when (find-package pkg-name)
269      (delete-package pkg-name))
270    (prog1
271        (let ((*package* (make-package pkg-name)))
272          (trim-list
273           (loop for c across +standard-chars+
274                 nconc
275                 (loop repeat 50
276                       nconc (randomly-check-readability (intern (string c)))))
277           10))
278;;      (delete-package pkg-name)
279      ))
280  nil)
281
282(deftest print.symbol.random.2
283  (let ((pkg-name "PRINT-SYMBOL-TEST-PACKAGE"))
284    (when (find-package pkg-name)
285      (delete-package pkg-name))
286    (prog1
287        (let ((*package* (make-package pkg-name))
288              (count 0))
289          (trim-list
290           (loop for c1 = (random-from-seq +standard-chars+)
291                 for c2 = (random-from-seq +standard-chars+)
292                 for string = (concatenate 'string (string c1) (string c2))
293                 for result = (randomly-check-readability (intern string))
294                 for tries from 1 to 10000
295                 when result do (incf count)
296                 nconc result
297                 when (= count 10)
298                 collect        (format nil "... ~A out of ~A, stopping test ..."
299                                        count tries)
300                 while (< count 10))
301           10))
302      ;; (delete-package pkg-name)
303      ))
304  nil)
305
306(deftest print.symbol.random.3
307  (let ((count 0)
308        (symbols (make-array '(1000) :fill-pointer 0 :adjustable t)))
309    ;; Find all symbols that have a home package, put into array SYMBOLS
310    (do-all-symbols (s)
311      (when (symbol-package s)
312        (vector-push-extend s symbols (array-dimension symbols 0))))
313    (loop for i = (random (fill-pointer symbols))
314          for s = (aref symbols i)
315          for tries from 1 to 10000
316          for problem = (randomly-check-readability s)
317          nconc problem
318          when problem do (incf count)
319          while (< count 10)))
320  nil)
321
322(deftest print.symbol.random.4
323  (let ((count 0)
324        (symbols (make-array '(1000) :fill-pointer 0 :adjustable t)))
325    ;; Find all symbols that have a home package, put into array SYMBOLS
326    (do-all-symbols (s)
327      (when (symbol-package s)
328        (vector-push-extend s symbols (array-dimension symbols 0))))
329    (loop for i = (random (fill-pointer symbols))
330          for s = (aref symbols i)
331          for tries from 1 to 10000
332          for problem = (let ((*package* (symbol-package s)))
333                          (randomly-check-readability s))
334          nconc problem
335          when problem do (incf count)
336          while (< count 10)))
337  nil)
338
339;;;; Tests of printing with escaping enabled
340
341(deftest prin1.symbol.1
342  (with-standard-io-syntax
343   (let ((*print-readably* nil)
344         (*package* (find-package :cl-test))
345         (*readtable* (copy-readtable nil)))
346     (flet ((%p (&rest args) (apply #'prin1.symbol.fn args)))
347       (values
348        (%p '|X| :upcase :upcase     '("x" "X" "\\X" "|X|"))
349        (%p '|X| :upcase :downcase   '("x" "X" "\\X" "|X|"))
350        (%p '|X| :upcase :capitalize '("x" "X" "\\X" "|X|"))
351        (%p '|X| :downcase :upcase     '("\\X" "|X|"))
352        (%p '|X| :downcase :downcase   '("\\X" "|X|"))
353        (%p '|X| :downcase :capitalize '("\\X" "|X|"))
354        (%p '|X| :preserve :upcase     '("X" "\\X" "|X|"))
355        (%p '|X| :preserve :downcase   '("X" "\\X" "|X|"))
356        (%p '|X| :preserve :capitalize '("X" "\\X" "|X|"))
357        (%p '|X| :invert :upcase       '("x" "\\X" "|X|"))
358        (%p '|X| :invert :downcase     '("x" "\\X" "|X|"))
359        (%p '|X| :invert :capitalize   '("x" "\\X" "|X|"))
360        ))))
361  t t t t t t t t t t t t)
362
363(deftest prin1.symbol.2
364  (with-standard-io-syntax
365   (let ((*print-readably* nil)
366         (*package* (find-package :cl-test))
367         (*readtable* (copy-readtable nil)))
368     (flet ((%p (&rest args) (apply #'prin1.symbol.fn args)))
369       (values
370        (%p '|x| :upcase :upcase     '("\\x" "|x|"))
371        (%p '|x| :upcase :downcase   '("\\x" "|x|"))
372        (%p '|x| :upcase :capitalize '("\\x" "|x|"))
373        (%p '|x| :downcase :upcase     '("x" "X" "\\x" "|x|"))
374        (%p '|x| :downcase :downcase   '("x" "X" "\\x" "|x|"))
375        (%p '|x| :downcase :capitalize '("x" "X" "\\x" "|x|"))
376        (%p '|x| :preserve :upcase     '("x" "\\x" "|x|"))
377        (%p '|x| :preserve :downcase   '("x" "\\x" "|x|"))
378        (%p '|x| :preserve :capitalize '("x" "\\x" "|x|"))
379        (%p '|x| :invert :upcase       '("X" "\\x" "|x|"))
380        (%p '|x| :invert :downcase     '("X" "\\x" "|x|"))
381        (%p '|x| :invert :capitalize   '("X" "\\x" "|x|"))
382        ))))
383  t t t t t t t t t t t t)
384
385(deftest prin1.symbol.3
386  (with-standard-io-syntax
387   (let ((*print-readably* nil)
388         (*package* (find-package :cl-test))
389         (*readtable* (copy-readtable nil)))
390     (flet ((%p (&rest args) (apply #'prin1.symbol.fn args)))
391       (values
392        (%p '|1| :upcase :upcase     '("\\1" "|1|"))
393        (%p '|1| :upcase :downcase   '("\\1" "|1|"))
394        (%p '|1| :upcase :capitalize '("\\1" "|1|"))
395        (%p '|1| :downcase :upcase     '("1" "\\1" "|1|"))
396        (%p '|1| :downcase :downcase   '("1" "\\1" "|1|"))
397        (%p '|1| :downcase :capitalize '("1" "\\1" "|1|"))
398        (%p '|1| :preserve :upcase     '("1" "\\1" "|1|"))
399        (%p '|1| :preserve :downcase   '("1" "\\1" "|1|"))
400        (%p '|1| :preserve :capitalize '("1" "\\1" "|1|"))
401        (%p '|1| :invert :upcase       '("1" "\\1" "|1|"))
402        (%p '|1| :invert :downcase     '("1" "\\1" "|1|"))
403        (%p '|1| :invert :capitalize   '("1" "\\1" "|1|"))
404        ))))
405  t t t t t t t t t t t t)
406
407;;; Random symbol printing tests when *print-escape* is true
408;;; and *print-readably* is false.
409
410;;; I AM NOT SURE THESE ARE CORRECT, SO THEY ARE COMMENTED OUT FOR NOW -- PFD
411
412#|
413(deftest print.symbol.escaped-random.1
414  (let ((pkg-name "PRINT-SYMBOL-TEST-PACKAGE"))
415    (when (find-package pkg-name)
416      (delete-package pkg-name))
417    (prog1
418        (let ((*package* (make-package pkg-name))
419              (result
420               (loop for c across +standard-chars+
421                     for s = (intern (string c))
422                     append
423                     (loop repeat 50
424                           nconc (randomly-check-readability
425                                  s
426                                  :readable nil
427                                  :escape t)))))
428          (subseq result 0 (min (length result) 10)))
429      ;; (delete-package pkg-name)
430      ))
431  nil)
432
433(deftest print.symbol.escaped-random.2
434  (let ((result
435         (loop for c across +standard-chars+
436               for s = (make-symbol (string c))
437               nconc
438               (loop repeat 50
439                     nconc (randomly-check-readability
440                            s
441                            :readable nil
442                            :escape t
443                            :gensym t
444                            :test #'similar-uninterned-symbols)))))
445    (subseq result 0 (min (length result) 10)))
446  nil)
447
448(deftest print.symbol.escaped-random.3
449  (let ((pkg-name "PRINT-SYMBOL-TEST-PACKAGE"))
450    (when (find-package pkg-name)
451      (delete-package pkg-name))
452    (prog1
453        (let ((*package* (make-package pkg-name))
454              (result
455               (loop for i below 256
456                     for c = (code-char i)
457                     when c
458                     nconc
459                     (let ((s (intern (string c))))
460                       (loop repeat 50
461                             nconc (randomly-check-readability
462                                    s
463                                    :readable nil
464                                    :escape t))))))
465          (subseq result 0 (min (length result) 10)))
466      ;; (delete-package pkg-name)
467      ))
468  nil)
469       
470(deftest print.symbol.escaped-random.4
471  (let ((result
472         (loop for i below 256
473               for c = (code-char i)
474               when c
475               nconc
476               (let ((s (make-symbol (string c))))
477                 (loop repeat 50
478                       nconc (randomly-check-readability
479                              s
480                              :readable nil
481                              :escape t
482                              :gensym t
483                              :test #'similar-uninterned-symbols))))))
484    (subseq result 0 (min (length result) 10)))
485  nil)
486
487(deftest print.symbol.escaped-random.5
488  (loop for s in *universe*
489        when (and (symbolp s) (symbol-package s) )
490        nconc
491        (loop repeat 50
492              nconc (randomly-check-readability
493                     s
494                     :readable nil
495                     :escape t)))
496  nil)
497
498(deftest print.symbol.escaped-random.6
499  (let ((*package* (find-package "KEYWORD")))
500    (loop for s in *universe*
501          when (and (symbolp s) (symbol-package s))
502          nconc
503          (loop repeat 50
504                nconc (randomly-check-readability
505                       s
506                       :readable nil
507                       :escape t))))
508  nil)
509
510(deftest print.symbol.escaped-random.7
511  (loop for s in *universe*
512        when (and (symbolp s) (not (symbol-package s)))
513        nconc
514        (loop repeat 50
515              nconc (randomly-check-readability
516                     s
517                     :readable nil
518                     :escape t
519                     :gensym t
520                     :test #'similar-uninterned-symbols)))
521  nil)                                                             
522                         
523(deftest print.symbol.escaped-random.8
524  (let ((*package* (find-package "KEYWORD")))
525    (loop for s in *universe*
526          when (and (symbolp s) (not (symbol-package s)))
527          nconc
528          (loop repeat 50
529                nconc (randomly-check-readability
530                       s
531                       :readable nil
532                       :escape t
533                       :gensym t
534                       :test #'similar-uninterned-symbols))))
535  nil)
536
537(deftest print.symbol.escaped.9
538  (let* ((*package* (find-package "CL-TEST"))
539         (s (intern "()")))
540    (randomly-check-readability s :readable nil :escape t))
541  nil)
542
543(deftest print.symbol.escaped.10
544  (let* ((*package* (find-package "KEYWORD"))
545         (s (intern "()")))
546    (randomly-check-readability s :readable nil :escape t))
547  nil)
548
549|#
550
551;;; Tests of printing package prefixes
552
553(deftest print.symbol.prefix.1
554  (with-standard-io-syntax
555   (let ((s (write-to-string (make-symbol "ABC") :gensym t :case :upcase :escape t :readably nil)))
556     (if (string= s "#:ABC") t s)))
557  t)
558
559(deftest print.symbol.prefix.2
560  (with-standard-io-syntax
561   (let ((s (write-to-string (make-symbol "ABC") :gensym nil :case :upcase :readably nil :escape nil)))
562     (if (string= s "ABC") t s)))
563  t)
564
565(deftest print.symbol.prefix.3
566  (with-standard-io-syntax
567   (let ((s (write-to-string (make-symbol "ABC")
568                             :gensym nil :case :upcase
569                             :readably t :escape nil)))
570     (if (and (string= (subseq s 0 2) "#:")
571              (string= (symbol-name (read-from-string s)) "ABC"))
572         t s)))
573  t)
574
575(deftest print.symbol.prefix.4
576  (with-standard-io-syntax
577   (let ((s (write-to-string (make-symbol "ABC") :gensym nil :case :upcase :readably nil :escape t)))
578     (if (string= s "ABC") t s)))
579  t)
580
581(deftest print.symbol.prefix.5
582  (with-standard-io-syntax
583   (let ((pkg-name "PRINT-SYMBOL-TEST-PACKAGE"))
584     (when (find-package pkg-name)
585       (delete-package pkg-name))
586     (let ((pkg (make-package pkg-name)))
587       (multiple-value-prog1
588        (let* ((*package* (find-package "CL-TEST"))
589               (s (intern "ABC" pkg)))
590          (values
591           (write-to-string s :case :upcase :readably nil :escape t)
592           (let ((*package* pkg))
593             (write-to-string s :case :upcase :readably nil :escape t))
594           (let ((*package* pkg))
595             (write-to-string s :case :downcase :readably nil :escape t))
596           ))
597        ;; (delete-package pkg)
598        ))))
599  "PRINT-SYMBOL-TEST-PACKAGE::ABC"
600  "ABC"
601  "abc")
602
603
604(deftest print.symbol.prefix.6
605  (let ((pkg-name "PRINT-SYMBOL-TEST-PACKAGE"))
606    (when (find-package pkg-name)
607      (delete-package pkg-name))
608    (let ((pkg (make-package pkg-name)))
609      (prog1
610          (with-standard-io-syntax
611           (let* ((*package* pkg)
612                  (s (intern "X" pkg)))
613             (write-to-string s :case :upcase :readably nil))
614           ;; (delete-package pkg)
615           ))))
616  "X")
617
618(deftest print.symbol.prefix.6a
619  (with-standard-io-syntax
620   (let ((*package* (find-package "CL-TEST")))
621     (write-to-string 'x :case :upcase :readably nil)))
622  "X")
623
624(deftest print.symbol.prefix.6b
625  (funcall
626   (compile
627    nil
628    '(lambda ()
629       (declare (optimize speed (safety 0)))
630       (with-standard-io-syntax
631        (let ((*package* (find-package "CL-TEST")))
632          (write-to-string 'cl-test::x :case :upcase :readably nil))))))
633  "X")
634
635(deftest print.symbol.prefix.7
636  (with-standard-io-syntax
637   (let ((pkg-name "PRINT-SYMBOL-TEST-PACKAGE")
638         (pkg-name2 "ANOTHER-PRINT-SYMBOL-TEST-PACKAGE"))
639     (when (find-package pkg-name)
640       (delete-package pkg-name))
641     (when (find-package pkg-name2)
642       (delete-package pkg-name2))
643     (prog1
644         (let* ((pkg (make-package pkg-name))
645                (pkg2 (make-package pkg-name2))
646                (s (intern "ABC" pkg)))
647           (import s pkg2)
648           (let ((*package* pkg2))
649             (write-to-string s :case :upcase :readably nil :escape t)))
650       ;; (delete-package pkg)
651       )))
652  "ABC")
653
654(deftest print.symbol.prefix.8
655  (with-standard-io-syntax
656   (let ((pkg-name "PRINT-SYMBOL-TEST-PACKAGE")
657         (pkg-name2 "ANOTHER-PRINT-SYMBOL-TEST-PACKAGE"))
658     (when (find-package pkg-name)
659       (delete-package pkg-name))
660     (when (find-package pkg-name2)
661       (delete-package pkg-name2))
662     (prog1
663         (let* ((pkg (make-package pkg-name))
664                (pkg2 (make-package pkg-name2))
665                (s (intern "ABC" pkg2)))
666           (import s pkg)
667           (delete-package pkg2)
668           (let ((*package* pkg))
669             (write-to-string s :case :upcase :gensym t :readably nil :escape t)))
670       ;; (delete-package pkg)
671       )))
672  "#:ABC")
673
674(deftest print.symbol.prefix.9
675  (with-standard-io-syntax
676   (let ((pkg-name "PRINT-SYMBOL-TEST-PACKAGE"))
677     (when (find-package pkg-name)
678       (delete-package pkg-name))
679     (prog1
680         (let* ((pkg (make-package pkg-name))
681                (s (intern "ABC" pkg)))
682           (export s pkg)
683           (let ((*package* (find-package "CL-TEST")))
684             (write-to-string s :case :upcase :readably nil :escape t)))
685       ;; (delete-package pkg)
686       )))
687  "PRINT-SYMBOL-TEST-PACKAGE:ABC")
688
689
690(deftest print.symbol.prefix.10
691  (with-standard-io-syntax
692   (let ((pkg-name "PRINT-SYMBOL-TEST-PACKAGE"))
693     (when (find-package pkg-name)
694       (delete-package pkg-name))
695     (prog1
696         (let* ((pkg (make-package pkg-name))
697                (s :|X|))
698           (import s pkg)
699           (let ((*package* pkg))
700             (write-to-string s :case :upcase :readably nil :escape t)))
701       ;; (delete-package pkg)
702       )))
703  ":X")
704
Note: See TracBrowser for help on using the repository browser.