Commit bdcbeb73 authored by pfdietz's avatar pfdietz

More array tests.

parent f5011697
......@@ -71,6 +71,22 @@
;;; lisp objects used when stimulating things in various tests.
(declaim (special *universe*))
;;; The function EMPIRICAL-SUBTYPEP checks two types
;;; for subtypeness, first using SUBTYPEP*, then (if that
;;; fails) empirically against all the elements of *universe*,
;;; checking if all that are in the first are also in the second.
;;; Return T if this is the case, NIL otherwise. This will
;;; always return T if type1 is truly a subtype of type2,
;;; but may return T even if this is not the case.
(defun empirical-subtypep (type1 type2)
(multiple-value-bind (sub good)
(subtypep* type1 type2)
(if good
sub
(loop for e in *universe*
always (or (not (typep e type1)) (typep e type2))))))
(defun check-type-predicate (P TYPE)
"Check that a predicate P is the same as #'(lambda (x) (typep x TYPE))
by applying both to all elements of *UNIVERSE*. Print message
......@@ -973,14 +989,14 @@ the condition to go uncaught if it cannot be classified."
(let ((num 0))
(declare (fixnum num))
(do-symbols (s p num)
(declare (ignore s))
s
(incf num))))
(defun num-external-symbols-in-package (p)
(let ((num 0))
(declare (fixnum num))
(do-external-symbols (s p num)
(declare (ignore s))
s
(incf num))))
(defun safely-delete-package (package-designator)
......
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Wed Jan 22 21:17:25 2003
;;;; Contains: Misc. tests of array features
(in-package :cl-test)
(deftest array-dimension-limit.1
(and (<= 1024 array-dimension-limit) t)
t)
(deftest array-dimension-limit.2
(and (typep array-dimension-limit 'fixnum) t)
t)
(deftest array-total-size-limit.1
(and (<= 1024 array-total-size-limit) t)
t)
(deftest array-total-size-limit.2
(and (typep array-total-size-limit 'fixnum) t)
t)
(deftest array-rank-limit.1
(and (<= 8 array-rank-limit) t)
t)
(deftest array-rank-limit.2
(and (typep array-rank-limit 'fixnum) t)
t)
......@@ -140,11 +140,16 @@
(load "array-dimension.lsp")
(load "array-dimensions.lsp")
(load "array-in-bounds-p.lsp")
(load "array-misc.lsp")
(load "array-rank.lsp")
(load "array-row-major-index.lsp")
(load "array-total-size.lsp")
(load "arrayp.lsp")
(load "fill-pointer.lsp")
(load "row-major-aref.lsp")
(load "simple-vector-p.lsp")
(load "svref.lsp")
(load "upgraded-array-element-type.lsp")
;;; Tests of packages
......
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Wed Jan 22 20:16:38 2003
;;;; Contains: Tests of ROW-MAJOR-AREF
(in-package :cl-test)
;;; ROW-MAJOR-AREF is also used by equalp-with-case (see rt/rt.lsp)
(deftest row-major-aref.1
(loop for i from 0 to 5 collect (row-major-aref #(a b c d e f) i))
(a b c d e f))
(deftest row-major-aref.2
(loop for i from 0 to 5 collect (row-major-aref #2a((a b c d)(e f g h)) i))
(a b c d e f))
(deftest row-major-aref.3
(row-major-aref #0a100 0)
100)
(deftest row-major-aref.4
(loop for i from 0 to 5 collect (row-major-aref #*011100 i))
(0 1 1 1 0 0))
(deftest row-major-aref.5
(loop for i from 0 to 5 collect (row-major-aref "abcdef" i))
(#\a #\b #\c #\d #\e #\f))
(deftest row-major-aref.6
(let ((a (make-array nil :initial-element 'x)))
(values
(aref a)
(setf (row-major-aref a 0) 'y)
(aref a)
a))
x y y #0ay)
(deftest row-major-aref.7
(let ((a (make-array '(4) :initial-element 'x)))
(values
(aref a 0)
(aref a 1)
(aref a 2)
(aref a 3)
(setf (row-major-aref a 0) 'a)
(setf (row-major-aref a 1) 'b)
(setf (row-major-aref a 2) 'c)
a))
x x x x a b c #(a b c x))
(deftest row-major-aref.8
(let ((a (make-array '(4) :element-type 'base-char
:initial-element #\x)))
(values
(aref a 0)
(aref a 1)
(aref a 2)
(aref a 3)
(setf (row-major-aref a 0) #\a)
(setf (row-major-aref a 1) #\b)
(setf (row-major-aref a 2) #\c)
a))
#\x #\x #\x #\x #\a #\b #\c "abcx")
(deftest row-major-aref.9
(let ((a (make-array '(4) :initial-element 0
:element-type 'bit)))
(values
(aref a 0)
(aref a 1)
(aref a 2)
(aref a 3)
(setf (row-major-aref a 0) 1)
(setf (row-major-aref a 1) 1)
(setf (row-major-aref a 3) 1)
a))
0 0 0 0 1 1 1 #*1101)
(deftest row-major-aref.10
(let ((a (make-array '(2 3 4)
:initial-contents '(((a b c d)(e f g h)(i j k l))
((m n o p)(q r s t)(u v w x))))))
(loop for i from 0 to 23 collect (row-major-aref a i)))
(a b c d e f g h i j k l m n o p q r s t u v w x))
;;; Error tests
(deftest row-major-aref.error.1
(classify-error (row-major-aref))
program-error)
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Wed Jan 22 21:23:45 2003
;;;; Contains: Tests for SIMPLE-VECTOR-P
(in-package :cl-test)
;;; More tests for this are in make-array.lsp
(deftest simple-vector-p.1
(loop for e in *universe*
unless (if (typep e 'simple-vector)
(simple-vector-p e)
(not (simple-vector-p e)))
collect e)
nil)
(deftest simple-vector-p.2
(notnot (simple-vector-p (make-array '(10))))
t)
(deftest simple-vector-p.3
(simple-vector-p (make-array '(5) :fill-pointer t))
nil)
(deftest simple-vector-p.4
(notnot (simple-vector-p (vector 'a 'b 'c)))
t)
(deftest simple-vector-p.5
(simple-vector-p (make-array '(5) :adjustable t))
nil)
(deftest simple-vector-p.6
(let ((a #(a b c d e g h)))
(simple-vector-p (make-array '(5) :displaced-to a)))
nil)
(deftest simple-vector-p.7
(simple-vector-p #*001101)
nil)
(deftest simple-vector-p.8
(simple-vector-p "abcdef")
nil)
(deftest simple-vector-p.9
(simple-vector-p (make-array nil))
nil)
(deftest simple-vector-p.10
(simple-vector-p (make-array '(10) :element-type 'base-char))
nil)
(deftest simple-vector-p.11
(simple-vector-p (make-array '(10) :element-type 'character))
nil)
(deftest simple-vector-p.12
(simple-vector-p (make-array '(10) :element-type 'bit))
nil)
;;; Error tests
(deftest simple-vector-p.error.1
(classify-error (simple-vector-p))
program-error)
(deftest simple-vector-p.error.2
(classify-error (simple-vector-p #(a b) nil))
program-error)
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Wed Jan 22 21:39:30 2003
;;;; Contains: Tests of SVREF
(in-package :cl-test)
(deftest svref.1
(let ((a (vector 1 2 3 4)))
(loop for i below 4 collect (svref a i)))
(1 2 3 4))
(deftest svref.2
(let ((a (vector 1 2 3 4)))
(values
(loop for i below 4
collect (setf (svref a i) (+ i 10)))
a))
(10 11 12 13)
#(10 11 12 13))
;;; Error tests
(deftest svref.error.1
(classify-error (svref))
program-error)
(deftest svref.error.2
(classify-error (svref (vector 1)))
program-error)
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Wed Jan 22 20:43:55 2003
;;;; Contains: Tests of UPGRADED-ARRAY-ELEMENT-TYPE
(in-package :cl-test)
(deftest upgraded-array-element-type.1
(let ((upgraded-bit (upgraded-array-element-type 'bit)))
(and (empirical-subtypep 'bit upgraded-bit)
(empirical-subtypep upgraded-bit 'bit)))
t)
(deftest upgraded-array-element-type.2
(let ((upgraded-base-char (upgraded-array-element-type 'base-char)))
(and (empirical-subtypep 'base-char upgraded-base-char)
(empirical-subtypep upgraded-base-char 'base-char)))
t)
(deftest upgraded-array-element-type.3
(let ((upgraded-character (upgraded-array-element-type 'character)))
(and (empirical-subtypep 'character upgraded-character)
(empirical-subtypep upgraded-character 'character)))
t)
(defparameter *upgraded-array-types-to-check*
`(boolean
base-char
character
t
,@(loop for i from 0 to 32
collect `(integer 0 (,(ash 1 i))))
symbol
,@(loop for i from 0 to 32
collect `(integer ,(- (ash 1 i)) (,(ash 1 i))))
(integer -10000000000000000000000000000000000
10000000000000000000000000000000000)
float
single-float
double-float
complex
rational
fixnum
function
sequence
list
cons
atom
symbol))
(deftest upgraded-array-element-type.4
(loop for type in *upgraded-array-types-to-check*
for upgraded-type = (upgraded-array-element-type type)
always (empirical-subtypep type upgraded-type))
t)
;; Include an environment (NIL, denoting the default null lexical
;; environment)
(deftest upgraded-array-element-type.5
(loop for type in *upgraded-array-types-to-check*
for upgraded-type = (upgraded-array-element-type type nil)
always (empirical-subtypep type upgraded-type))
t)
;;; Error tests
(deftest upgraded-array-element-type.error.1
(classify-error (upgraded-array-element-type))
program-error)
(deftest upgraded-array-element-type.error.2
(classify-error (upgraded-array-element-type 'bit nil nil))
program-error)
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment