universe.lsp 16.9 KB
Newer Older
1 2 3 4 5 6 7 8 9
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Thu Apr  9 19:32:56 1998
;;;; Contains: A global variable containing a list of
;;;;           as many kinds of CL objects as we can think of
;;;;           This list is used to test many other CL functions

(in-package :cl-test)

10
(defparameter *condition-types*
11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41
    '(arithmetic-error
      cell-error
      condition
      control-error
      division-by-zero
      end-of-file
      error
      file-error
      floating-point-inexact
      floating-point-invalid-operation
      floating-point-underflow
      floating-point-overflow
      package-error
      parse-error
      print-not-readable
      program-error
      reader-error
      serious-condition
      simple-condition
      simple-error
      simple-type-error
      simple-warning
      storage-condition
      stream-error
      style-warning
      type-error
      unbound-slot
      unbound-variable
      undefined-function
      warning))

42
(defparameter *condition-objects*
43
  (locally (declare (optimize safety))
sds's avatar
sds committed
44 45 46
           (loop for tp in *condition-types* append
                 (handler-case (list (make-condition tp))
                               (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))
sds's avatar
sds committed
53 54 55 56
           (loop for pname in *standard-package-names* append
                 (handler-case (let ((pkg (find-package pname)))
                                 (and pkg (list pkg)))
                               (error () nil)))))
57

58
(defparameter *integers*
59 60 61 62
    (remove-duplicates
     `(
       0
       ;; Integers near the fixnum/bignum boundaries
63 64
       ,@(loop for i from -5 to 5 collect (+ i most-positive-fixnum))
       ,@(loop for i from -5 to 5 collect (+ i most-negative-fixnum))
65 66 67 68 69 70 71 72 73 74
       ;; Powers of two, negatives, and off by one.
       ,@(loop for i from 1 to 64 collect (ash 1 i))
       ,@(loop for i from 1 to 64 collect (1- (ash 1 i)))
       ,@(loop for i from 1 to 64 collect (ash -1 i))
       ,@(loop for i from 1 to 64 collect (1+ (ash -1 i)))
       ;; A big integer
       ,(expt 17 50)
       ;; Some arbitrarily chosen integers
       12387131 1272314 231 -131 -561823 23713 -1234611312123 444121 991)))

75
(defparameter *floats*
76
    (append
77
     (loop for sym in '(pi
sds's avatar
sds committed
78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110
                        most-positive-short-float
                        least-positive-short-float
                        least-positive-normalized-short-float
                        most-positive-double-float
                        least-positive-double-float
                        least-positive-normalized-double-float
                        most-positive-long-float
                        least-positive-long-float
                        least-positive-normalized-long-float
                        most-positive-single-float
                        least-positive-single-float
                        least-positive-normalized-single-float
                        most-negative-short-float
                        least-negative-short-float
                        least-negative-normalized-short-float
                        most-negative-single-float
                        least-negative-single-float
                        least-negative-normalized-single-float
                        most-negative-double-float
                        least-negative-double-float
                        least-negative-normalized-double-float
                        most-negative-long-float
                        least-negative-long-float
                        least-negative-normalized-long-float
                        short-float-epsilon
                        short-float-negative-epsilon
                        single-float-epsilon
                        single-float-negative-epsilon
                        double-float-epsilon
                        double-float-negative-epsilon
                        long-float-epsilon
                        long-float-negative-epsilon)
           when (boundp sym) collect (symbol-value sym))
111 112 113 114 115 116 117
     (list
      0.0 1.0 -1.0 313123.13 283143.231 -314781.9
      1.31283d2 834.13812D-45
      8131238.1E14 -4618926.231e-2
      -37818.131F3 81.318231f-19
      1.31273s3 12361.12S-7
      6124.124l0 13123.1L-23)))
118

119
(defparameter *ratios*
120 121 122
    '(1/3 1/1000 1/1000000000000000 -10/3 -1000/7 -987129387912381/13612986912361
      189729874978126783786123/1234678123487612347896123467851234671234))

123
(defparameter *complexes*
124 125 126 127 128 129 130
    '(#C(0.0 0.0)
      #C(1.0 0.0)
      #C(0.0 1.0)
      #C(1.0 1.0)
      #C(-1.0 -1.0)
      #C(1289713.12312 -9.12681271)
      #C(1.0D100 1.0D100)
pfdietz's avatar
pfdietz committed
131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147
      #C(-1.0D-100 -1.0D-100)
      #C(10.0s0 20.0s0)
      #C(100.0l0 200.0l0)
      #C(1.0s0 2.0f0)
      #C(1.0s0 3.0d0)
      #C(1.0s0 4.0l0)
      #C(1.0f0 5.0d0)
      #C(1.0f0 6.0l0)
      #C(1.0d0 7.0l0)
      #C(1.0f0 2.0s0)
      #C(1.0d0 3.0s0)
      #C(1.0l0 4.0s0)
      #C(1.0d0 5.0f0)
      #C(1.0l0 6.0f0)
      #C(1.0l0 7.0d0)
      #C(1/2 1/3)
      ))
148

149
(defparameter *numbers*
150
    (append *integers*
sds's avatar
sds committed
151 152 153
            *floats*
            *ratios*
            *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 162
  (loop
    for name in namelist append
sds's avatar
sds committed
163 164 165 166
        (handler-case
            (list (read-from-string
                   (concatenate 'string "\#\\" name)))
          (error () nil))))
167

168
(defparameter *characters*
169 170 171 172
    (remove-duplicates
     `(#\Newline
       #\Space
       ,@(try-to-read-chars "Rubout"
sds's avatar
sds committed
173 174 175 176 177 178
                            "Page"
                            "Tab"
                            "Backspace"
                            "Return"
                            "Linefeed"
                            "Null")
179 180 181 182
       #\a #\A #\0 #\9 #\. #\( #\) #\[ #\]
       )))


183
(defparameter *strings*
184 185
    (append
     (and (code-char 0)
sds's avatar
sds committed
186 187 188
          (list
           (make-string 1 :initial-element (code-char 0))
           (make-string 10 :initial-element (code-char 0))))
189 190 191 192 193
     (list
      "" "A" "a" "0" "abcdef"
      "~!@#$%^&*()_+`1234567890-=<,>.?/:;\"'{[}]|\\ abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWYXZ"
      (make-string 100000 :initial-element #\g)
      (let ((s (make-string 256)))
sds's avatar
sds committed
194 195 196 197 198 199
        (loop
            for i from 0 to 255
            do (let ((c (code-char i)))
                 (when c
                   (setf (elt s i) c))))
        s)
200 201
      ;; Specialized strings
      (make-array 3
sds's avatar
sds committed
202 203 204 205
                  :element-type 'character
                  :displaced-to (make-array 5 :element-type 'character
                                            :initial-contents "abcde")
                  :displaced-index-offset 1)
206
      (make-array 10 :initial-element #\x
sds's avatar
sds committed
207 208
                  :fill-pointer 5
                  :element-type 'character)
209
      (make-array 10 :initial-element #\x
sds's avatar
sds committed
210
                  :element-type 'base-char)
211
      (make-array 3 :initial-element #\y
sds's avatar
sds committed
212 213
                  :adjustable t
                  :element-type 'base-char)
214
      )))
215

216
(defparameter *conses*
217 218 219 220 221
    (list
     (list 'a 'b)
     (list nil)
     (list 1 2 3 4 5 6)))

222
(defparameter *circular-conses*
223 224 225 226 227 228 229 230 231 232 233
    (list
     (let ((s (copy-list '(a b c d))))
       (nconc s s)
       s)
     (let ((s (list nil)))
       (setf (car s) s)
       s)
     (let ((s (list nil)))
       (setf (car s) s)
       (setf (cdr s) s))))

234 235 236
(defparameter *booleans* '(nil t))
(defparameter *keywords* '(:a :b :|| :|a| :|1234|))
(defparameter *uninterned-symbols*
237
  (list '#:nil '#:t '#:foo '#:||))
238
(defparameter *cl-test-symbols*
239 240 241
    `(,(intern "a" :cl-test)
      ,(intern "" :cl-test)
      ,@(and (code-char 0)
sds's avatar
sds committed
242
             (list (intern (make-string 1 :initial-element (code-char 0)) :cl-test)))
243
      ,@(and (code-char 0)
sds's avatar
sds committed
244 245 246 247 248 249 250 251 252 253
             (let* ((s (make-string 10 :initial-element (code-char 0)))
                    (s2 (copy-seq s))
                    (s3 (copy-seq s)))
               (setf (subseq s 3 4) "a")
               (setf (subseq s2 4 5) "a")
               (setf (subseq s3 4 5) "a")
               (setf (subseq s3 7 8) "b")
               (list (intern s :cl-test)
                     (intern s2 :cl-test)
                     (intern s3 :cl-test))))
254 255
      ))

256
(defparameter *cl-user-symbols*
257 258 259 260 261 262
  '(cl-user::foo
    cl-user::x
    cl-user::cons
    cl-user::lambda
    cl-user::*print-readably*
    cl-user::push))
sds's avatar
sds committed
263

264
(defparameter *symbols*
265
    (append *booleans* *keywords* *uninterned-symbols*
sds's avatar
sds committed
266 267
            *cl-test-symbols*
            *cl-user-symbols*))
268

269
(defparameter *array-dimensions*
270
    (loop
271
        for i from 0 below (min array-rank-limit 8) collect
sds's avatar
sds committed
272
          (loop for j from 1 to i collect 2)))
273

274
(defparameter *default-array-target* (make-array '(300)))
275

276
(defparameter *arrays*
277 278 279
    (append
     (list (make-array '10))
     (mapcar #'make-array *array-dimensions*)
sds's avatar
sds committed
280

281 282
     ;; typed arrays
     (loop for tp in '(fixnum float bit character base-char
sds's avatar
sds committed
283 284 285 286 287 288 289
                       (signed-byte 8) (unsigned-byte 8))
           for element in '(18 16.0f0 0 #\x #\y 127 200)
         append
           (loop
               for d in *array-dimensions*
               collect (make-array d :element-type tp
                                   :initial-element element)))
290

291 292
     ;; More typed arrays
     (loop for i from 1 to 64
sds's avatar
sds committed
293 294 295 296 297
           append
           (list (make-array 10 :element-type `(unsigned-byte ,i)
                             :initial-element 1)
                 (make-array 10 :element-type `(signed-byte ,i)
                             :initial-element 0)))
298

299 300 301
     ;; adjustable arrays
     (loop
       for d in *array-dimensions*
sds's avatar
sds committed
302
         collect (make-array d :adjustable t))
303 304 305 306 307 308

     ;; Displaced arrays
     (loop
      for d in *array-dimensions*
      for i from 1
      collect (make-array d :displaced-to *default-array-target*
sds's avatar
sds committed
309
                          :displaced-index-offset i))
310 311 312 313 314

     (list
      #()
      #*
      #*00000
315 316
      #*1010101010101101
      (make-array 10 :element-type 'bit
sds's avatar
sds committed
317 318
                  :initial-contents '(0 1 1 0 1 1 1 1 0 1)
                  :fill-pointer 8)
319
      (make-array 5 :element-type 'bit
sds's avatar
sds committed
320 321
                  :displaced-to #*0111000110
                  :displaced-index-offset 3)
322
      (make-array 10 :element-type 'bit
sds's avatar
sds committed
323 324
                  :initial-contents '(1 1 0 0 1 1 1 0 1 1)
                  :adjustable t)
325
      )
326 327 328 329

     ;; Integer arrays
     (list
      (make-array '(10) :element-type '(integer 0 (256))
sds's avatar
sds committed
330
                  :initial-contents '(8 9 10 11 12 1 2 3 4 5))
331
      (make-array '(10) :element-type '(integer -128 (128))
sds's avatar
sds committed
332
                  :initial-contents '(8 9 -10 11 -12 1 -2 -3 4 5))
333
      (make-array '(6) :element-type '(integer 0 (#.(ash 1 16)))
sds's avatar
sds committed
334
                  :initial-contents '(5 9 100 1312 23432 87))
335
      (make-array '(4) :element-type '(integer 0 (#.(ash 1 28)))
sds's avatar
sds committed
336
                  :initial-contents '(100000 231213 8123712 19))
337
      (make-array '(4) :element-type '(integer 0 (#.(ash 1 32)))
sds's avatar
sds committed
338 339
                  :initial-contents '(#.(1- (ash 1 32)) 0 872312 10000000))

340
      (make-array nil :element-type '(integer 0 (256))
sds's avatar
sds committed
341
                  :initial-element 14)
342
      (make-array '(2 2) :element-type '(integer 0 (256))
sds's avatar
sds committed
343
                  :initial-contents '((34 98)(14 119)))
344 345 346 347 348
      )

     ;; Float arrays
     (list
      (make-array '(5) :element-type 'short-float
sds's avatar
sds committed
349
                  :initial-contents '(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0))
350
      (make-array '(5) :element-type 'single-float
sds's avatar
sds committed
351
                  :initial-contents '(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0))
352
      (make-array '(5) :element-type 'double-float
sds's avatar
sds committed
353
                  :initial-contents '(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0))
354
      (make-array '(5) :element-type 'long-float
sds's avatar
sds committed
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))
sds's avatar
sds committed
360 361 362
              (handler-case
               (list (make-array '(0) :element-type nil))
               (error () nil)))
363

364
     ;; more kinds of arrays here later?
365 366
     ))

367
(defparameter *hash-tables*
368 369 370 371 372
  (list
   (make-hash-table)
   (make-hash-table :test #'eq)
   (make-hash-table :test #'eql)
   (make-hash-table :test #'equal)
373
   #-(or CMU ECL) (make-hash-table :test #'equalp)
374
   ))
375

376
(defparameter *pathnames*
377 378
  (locally
   (declare (optimize safety))
379
   (loop for form in '((make-pathname :name "foo")
sds's avatar
sds committed
380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395
                       (make-pathname :name "FOO" :case :common)
                       (make-pathname :name "bar")
                       (make-pathname :name "foo" :type "txt")
                       (make-pathname :name "bar" :type "txt")
                       (make-pathname :name "XYZ" :type "TXT" :case :common)
                       (make-pathname :name nil)
                       (make-pathname :name :wild)
                       (make-pathname :name nil :type "txt")
                       (make-pathname :name :wild :type "txt")
                       (make-pathname :name :wild :type "TXT" :case :common)
                       (make-pathname :name :wild :type "abc" :case :common)
                       (make-pathname :directory :wild)
                       (make-pathname :type :wild)
                       (make-pathname :version :wild)
                       (make-pathname :version :newest))
         append (ignore-errors (eval `(list ,form))))))
396 397

(eval-when (:compile-toplevel :load-toplevel :execute)
398 399 400 401
  (locally
   (declare (optimize safety))
   (ignore-errors
     (setf (logical-pathname-translations "CLTESTROOT")
402 403 404 405
           `(("**;*.*.*" ,(merge-pathnames
                           "sandbox/"
                           (make-pathname :directory '(:absolute :wild-inferiors)
                                          :name :wild :type :wild))))))
406 407
   (ignore-errors
     (setf (logical-pathname-translations "CLTEST")
408 409 410 411 412 413 414 415
           `(("**;*.*.*" ,(merge-pathnames
                           "sandbox/"
                           (make-pathname
                            :directory (append
                                        (pathname-directory
                                         (truename (make-pathname)))
                                        '(:wild-inferiors))
                            :name :wild :type :wild))))))
416
   ))
417 418

(defparameter *logical-pathnames*
419 420 421 422 423
  (locally
   (declare (optimize safety))
   (append
    (ignore-errors (list (logical-pathname "CLTESTROOT:")))
    )))
424

425
(defparameter *streams*
426 427 428 429 430 431 432 433 434 435 436
  (remove-duplicates
   (remove-if
    #'null
    (list
     *debug-io*
     *error-output*
     *query-io*
     *standard-input*
     *standard-output*
     *terminal-io*
     *trace-output*))))
437

438
(defparameter *readtables*
439
  (list *readtable*
sds's avatar
sds committed
440
        (copy-readtable)))
441 442 443 444 445 446 447

(defstruct foo-structure
  x y z)

(defstruct bar-structure
  x y z)

448
(defparameter *structures*
449 450 451 452 453
  (list
   (make-foo-structure :x 1 :y 'a :z nil)
   (make-foo-structure :x 1 :y 'a :z nil)
   (make-bar-structure :x 1 :y 'a :z nil)
   ))
454

455 456 457 458
(defun meaningless-user-function-for-universe (x y z)
  (list (+ x 1) (+ y 2) (+ z 3)))

(defgeneric meaningless-user-generic-function-for-universe (x y z)
459
  #+(or (not :gcl) :ansi-cl) (:method ((x integer) (y integer) (z integer)) (+ x y z)))
460

461
(eval-when (:load-toplevel :execute)
462
  (compile 'meaningless-user-function-for-universe)
463
  ;; Conditionalize to avoid a cmucl bug
464
  #-(or cmu gcl ecl) (compile 'meaningless-user-generic-function-for-universe)
465 466
  )

467
(defparameter *functions*
468
  (list #'cons #'car #'append #'values
sds's avatar
sds committed
469 470 471 472 473
        (macro-function 'cond)
        #'meaningless-user-function-for-universe
        #'meaningless-user-generic-function-for-universe
        #'(lambda (x) x)
        (compile nil '(lambda (x) x))))
474

475
(defparameter *methods*
476
  (list
477
   #+(or (not :gcl) :ansi-cl )
478
   (find-method #'meaningless-user-generic-function-for-universe nil
sds's avatar
sds committed
479
                (mapcar #'find-class '(integer integer integer)))
480
   ;; Add more methods here
481
   ))
sds's avatar
sds committed
482

483

484
(defparameter *random-states*
485 486
  (list (make-random-state)))

487
(defparameter *universe*
488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507
  (remove-duplicates
   (append
    *symbols*
    *numbers*
    *characters*
    (mapcar #'copy-seq *strings*)
    *conses*
    *condition-objects*
    *package-objects*
    *arrays*
    *hash-tables*
    *pathnames*
    *logical-pathnames*
    *streams*
    *readtables*
    *structures*
    *functions*
    *random-states*
    *methods*
    nil)))
508

509
(defparameter *mini-universe*
pfdietz's avatar
pfdietz committed
510
  (remove-duplicates
511 512
   (append
    (mapcar #'first
sds's avatar
sds committed
513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529
            (list *symbols*
                  *numbers*
                  *characters*
                  (list (copy-seq (first *strings*)))
                  *conses*
                  *condition-objects*
                  *package-objects*
                  *arrays*
                  *hash-tables*
                  *pathnames*
                  *logical-pathnames*
                  *streams*
                  *readtables*
                  *structures*
                  *functions*
                  *random-states*
                  *methods*))
530 531
    '(;;; Others to fill in gaps
      1.2s0 1.3f0 1.5d0 1.8l0 3/5 10000000000000000000000))))
pfdietz's avatar
pfdietz committed
532 533 534 535 536 537

(defparameter *classes*
  (remove-duplicates (mapcar #'class-of *universe*)))

(defparameter *built-in-classes*
  (remove-if-not #'(lambda (x) (typep x 'built-in-class))
sds's avatar
sds committed
538
                 *classes*))