source: trunk/source/tests/ansi-tests/universe.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: 14.4 KB
Line 
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*))
Note: See TracBrowser for help on using the repository browser.