1 | ;-*- Mode: Lisp -*- |
---|
2 | ;;;; Author: Paul Dietz |
---|
3 | ;;;; Created: Thu Apr 9 19:32:56 1998 |
---|
4 | ;;;; Contains: A global variable containing a list of |
---|
5 | ;;;; as many kinds of CL objects as we can think of |
---|
6 | ;;;; This list is used to test many other CL functions |
---|
7 | |
---|
8 | (in-package :cl-test) |
---|
9 | |
---|
10 | (defparameter *condition-types* |
---|
11 | '(arithmetic-error |
---|
12 | cell-error |
---|
13 | condition |
---|
14 | control-error |
---|
15 | division-by-zero |
---|
16 | end-of-file |
---|
17 | error |
---|
18 | file-error |
---|
19 | floating-point-inexact |
---|
20 | floating-point-invalid-operation |
---|
21 | floating-point-underflow |
---|
22 | floating-point-overflow |
---|
23 | package-error |
---|
24 | parse-error |
---|
25 | print-not-readable |
---|
26 | program-error |
---|
27 | reader-error |
---|
28 | serious-condition |
---|
29 | simple-condition |
---|
30 | simple-error |
---|
31 | simple-type-error |
---|
32 | simple-warning |
---|
33 | storage-condition |
---|
34 | stream-error |
---|
35 | style-warning |
---|
36 | type-error |
---|
37 | unbound-slot |
---|
38 | unbound-variable |
---|
39 | undefined-function |
---|
40 | warning)) |
---|
41 | |
---|
42 | (defparameter *condition-objects* |
---|
43 | (locally (declare (optimize safety)) |
---|
44 | (loop for tp in *condition-types* append |
---|
45 | (handler-case (list (make-condition tp)) |
---|
46 | (error () nil))))) |
---|
47 | |
---|
48 | (defparameter *standard-package-names* |
---|
49 | '("COMMON-LISP" "COMMON-LISP-USER" "KEYWORD")) |
---|
50 | |
---|
51 | (defparameter *package-objects* |
---|
52 | (locally (declare (optimize safety)) |
---|
53 | (loop for pname in *standard-package-names* append |
---|
54 | (handler-case (let ((pkg (find-package pname))) |
---|
55 | (and pkg (list pkg))) |
---|
56 | (error () nil))))) |
---|
57 | |
---|
58 | (defparameter *integers* |
---|
59 | (remove-duplicates |
---|
60 | `( |
---|
61 | 0 |
---|
62 | ;; Integers near the fixnum/bignum boundaries |
---|
63 | ,@(loop for i from -5 to 5 collect (+ i most-positive-fixnum)) |
---|
64 | ,@(loop for i from -5 to 5 collect (+ i most-negative-fixnum)) |
---|
65 | ;; Powers of two, negatives, and off by one. |
---|
66 | ,@(loop for i from 1 to 64 collect (ash 1 i)) |
---|
67 | ,@(loop for i from 1 to 64 collect (1- (ash 1 i))) |
---|
68 | ,@(loop for i from 1 to 64 collect (ash -1 i)) |
---|
69 | ,@(loop for i from 1 to 64 collect (1+ (ash -1 i))) |
---|
70 | ;; A big integer |
---|
71 | ,(expt 17 50) |
---|
72 | ;; Some arbitrarily chosen integers |
---|
73 | 12387131 1272314 231 -131 -561823 23713 -1234611312123 444121 991))) |
---|
74 | |
---|
75 | (defparameter *floats* |
---|
76 | (append |
---|
77 | (loop for sym in '(pi |
---|
78 | most-positive-short-float |
---|
79 | least-positive-short-float |
---|
80 | least-positive-normalized-short-float |
---|
81 | most-positive-double-float |
---|
82 | least-positive-double-float |
---|
83 | least-positive-normalized-double-float |
---|
84 | most-positive-long-float |
---|
85 | least-positive-long-float |
---|
86 | least-positive-normalized-long-float |
---|
87 | most-positive-single-float |
---|
88 | least-positive-single-float |
---|
89 | least-positive-normalized-single-float |
---|
90 | most-negative-short-float |
---|
91 | least-negative-short-float |
---|
92 | least-negative-normalized-short-float |
---|
93 | most-negative-single-float |
---|
94 | least-negative-single-float |
---|
95 | least-negative-normalized-single-float |
---|
96 | most-negative-double-float |
---|
97 | least-negative-double-float |
---|
98 | least-negative-normalized-double-float |
---|
99 | most-negative-long-float |
---|
100 | least-negative-long-float |
---|
101 | least-negative-normalized-long-float |
---|
102 | short-float-epsilon |
---|
103 | short-float-negative-epsilon |
---|
104 | single-float-epsilon |
---|
105 | single-float-negative-epsilon |
---|
106 | double-float-epsilon |
---|
107 | double-float-negative-epsilon |
---|
108 | long-float-epsilon |
---|
109 | long-float-negative-epsilon) |
---|
110 | when (boundp sym) collect (symbol-value sym)) |
---|
111 | (list |
---|
112 | 0.0 1.0 -1.0 313123.13 283143.231 -314781.9 |
---|
113 | 1.31283d2 834.13812D-45 |
---|
114 | 8131238.1E14 -4618926.231e-2 |
---|
115 | -37818.131F3 81.318231f-19 |
---|
116 | 1.31273s3 12361.12S-7 |
---|
117 | 6124.124l0 13123.1L-23))) |
---|
118 | |
---|
119 | (defparameter *ratios* |
---|
120 | '(1/3 1/1000 1/1000000000000000 -10/3 -1000/7 -987129387912381/13612986912361 |
---|
121 | 189729874978126783786123/1234678123487612347896123467851234671234)) |
---|
122 | |
---|
123 | (defparameter *complexes* |
---|
124 | '(#C(0.0 0.0) |
---|
125 | #C(1.0 0.0) |
---|
126 | #C(0.0 1.0) |
---|
127 | #C(1.0 1.0) |
---|
128 | #C(-1.0 -1.0) |
---|
129 | #C(1289713.12312 -9.12681271) |
---|
130 | #C(1.0D100 1.0D100) |
---|
131 | #C(-1.0D-100 -1.0D-100) |
---|
132 | #C(10.0s0 20.0s0) |
---|
133 | #C(100.0l0 200.0l0) |
---|
134 | #C(1.0s0 2.0f0) |
---|
135 | #C(1.0s0 3.0d0) |
---|
136 | #C(1.0s0 4.0l0) |
---|
137 | #C(1.0f0 5.0d0) |
---|
138 | #C(1.0f0 6.0l0) |
---|
139 | #C(1.0d0 7.0l0) |
---|
140 | #C(1.0f0 2.0s0) |
---|
141 | #C(1.0d0 3.0s0) |
---|
142 | #C(1.0l0 4.0s0) |
---|
143 | #C(1.0d0 5.0f0) |
---|
144 | #C(1.0l0 6.0f0) |
---|
145 | #C(1.0l0 7.0d0) |
---|
146 | #C(1/2 1/3) |
---|
147 | )) |
---|
148 | |
---|
149 | (defparameter *numbers* |
---|
150 | (append *integers* |
---|
151 | *floats* |
---|
152 | *ratios* |
---|
153 | *complexes*)) |
---|
154 | |
---|
155 | (defparameter *reals* (append *integers* *floats* *ratios*)) |
---|
156 | |
---|
157 | (defparameter *rationals* (append *integers* *ratios*)) |
---|
158 | |
---|
159 | (defun try-to-read-chars (&rest namelist) |
---|
160 | (declare (optimize safety)) |
---|
161 | (loop |
---|
162 | for name in namelist append |
---|
163 | (handler-case |
---|
164 | (list (read-from-string |
---|
165 | (concatenate 'string "\#\\" name))) |
---|
166 | (error () nil)))) |
---|
167 | |
---|
168 | (defparameter *characters* |
---|
169 | (remove-duplicates |
---|
170 | `(#\Newline |
---|
171 | #\Space |
---|
172 | ,@(try-to-read-chars "Rubout" |
---|
173 | "Page" |
---|
174 | "Tab" |
---|
175 | "Backspace" |
---|
176 | "Return" |
---|
177 | "Linefeed" |
---|
178 | "Null") |
---|
179 | #\a #\A #\0 #\9 #\. #\( #\) #\[ #\] |
---|
180 | ))) |
---|
181 | |
---|
182 | |
---|
183 | (defparameter *strings* |
---|
184 | (append |
---|
185 | (and (code-char 0) |
---|
186 | (list |
---|
187 | (make-string 1 :initial-element (code-char 0)) |
---|
188 | (make-string 10 :initial-element (code-char 0)))) |
---|
189 | (list |
---|
190 | "" "A" "a" "0" "abcdef" |
---|
191 | "~!@#$%^&*()_+`1234567890-=<,>.?/:;\"'{[}]|\\ abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWYXZ" |
---|
192 | (make-string 100000 :initial-element #\g) |
---|
193 | (let ((s (make-string 256))) |
---|
194 | (loop |
---|
195 | for i from 0 to 255 |
---|
196 | do (let ((c (code-char i))) |
---|
197 | (when c |
---|
198 | (setf (elt s i) c)))) |
---|
199 | s) |
---|
200 | ;; Specialized strings |
---|
201 | (make-array 3 |
---|
202 | :element-type 'character |
---|
203 | :displaced-to (make-array 5 :element-type 'character |
---|
204 | :initial-contents "abcde") |
---|
205 | :displaced-index-offset 1) |
---|
206 | (make-array 10 :initial-element #\x |
---|
207 | :fill-pointer 5 |
---|
208 | :element-type 'character) |
---|
209 | (make-array 10 :initial-element #\x |
---|
210 | :element-type 'base-char) |
---|
211 | (make-array 3 :initial-element #\y |
---|
212 | :adjustable t |
---|
213 | :element-type 'base-char) |
---|
214 | ))) |
---|
215 | |
---|
216 | (defparameter *conses* |
---|
217 | (list |
---|
218 | (list 'a 'b) |
---|
219 | (list nil) |
---|
220 | (list 1 2 3 4 5 6))) |
---|
221 | |
---|
222 | (defparameter *circular-conses* |
---|
223 | (list |
---|
224 | (let ((s (copy-list '(a b c d)))) |
---|
225 | (nconc s s) |
---|
226 | s) |
---|
227 | (let ((s (list nil))) |
---|
228 | (setf (car s) s) |
---|
229 | s) |
---|
230 | (let ((s (list nil))) |
---|
231 | (setf (car s) s) |
---|
232 | (setf (cdr s) s)))) |
---|
233 | |
---|
234 | (defparameter *booleans* '(nil t)) |
---|
235 | (defparameter *keywords* '(:a :b :|| :|a| :|1234|)) |
---|
236 | (defparameter *uninterned-symbols* |
---|
237 | (list '#:nil '#:t '#:foo '#:||)) |
---|
238 | (defparameter *cl-test-symbols* |
---|
239 | `(,(intern "a" :cl-test) |
---|
240 | ,(intern "" :cl-test) |
---|
241 | ,@(and (code-char 0) |
---|
242 | (list (intern (make-string 1 :initial-element (code-char 0)) :cl-test))) |
---|
243 | ,@(and (code-char 0) |
---|
244 | (let* ((s (make-string 10 :initial-element (code-char 0))) |
---|
245 | (s2 (copy-seq s)) |
---|
246 | (s3 (copy-seq s))) |
---|
247 | (setf (subseq s 3 4) "a") |
---|
248 | (setf (subseq s2 4 5) "a") |
---|
249 | (setf (subseq s3 4 5) "a") |
---|
250 | (setf (subseq s3 7 8) "b") |
---|
251 | (list (intern s :cl-test) |
---|
252 | (intern s2 :cl-test) |
---|
253 | (intern s3 :cl-test)))) |
---|
254 | )) |
---|
255 | |
---|
256 | (defparameter *cl-user-symbols* |
---|
257 | '(cl-user::foo |
---|
258 | cl-user::x |
---|
259 | cl-user::cons |
---|
260 | cl-user::lambda |
---|
261 | cl-user::*print-readably* |
---|
262 | cl-user::push)) |
---|
263 | |
---|
264 | (defparameter *symbols* |
---|
265 | (append *booleans* *keywords* *uninterned-symbols* |
---|
266 | *cl-test-symbols* |
---|
267 | *cl-user-symbols*)) |
---|
268 | |
---|
269 | (defparameter *array-dimensions* |
---|
270 | (loop |
---|
271 | for i from 0 to 8 collect |
---|
272 | (loop for j from 1 to i collect 2))) |
---|
273 | |
---|
274 | (defparameter *default-array-target* (make-array '(300))) |
---|
275 | |
---|
276 | (defparameter *arrays* |
---|
277 | (append |
---|
278 | (list (make-array '10)) |
---|
279 | (mapcar #'make-array *array-dimensions*) |
---|
280 | |
---|
281 | ;; typed arrays |
---|
282 | (loop for tp in '(fixnum float bit character base-char |
---|
283 | (signed-byte 8) (unsigned-byte 8)) |
---|
284 | for element in '(18 16.0f0 0 #\x #\y 127 200) |
---|
285 | append |
---|
286 | (loop |
---|
287 | for d in *array-dimensions* |
---|
288 | collect (make-array d :element-type tp |
---|
289 | :initial-element element))) |
---|
290 | |
---|
291 | ;; More typed arrays |
---|
292 | (loop for i from 1 to 64 |
---|
293 | append |
---|
294 | (list (make-array 10 :element-type `(unsigned-byte ,i) |
---|
295 | :initial-element 1) |
---|
296 | (make-array 10 :element-type `(signed-byte ,i) |
---|
297 | :initial-element 0))) |
---|
298 | |
---|
299 | ;; adjustable arrays |
---|
300 | (loop |
---|
301 | for d in *array-dimensions* |
---|
302 | collect (make-array d :adjustable t)) |
---|
303 | |
---|
304 | ;; Displaced arrays |
---|
305 | (loop |
---|
306 | for d in *array-dimensions* |
---|
307 | for i from 1 |
---|
308 | collect (make-array d :displaced-to *default-array-target* |
---|
309 | :displaced-index-offset i)) |
---|
310 | |
---|
311 | (list |
---|
312 | #() |
---|
313 | #* |
---|
314 | #*00000 |
---|
315 | #*1010101010101101 |
---|
316 | (make-array 10 :element-type 'bit |
---|
317 | :initial-contents '(0 1 1 0 1 1 1 1 0 1) |
---|
318 | :fill-pointer 8) |
---|
319 | (make-array 5 :element-type 'bit |
---|
320 | :displaced-to #*0111000110 |
---|
321 | :displaced-index-offset 3) |
---|
322 | (make-array 10 :element-type 'bit |
---|
323 | :initial-contents '(1 1 0 0 1 1 1 0 1 1) |
---|
324 | :adjustable t) |
---|
325 | ) |
---|
326 | |
---|
327 | ;; Integer arrays |
---|
328 | (list |
---|
329 | (make-array '(10) :element-type '(integer 0 (256)) |
---|
330 | :initial-contents '(8 9 10 11 12 1 2 3 4 5)) |
---|
331 | (make-array '(10) :element-type '(integer -128 (128)) |
---|
332 | :initial-contents '(8 9 -10 11 -12 1 -2 -3 4 5)) |
---|
333 | (make-array '(6) :element-type '(integer 0 (#.(ash 1 16))) |
---|
334 | :initial-contents '(5 9 100 1312 23432 87)) |
---|
335 | (make-array '(4) :element-type '(integer 0 (#.(ash 1 28))) |
---|
336 | :initial-contents '(100000 231213 8123712 19)) |
---|
337 | (make-array '(4) :element-type '(integer 0 (#.(ash 1 32))) |
---|
338 | :initial-contents '(#.(1- (ash 1 32)) 0 872312 10000000)) |
---|
339 | |
---|
340 | (make-array nil :element-type '(integer 0 (256)) |
---|
341 | :initial-element 14) |
---|
342 | (make-array '(2 2) :element-type '(integer 0 (256)) |
---|
343 | :initial-contents '((34 98)(14 119))) |
---|
344 | ) |
---|
345 | |
---|
346 | ;; Float arrays |
---|
347 | (list |
---|
348 | (make-array '(5) :element-type 'short-float |
---|
349 | :initial-contents '(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0)) |
---|
350 | (make-array '(5) :element-type 'single-float |
---|
351 | :initial-contents '(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0)) |
---|
352 | (make-array '(5) :element-type 'double-float |
---|
353 | :initial-contents '(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0)) |
---|
354 | (make-array '(5) :element-type 'long-float |
---|
355 | :initial-contents '(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0)) |
---|
356 | ) |
---|
357 | |
---|
358 | ;; The ever-popular NIL array |
---|
359 | (locally (declare (optimize safety)) |
---|
360 | (handler-case |
---|
361 | (list (make-array '(0) :element-type nil)) |
---|
362 | (error () nil))) |
---|
363 | |
---|
364 | ;; more kinds of arrays here later? |
---|
365 | )) |
---|
366 | |
---|
367 | (defparameter *hash-tables* |
---|
368 | (list |
---|
369 | (make-hash-table) |
---|
370 | (make-hash-table :test #'eq) |
---|
371 | (make-hash-table :test #'eql) |
---|
372 | (make-hash-table :test #'equal) |
---|
373 | #-(or CMU ECL) (make-hash-table :test #'equalp) |
---|
374 | )) |
---|
375 | |
---|
376 | (defparameter *pathnames* |
---|
377 | (locally |
---|
378 | (declare (optimize safety)) |
---|
379 | (loop for form in '((make-pathname :name "foo") |
---|
380 | (make-pathname :name "FOO" :case :common) |
---|
381 | (make-pathname :name "bar") |
---|
382 | (make-pathname :name "foo" :type "txt") |
---|
383 | (make-pathname :name "bar" :type "txt") |
---|
384 | (make-pathname :name "XYZ" :type "TXT" :case :common) |
---|
385 | (make-pathname :name nil) |
---|
386 | (make-pathname :name :wild) |
---|
387 | (make-pathname :name nil :type "txt") |
---|
388 | (make-pathname :name :wild :type "txt") |
---|
389 | (make-pathname :name :wild :type "TXT" :case :common) |
---|
390 | (make-pathname :name :wild :type "abc" :case :common) |
---|
391 | (make-pathname :directory :wild) |
---|
392 | (make-pathname :type :wild) |
---|
393 | (make-pathname :version :wild) |
---|
394 | (make-pathname :version :newest)) |
---|
395 | append (ignore-errors (eval `(list ,form)))))) |
---|
396 | |
---|
397 | (eval-when (:compile-toplevel :load-toplevel :execute) |
---|
398 | (locally |
---|
399 | (declare (optimize safety)) |
---|
400 | (ignore-errors |
---|
401 | (setf (logical-pathname-translations "CLTESTROOT") |
---|
402 | `(("**;*.*.*" ,(make-pathname :directory '(:absolute :wild-inferiors) |
---|
403 | :name :wild :type :wild))))) |
---|
404 | (ignore-errors |
---|
405 | (setf (logical-pathname-translations "CLTEST") |
---|
406 | `(("**;*.*.*" ,(make-pathname |
---|
407 | :directory (append |
---|
408 | (pathname-directory |
---|
409 | (truename (make-pathname))) |
---|
410 | '(:wild-inferiors)) |
---|
411 | :name :wild :type :wild))))) |
---|
412 | )) |
---|
413 | |
---|
414 | (defparameter *logical-pathnames* |
---|
415 | (locally |
---|
416 | (declare (optimize safety)) |
---|
417 | (append |
---|
418 | (ignore-errors (list (logical-pathname "CLTESTROOT:"))) |
---|
419 | ))) |
---|
420 | |
---|
421 | (defparameter *streams* |
---|
422 | (remove-duplicates |
---|
423 | (remove-if |
---|
424 | #'null |
---|
425 | (list |
---|
426 | *debug-io* |
---|
427 | *error-output* |
---|
428 | *query-io* |
---|
429 | *standard-input* |
---|
430 | *standard-output* |
---|
431 | *terminal-io* |
---|
432 | *trace-output*)))) |
---|
433 | |
---|
434 | (defparameter *readtables* |
---|
435 | (list *readtable* |
---|
436 | (copy-readtable))) |
---|
437 | |
---|
438 | (defstruct foo-structure |
---|
439 | x y z) |
---|
440 | |
---|
441 | (defstruct bar-structure |
---|
442 | x y z) |
---|
443 | |
---|
444 | (defparameter *structures* |
---|
445 | (list |
---|
446 | (make-foo-structure :x 1 :y 'a :z nil) |
---|
447 | (make-foo-structure :x 1 :y 'a :z nil) |
---|
448 | (make-bar-structure :x 1 :y 'a :z nil) |
---|
449 | )) |
---|
450 | |
---|
451 | (defun meaningless-user-function-for-universe (x y z) |
---|
452 | (list (+ x 1) (+ y 2) (+ z 3))) |
---|
453 | |
---|
454 | (defgeneric meaningless-user-generic-function-for-universe (x y z) |
---|
455 | #+(or (not :gcl) :ansi-cl) (:method ((x integer) (y integer) (z integer)) (+ x y z))) |
---|
456 | |
---|
457 | (eval-when (:load-toplevel :execute) |
---|
458 | (compile 'meaningless-user-function-for-universe) |
---|
459 | ;; Conditionalize to avoid a cmucl bug |
---|
460 | #-(or cmu gcl ecl) (compile 'meaningless-user-generic-function-for-universe) |
---|
461 | ) |
---|
462 | |
---|
463 | (defparameter *functions* |
---|
464 | (list #'cons #'car #'append #'values |
---|
465 | (macro-function 'cond) |
---|
466 | #'meaningless-user-function-for-universe |
---|
467 | #'meaningless-user-generic-function-for-universe |
---|
468 | #'(lambda (x) x) |
---|
469 | (compile nil '(lambda (x) x)))) |
---|
470 | |
---|
471 | (defparameter *methods* |
---|
472 | (list |
---|
473 | #+(or (not :gcl) :ansi-cl ) |
---|
474 | (find-method #'meaningless-user-generic-function-for-universe nil |
---|
475 | (mapcar #'find-class '(integer integer integer))) |
---|
476 | ;; Add more methods here |
---|
477 | )) |
---|
478 | |
---|
479 | |
---|
480 | (defparameter *random-states* |
---|
481 | (list (make-random-state))) |
---|
482 | |
---|
483 | (defparameter *universe* |
---|
484 | (remove-duplicates |
---|
485 | (append |
---|
486 | *symbols* |
---|
487 | *numbers* |
---|
488 | *characters* |
---|
489 | (mapcar #'copy-seq *strings*) |
---|
490 | *conses* |
---|
491 | *condition-objects* |
---|
492 | *package-objects* |
---|
493 | *arrays* |
---|
494 | *hash-tables* |
---|
495 | *pathnames* |
---|
496 | *logical-pathnames* |
---|
497 | *streams* |
---|
498 | *readtables* |
---|
499 | *structures* |
---|
500 | *functions* |
---|
501 | *random-states* |
---|
502 | *methods* |
---|
503 | nil))) |
---|
504 | |
---|
505 | (defparameter *mini-universe* |
---|
506 | (remove-duplicates |
---|
507 | (append |
---|
508 | (mapcar #'first |
---|
509 | (list *symbols* |
---|
510 | *numbers* |
---|
511 | *characters* |
---|
512 | (list (copy-seq (first *strings*))) |
---|
513 | *conses* |
---|
514 | *condition-objects* |
---|
515 | *package-objects* |
---|
516 | *arrays* |
---|
517 | *hash-tables* |
---|
518 | *pathnames* |
---|
519 | *logical-pathnames* |
---|
520 | *streams* |
---|
521 | *readtables* |
---|
522 | *structures* |
---|
523 | *functions* |
---|
524 | *random-states* |
---|
525 | *methods*)) |
---|
526 | '(;;; Others to fill in gaps |
---|
527 | 1.2s0 1.3f0 1.5d0 1.8l0 3/5 10000000000000000000000)))) |
---|
528 | |
---|
529 | (defparameter *classes* |
---|
530 | (remove-duplicates (mapcar #'class-of *universe*))) |
---|
531 | |
---|
532 | (defparameter *built-in-classes* |
---|
533 | (remove-if-not #'(lambda (x) (typep x 'built-in-class)) |
---|
534 | *classes*)) |
---|