← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to ansi-tests/universe.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
ansi-tests/universe.lsp
 
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 GCL CMU ECL) (make-hash-table :test #'equalp)
 
374
   ))
 
375
 
 
376
(defparameter *pathnames*
 
377
  (locally
 
378
   (declare (optimize safety))
 
379
   (append
 
380
    (ignore-errors (list (make-pathname :name "foo")))
 
381
    (ignore-errors (list (make-pathname :name "FOO" :case :common)))
 
382
    (ignore-errors (list (make-pathname :name "bar")))
 
383
    (ignore-errors (list (make-pathname :name "foo" :type "txt")))
 
384
    (ignore-errors (list (make-pathname :name "bar" :type "txt")))
 
385
    (ignore-errors (list (make-pathname :name "XYZ" :type "TXT" :case :common)))
 
386
    (ignore-errors (list (make-pathname :name nil)))
 
387
    (ignore-errors (list (make-pathname :name :wild)))
 
388
    (ignore-errors (list (make-pathname :name nil :type "txt")))
 
389
    (ignore-errors (list (make-pathname :name :wild :type "txt")))
 
390
    (ignore-errors (list (make-pathname :name :wild :type "TXT" :case :common)))
 
391
    (ignore-errors (list (make-pathname :name :wild :type "abc" :case :common)))
 
392
    (ignore-errors (list (make-pathname :directory :wild)))
 
393
    (ignore-errors (list (make-pathname :type :wild)))
 
394
    (ignore-errors (list (make-pathname :version :wild)))
 
395
    (ignore-errors (list (make-pathname :version :newest)))
 
396
    )))
 
397
 
 
398
(eval-when (load eval compile)
 
399
  (locally
 
400
   (declare (optimize safety))
 
401
   (ignore-errors
 
402
     (setf (logical-pathname-translations "CLTESTROOT")
 
403
           `(("**;*.*.*" ,(make-pathname :directory '(:absolute :wild-inferiors)
 
404
                                         :name :wild :type :wild)))))
 
405
   (ignore-errors
 
406
     (setf (logical-pathname-translations "CLTEST")
 
407
           `(("**;*.*.*" ,(make-pathname
 
408
                           :directory (append
 
409
                                       (pathname-directory
 
410
                                        (truename (make-pathname)))
 
411
                                       '(:wild-inferiors))
 
412
                           :name :wild :type :wild)))))
 
413
   ))
 
414
 
 
415
(defparameter *logical-pathnames*
 
416
  (locally
 
417
   (declare (optimize safety))
 
418
   (append
 
419
    (ignore-errors (list (logical-pathname "CLTESTROOT:")))
 
420
    )))
 
421
 
 
422
(defparameter *streams*
 
423
  (remove-duplicates
 
424
   (remove-if
 
425
    #'null
 
426
    (list
 
427
     *debug-io*
 
428
     *error-output*
 
429
     *query-io*
 
430
     *standard-input*
 
431
     *standard-output*
 
432
     *terminal-io*
 
433
     *trace-output*))))
 
434
 
 
435
(defparameter *readtables*
 
436
  (list *readtable*
 
437
        (copy-readtable)))
 
438
 
 
439
(defstruct foo-structure
 
440
  x y z)
 
441
 
 
442
(defstruct bar-structure
 
443
  x y z)
 
444
 
 
445
(defparameter *structures*
 
446
  (list
 
447
   (make-foo-structure :x 1 :y 'a :z nil)
 
448
   (make-foo-structure :x 1 :y 'a :z nil)
 
449
   (make-bar-structure :x 1 :y 'a :z nil)
 
450
   ))
 
451
 
 
452
(defun meaningless-user-function-for-universe (x y z)
 
453
  (list (+ x 1) (+ y 2) (+ z 3)))
 
454
 
 
455
(defgeneric meaningless-user-generic-function-for-universe (x y z)
 
456
  #+(or (not :gcl) :setf) (:method ((x integer) (y integer) (z integer)) (+ x y z))
 
457
  )
 
458
 
 
459
(eval-when (:load-toplevel)
 
460
  (compile 'meaningless-user-function-for-universe)
 
461
  (compile 'meaningless-user-generic-function-for-universe)
 
462
  )
 
463
 
 
464
(defparameter *functions*
 
465
  (list #'cons #'car #'append #'values
 
466
        (macro-function 'cond)
 
467
        #'meaningless-user-function-for-universe
 
468
        #'meaningless-user-generic-function-for-universe
 
469
        #'(lambda (x) x)))
 
470
 
 
471
(defparameter *methods*
 
472
  (list
 
473
   ;; Add methods here
 
474
   ))
 
475
   
 
476
 
 
477
(defparameter *random-states*
 
478
  (list (make-random-state)))
 
479
 
 
480
(defparameter *universe*
 
481
  (remove-duplicates
 
482
   (append
 
483
    *symbols*
 
484
    *numbers*
 
485
    *characters*
 
486
    (mapcar #'copy-seq *strings*)
 
487
    *conses*
 
488
    *condition-objects*
 
489
    *package-objects*
 
490
    *arrays*
 
491
    *hash-tables*
 
492
    *pathnames*
 
493
    *logical-pathnames*
 
494
    *streams*
 
495
    *readtables*
 
496
    *structures*
 
497
    *functions*
 
498
    *random-states*
 
499
    *methods*
 
500
    nil)))
 
501
 
 
502
(defparameter *mini-universe*
 
503
  (remove-duplicates
 
504
   (append
 
505
    (mapcar #'first
 
506
            (list *symbols*
 
507
                  *numbers*
 
508
                  *characters*
 
509
                  (list (copy-seq (first *strings*)))
 
510
                  *conses*
 
511
                  *condition-objects*
 
512
                  *package-objects*
 
513
                  *arrays*
 
514
                  *hash-tables*
 
515
                  *pathnames*
 
516
                  *logical-pathnames*
 
517
                  *streams*
 
518
                  *readtables*
 
519
                  *structures*
 
520
                  *functions*
 
521
                  *random-states*
 
522
                  *methods*))
 
523
    '(;;; Others to fill in gaps
 
524
      1.2s0 1.3f0 1.5d0 1.8l0 3/5 10000000000000000000000))))