Commit 2a376817 authored by pfdietz's avatar pfdietz
Browse files

Imported the test suite into the gcl development tree.

parent a4327ac0
This directory contains a partial Common Lisp standards compliance
test suite.
To load, edit load.lsp and load it. To run, do this:
(in-package :cl-test)
(do-tests)
From GCL, instead just load gclload.lsp. This will automatically
run the tests.
Individual tests may be run by (do-test '<test name>).
The tests here cover the CONSes, SYMBOLs and PACKAGEs section of the
hyperspec, as well as fragments of other parts (sequences, types,
lists, arrays, structures, the reader). I intend to add tests for the
other parts of the standard. The package tests are currently disabled
in GCL because of a bug in DEFPACKAGE.
When I run this I have a copy of the MK defsystem in the ../defsys30
directory. The .system files use the MK forms (not the defsystem from
ACL). (Note: when gclload.lsp is loaded the defsystem is not used.)
The tar file contains a modified version of the Waters RT regression
test package, which gets installed in subdirectory rt/.
Please tell me when you find incorrect test cases.
There are five test cases that cause very long loops on ACL (ELT-*
tests on type-bogus inputs; I think the system is considering the
pointers to be very large unsigned integers.)
Paul Dietz
dietz@dls.net
(setf x
(loop
for tp in '(CONDITION
SERIOUS-CONDITION
ERROR
TYPE-ERROR
SIMPLE-TYPE-ERROR
SIMPLE-CONDITION
PARSE-ERROR
CELL-ERROR
UNBOUND-SLOT
WARNING
STYLE-WARNING
STORAGE-CONDITION
SIMPLE-WARNING
UNBOUND-VARIABLE
CONTROL-ERROR
PROGRAM-ERROR
UNDEFINED-FUNCTION
PACKAGE-ERROR
ARITHMETIC-ERROR
DIVISION-BY-ZERO
FLOATING-POINT-INVALID-OPERATION
FLOATING-POINT-INEXACT
FLOATING-POINT-OVERFLOW
FLOATING-POINT-UNDERFLOW
FILE-ERROR
BROADCAST-STREAM
CONCATENATED-STREAM
ECHO-STREAM
FILE-STREAM
STRING-STREAM
SYNONYM-STREAM
TWO-WAY-STREAM
STREAM-ERROR
END-OF-FILE
PRINT-NOT-READABLE
READER-ERROR)
collect (list tp (multiple-value-list (subtypep tp 'atom)))))
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Sat Mar 28 17:10:18 1998
;;;; Contains: Aux. functions for CL-TEST
(in-package :cl-test)
(use-package :rt)
(declaim (optimize (safety 3)))
(defun make-int-list (n)
(loop for i from 0 to (1- n) collect i))
(declaim (special *universe*))
(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
when a mismatch is found, and return number of mistakes."
(loop
for x in *universe* count
(block failed
(let ((p1 (handler-case
(funcall P x)
(error () (format t "(FUNCALL ~S ~S) failed~%"
P x)
(return-from failed t))))
(p2 (handler-case
(typep x TYPE)
(error () (format t "(TYPEP ~S '~S) failed~%"
x TYPE)
(return-from failed t)))))
(when (or (and p1 (not p2))
(and (not p1) p2))
(format t "(FUNCALL ~S ~S) = ~S, (TYPEP ~S '~S) = ~S~%"
P x p1 x TYPE p2)
t)))))
(declaim (special *catch-error-type*))
(defun catch-continue-debugger-hook (condition dbh)
"Function that when used as *debugger-hook*, causes
continuable errors to be continued without user intervention."
(declare (ignore dbh))
(let ((r (find-restart 'continue condition)))
(cond
((and *catch-error-type*
(not (typep condition *catch-error-type*)))
(format t "Condition ~S is not a ~A~%" condition *catch-error-type*)
(cond (r (format t "Its continue restart is ~S~%" r))
(t (format t "It has no continue restart~%")))
(throw 'continue-failed nil))
(r (invoke-restart r))
(t (throw 'continue-failed nil)))))
#|
(defun safe (fn &rest args)
"Apply fn to args, trapping errors. Convert type-errors to the
symbol type-error."
(declare (optimize (safety 3)))
(handler-case
(apply fn args)
(type-error () 'type-error)
(error (c) c)))
|#
;; Use the next macro in place of SAFE
(defmacro catch-type-error (form)
"Evaluate form in safe mode, returning its value if there is no error.
If an error does occur, return type-error on TYPE-ERRORs, or the error
condition itself on other errors."
`(locally (declare (optimize (safety 3)))
(handler-case ,form
(type-error () 'type-error)
(error (c) c))))
;;
;; A scaffold is a structure that is used to remember the object
;; identities of the cons cells in a (noncircular) data structure.
;; This lets us check if the data structure has been changed by
;; an operation.
;;
(defstruct scaffold
node
car
cdr)
(defun make-scaffold-copy (x)
"Make a tree that will be used to check if a tree has been changed."
(if
(consp x)
(make-scaffold :node x
:car (make-scaffold-copy (car x))
:cdr (make-scaffold-copy (cdr x)))
(make-scaffold :node x
:car nil
:cdr nil)))
(defun check-scaffold-copy (x xcopy)
"Return t if xcopy were produced from x by make-scaffold-copy,
and none of the cons cells in the tree rooted at x have been
changed."
(and (eq x (scaffold-node xcopy))
(or
(not (consp x))
(and
(check-scaffold-copy (car x) (scaffold-car xcopy))
(check-scaffold-copy (cdr x) (scaffold-cdr xcopy))))))
;;
;; The function SUBTYPEP returns two generalized booleans.
;; This auxiliary function returns two booleans instead
;; (which makes it easier to write tests).
;;
(defun subtypep* (obj type)
(multiple-value-bind (result good)
(subtypep obj type)
(values (not (not result))
(not (not good)))))
(eval-when (load eval compile)
(unless (fboundp 'complement)
(defun complement (fn)
#'(lambda (&rest args) (not (apply fn args))))))
(defun compose (&rest fns)
(let ((rfns (reverse fns)))
#'(lambda (x) (loop for f in rfns do (setf x (funcall f x))) x)))
(defun evendigitp (c)
(not (not (find c "02468"))))
(defun odddigitp (c)
(not (not (find c "13579"))))
(defun nextdigit (c)
(cadr (member c '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))))
(defun is-eq-p (x) #'(lambda (y) (eq x y)))
(defun is-not-eq-p (x) #'(lambda (y) (not (eq x y))))
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Sat Mar 14 09:48:24 1998
;;;; Contains: Test cases for CL, section 17.1
(in-package :cl-test)
(use-package :rt)
(declaim (optimize (safety 3)))
;; elt on ordinary vectors
(defun make-int-array (n &optional (fn #'make-array))
(let ((a (funcall fn n)))
(loop
for i from 0 to (1- n) do
(setf (aref a i) i))
a))
(deftest elt-v-1
(handler-case
(elt (make-array '(0)) 0)
(type-error () 'type-error)
(error (c) c))
type-error)
;; (deftest elt-v-2 (elt (make-array '(1)) 0) nil) ;; actually undefined
(deftest elt-v-3 (elt (make-array '(5) :initial-contents '(a b c d e)) 0)
a)
(deftest elt-v-4 (elt (make-array '(5) :initial-contents '(a b c d e)) 2)
c)
(deftest elt-v-5 (elt (make-array '(5) :initial-contents '(a b c d e)) 4)
e)
(defun elt-v-6-body ()
(let ((x (make-int-list 1000)))
(let ((a (make-array '(1000) :initial-contents x)))
(loop
for i from 0 to 999 do
(unless (eql i (elt a i)) (return nil))
finally (return t)))))
(deftest elt-v-6
(elt-v-6-body)
t)
(deftest elt-v-7
(let* ((x (make-array '(4) :initial-contents (list 'a 'b 'c 'd)))
(y (setf (elt x 0) 'e)))
(list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y))
(e b c d e))
(deftest elt-v-8
(let* ((x (make-array '(4) :initial-contents (list 'a 'b 'c 'd)))
(y (setf (elt x 1) 'e)))
(list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y))
(a e c d e))
(deftest elt-v-9
(let* ((x (make-array '(4) :initial-contents (list 'a 'b 'c 'd)))
(y (setf (elt x 3) 'e)))
(list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y))
(a b c e e))
(deftest elt-v-10
(handler-case
(let ((x (make-array '(3) :initial-contents (list 'a 'b 'c))))
(setf (elt x 4) 'd))
(type-error () 'type-error)
(error (c) c))
type-error)
(deftest elt-v-11
(handler-case
(let ((x (make-array '(3) :initial-contents (list 'a 'b 'c))))
(setf (elt x -100) 'd))
(type-error () 'type-error)
(error (c) c))
type-error)
(deftest elt-v-12
(let ((x (make-int-array 100000)))
(elt x 90000))
90000)
(deftest elt-v-13
(let ((x (make-int-array 100000)))
(setf (elt x 80000) 'foo)
(list (elt x 79999)
(elt x 80000)
(elt x 80001)))
(79999 foo 80001))
;;; Adjustable arrays
(defun make-adj-array (n &key initial-contents)
(if initial-contents
(make-array n :adjustable t :initial-contents initial-contents)
(make-array n :adjustable t)))
(deftest elt-adj-array-1
(handler-case
(elt (make-adj-array '(0)) 0)
(type-error () 'type-error)
(error (c) c))
type-error)
;; (deftest elt-adj-array-2 (elt (make-adj-array '(1)) 0) nil) ;; actually undefined
(deftest elt-adj-array-3 (elt (make-adj-array '(5) :initial-contents '(a b c d e)) 0)
a)
(deftest elt-adj-array-4 (elt (make-adj-array '(5) :initial-contents '(a b c d e)) 2)
c)
(deftest elt-adj-array-5 (elt (make-adj-array '(5) :initial-contents '(a b c d e)) 4)
e)
(defun elt-adj-array-6-body ()
(let ((x (make-int-list 1000)))
(let ((a (make-adj-array '(1000) :initial-contents x)))
(loop
for i from 0 to 999 do
(unless (eql i (elt a i)) (return nil))
finally (return t)))))
(deftest elt-adj-array-6
(elt-adj-array-6-body)
t)
(deftest elt-adj-array-7
(let* ((x (make-adj-array '(4) :initial-contents (list 'a 'b 'c 'd)))
(y (setf (elt x 0) 'e)))
(list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y))
(e b c d e))
(deftest elt-adj-array-8
(let* ((x (make-adj-array '(4) :initial-contents (list 'a 'b 'c 'd)))
(y (setf (elt x 1) 'e)))
(list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y))
(a e c d e))
(deftest elt-adj-array-9
(let* ((x (make-adj-array '(4) :initial-contents (list 'a 'b 'c 'd)))
(y (setf (elt x 3) 'e)))
(list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y))
(a b c e e))
(deftest elt-adj-array-10
(handler-case
(let ((x (make-adj-array '(3) :initial-contents (list 'a 'b 'c))))
(setf (elt x 4) 'd))
(type-error () 'type-error)
(error (c) c))
type-error)
(deftest elt-adj-array-11
(handler-case
(let ((x (make-adj-array '(3) :initial-contents (list 'a 'b 'c))))
(setf (elt x -100) 'd))
(type-error () 'type-error)
(error (c) c))
type-error)
(deftest elt-adj-array-12
(let ((x (make-int-array 100000 #'make-adj-array)))
(elt x 90000))
90000)
(deftest elt-adj-array-13
(let ((x (make-int-array 100000 #'make-adj-array)))
(setf (elt x 80000) 'foo)
(list (elt x 79999)
(elt x 80000)
(elt x 80001)))
(79999 foo 80001))
;; displaced arrays
(defvar *displaced* nil)
(setf *displaced* (make-int-array 100000))
(defun make-displaced-array (n displacement)
(make-array n :displaced-to *displaced*
:displaced-index-offset displacement))
(deftest elt-displaced-array-1
(handler-case
(elt (make-displaced-array '(0) 100) 0)
(type-error () 'type-error)
(error (c) c))
type-error)
(deftest elt-displaced-array-2
(elt (make-displaced-array '(1) 100) 0)
100)
(deftest elt-displaced-array-3
(elt (make-displaced-array '(5) 100) 4)
104)
#|
(deftest elt-displaced-array-4
(handler-case
(make-displaced-array '(100) 100000)
(type-error () 'type-error)
(error (c) c))
type-error)
|#
#|
(deftest elt-displaced-array-5
(handler-case
(make-displaced-array '(100) (- 100000 50))
(type-error () 'type-error)
(error (c) c))
type-error)
|#
;; subseq vectors
(defun subseq-vector-1-body ()
(block nil
(let* ((x (make-sequence 'vector 10 :initial-element 'a))
(y (subseq x 4 8)))
(unless (every #'(lambda (e) (eq e 'a)) x)
(return 1))
(unless (every #'(lambda (e) (eq e 'a)) y)
(return 2))
(unless (eql (length x) 10) (return 3))
(unless (eql (length y) 4) (return 4))
(loop for i from 0 to 9 do (setf (aref x i) 'b))
(unless (every #'(lambda (e) (eq e 'a)) y)
(return 5))
(loop for i from 0 to 3 do (setf (aref y i) 'c))
(or
(not (not (every #'(lambda (e) (eq e 'b)) x)))
6))))
(deftest subseq-vector-1
(subseq-vector-1-body)
t)
(defun subseq-vector-2-body ()
(block nil
(let* ((x (make-sequence '(vector fixnum) 10 :initial-element 1))
(y (subseq x 4 8)))
(unless (every #'(lambda (e) (eql e 1)) x)
(return 1))
(unless (every #'(lambda (e) (eql e 1)) y)
(return 2))
(unless (eql (length x) 10) (return 3))
(unless (eql (length y) 4) (return 4))
(loop for i from 0 to 9 do (setf (aref x i) 2))
(unless (every #'(lambda (e) (eql e 1)) y)
(return 5))
(loop for i from 0 to 3 do (setf (aref y i) 3))
(or
(not (not (every #'(lambda (e) (eql e 2)) x)))
6))))
(deftest subseq-vector-2
(subseq-vector-2-body)
t)
(defun subseq-vector-3-body ()
(block nil
(let* ((x (make-sequence '(vector single-float) 10 :initial-element 1.0))
(y (subseq x 4 8)))
(unless (every #'(lambda (e) (= e 1.0)) x)
(return 1))
(unless (every #'(lambda (e) (= e 1.0)) y)
(return 2))
(unless (eql (length x) 10) (return 3))
(unless (eql (length y) 4) (return 4))
(loop for i from 0 to 9 do (setf (aref x i) 2.0))
(unless (every #'(lambda (e) (= e 1.0)) y)
(return 5))
(loop for i from 0 to 3 do (setf (aref y i) 3.0))
(or
(not (not (every #'(lambda (e) (= e 2.0)) x)))
6))))
(deftest subseq-vector-3
(subseq-vector-3-body)
t)
(defun subseq-vector-4-body ()
(block nil
(let* ((x (make-sequence '(vector double-float) 10 :initial-element 1.0d0))
(y (subseq x 4 8)))
(unless (every #'(lambda (e) (= e 1.0)) x)
(return 1))
(unless (every #'(lambda (e) (= e 1.0)) y)
(return 2))
(unless (eql (length x) 10) (return 3))
(unless (eql (length y) 4) (return 4))
(loop for i from 0 to 9 do (setf (aref x i) 2.0d0))
(unless (every #'(lambda (e) (= e 1.0)) y)
(return 5))
(loop for i from 0 to 3 do (setf (aref y i) 3.0d0))
(or
(not (not (every #'(lambda (e) (= e 2.0)) x)))
6))))
(deftest subseq-vector-4
(subseq-vector-4-body)
t)
(defun subseq-vector-5-body ()
(block nil
(let* ((x (make-sequence '(vector short-float) 10 :initial-element 1.0s0))
(y (subseq x 4 8)))
(unless (every #'(lambda (e) (= e 1.0)) x)
(return 1))
(unless (every #'(lambda (e) (= e 1.0)) y)
(return 2))
(unless (eql (length x) 10) (return 3))
(unless (eql (length y) 4) (return 4))
(loop for i from 0 to 9 do (setf (aref x i) 2.0s0))
(unless (every #'(lambda (e) (= e 1.0)) y)
(return 5))
(loop for i from 0 to 3 do (setf (aref y i) 3.0s0))
(or
(not (not (every #'(lambda (e) (= e 2.0)) x)))
6))))
(deftest subseq-vector-5
(subseq-vector-5-body)
t)
(defun subseq-vector-6-body ()
(block nil
(let* ((x (make-sequence '(vector long-float) 10 :initial-element 1.0l0))
(y (subseq x 4 8)))
(unless (every #'(lambda (e) (= e 1.0)) x)
(return 1))
(unless (every #'(lambda (e) (= e 1.0)) y)
(return 2))
(unless (eql (length x) 10) (return 3))
(unless (eql (length y) 4) (return 4))
(loop for i from 0 to 9 do (setf (aref x i) 2.0l0))
(unless (every #'(lambda (e) (= e 1.0)) y)
(return 5))
(loop for i from 0 to 3 do (setf (aref y i) 3.0l0))
(or
(not (not (every #'(lambda (e) (= e 2.0)) x)))
6))))
(deftest subseq-vector-6
(subseq-vector-6-body)
t)
(deftest copy-seq-vector-1
(let* ((x (make-array '(10) :initial-contents '(a b c d e f g h i j)))
(y (copy-seq x)))
(equal-array x y))
t)
(deftest subseq-vector-7
(let* ((x (make-array '(10) :initial-contents '(a b c d e f g h i j)))
(y (subseq x 2 8)))
(equal-array y (make-array '(6) :initial-contents '(c d e f g h))))
t)
(deftest subseq-vector-8
(let* ((x (make-array '(200) :initial-element 107
:element-type 'fixnum))
(y (subseq x 17 95)))
(and (eql (length y) (- 95 17))
(equal-array y
(make-array (list (- 95 17))
:initial-element 107
:element-type 'fixnum))))
t)
(deftest subseq-vector-9
(let* ((x (make-array '(1000) :initial-element 17.6e-1
:element-type 'single-float))
(lo 164)
(hi 873)
(y (subseq x lo hi)))
(and (eql (length y) (- hi lo))
(equal-array y
(make-array (list (- hi lo))
:initial-element 17.6e-1
:element-type 'single-float))))
t)
(deftest subseq-vector-10
(let* ((x (make-array '(2000) :initial-element 3.1415927d4
:element-type 'double-float))
(lo 731)
(hi 1942)
(y (subseq x lo hi)))
(and (eql (length y) (- hi lo))
(equal-array y
(make-array (list (- hi lo))
:initial-element 3.1415927d4
:element-type 'double-float))))
t)
;; array reversal
(defun equal-array (a1 a2)
(and (typep a1 'array)
(typep a2 'array)
(= (array-rank a1) (array-rank a2))
(let ((ad (array-dimensions a1)))
(and (equal ad (array-dimensions a2))
(let ((as (array-total-size a1)))
(and (= as (array-total-size a2))
(loop
for i from 0 to (1- as) do
(unless (equal (row-major-aref a1 i)
(row-major-aref a2 i))
(return nil))
finally (return t))))))))
;; array length
(deftest array-length-1
(length (make-array '(20)))
20)
(deftest array-length-2
(length (make-array '(100001)))
100001)
(deftest array-length-3
(length (make-array '(0)))
0)