Commit 2a376817 authored by pfdietz's avatar pfdietz

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))))
This diff is collapsed.
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Wed Apr 8 20:05:24 1998
;;;; Contains: Test cases for CL, section 14.1 of CLtL2, Lists as Sequences
(in-package :cl-test)
(use-package :rt)
(declaim (optimize (safety 3)))
(defun safe-elt (x n)
(handler-case
(elt x n)
(type-error () 'type-error)
(error (c) c)))
;; elt on lists
(deftest elt-1 (safe-elt nil 0) type-error)
(deftest elt-1a (safe-elt nil -10) type-error)
(deftest elt-2 (safe-elt nil 1000000) type-error)
(deftest elt-3 (safe-elt '(a b c d e) 0) a)
(deftest elt-4 (safe-elt '(a b c d e) 2) c)
(deftest elt-5 (safe-elt '(a b c d e) 4) e)
(deftest elt-5a (safe-elt '(a b c d e) -4) type-error)
(deftest elt-6
(let ((x (make-int-list 1000)))
(not (not
(every
#'(lambda (i)
(eql i (safe-elt x i)))
x))))
t)
(deftest elt-7
(let* ((x (list 'a 'b 'c 'd))
(y (setf (elt x 0) 'e)))
(list x y))
((e b c d) e))
(deftest elt-8
(let* ((x (list 'a 'b 'c 'd))
(y (setf (elt x 1) 'e)))
(list x y))
((a e c d) e))
(deftest elt-9
(let* ((x (list 'a 'b 'c 'd))
(y (setf (elt x 3) 'e)))
(list x y))
((a b c e) e))
(deftest elt-10
(handler-case
(let ((x (list 'a 'b 'c)))
(setf (elt x 4) 'd))
(type-error () 'type-error)
(error (c) c))
type-error)
(deftest elt-11
(let ((x (list 'a 'b 'c 'd 'e)))
(let ((y (loop for c on x collect c)))
(setf (elt x 2) 'f)
(not
(not
(every #'eq
y
(loop for c on x collect c))))))
t)
(deftest elt-12
(let ((x (make-int-list 100000)))
(safe-elt x 90000))
90000)
(deftest elt-13
(let ((x (make-int-list 100000)))
(setf (elt x 80000) 'foo)
(list (safe-elt x 79999)
(safe-elt x 80000)
(safe-elt x 80001)))
(79999 foo 80001))
;; Special case to test error handling as dictated by new
;; CL standard
(deftest elt-14
(let ((x (list 'a 'b 'c)))
(safe-elt x 10))
type-error)
(deftest elt-15
(let ((x (list 'a 'b 'c)))
(safe-elt x 'a))
type-error)
(deftest elt-16
(let ((x (list 'a 'b 'c)))
(safe-elt x 10.0))
type-error)
(deftest elt-17
(let ((x (list 'a 'b 'c)))
(safe-elt x -1))
type-error)
(deftest elt-18
(let ((x (list 'a 'b 'c)))
(safe-elt x -100000000000000000))
type-error)
(deftest elt-19
(let ((x (list 'a 'b 'c)))
(safe-elt x #\w))
type-error)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; subseq, on lists
(deftest subseq-list-1
(subseq '(a b c d e) 0 0)
nil)
(deftest subseq-list-2
(subseq '(a b c) 0)
(a b c))
(deftest subseq-list-3
(subseq '(a b c) 1)
(b c))
(defun subseq-list-4-body ()
(block done
(let ((x (loop for i from 0 to 19 collect i)))
(loop
for i from 0 to 20 do
(loop
for j from i to 20 do
(let ((y (subseq x i j)))
(loop
for e in y and k from i to (1- j) do
(unless (eql e k) (return-from done nil)))))))
t))
(deftest subseq-list-4
(subseq-list-4-body)
t)
(defun subseq-list-5-body ()
(block done
(let ((x (loop for i from 0 to 29 collect i)))
(loop
for i from 0 to 30 do
(unless (equal (subseq x i)
(loop for j from i to 29 collect j))
(return-from done nil))))
t))
(deftest subseq-list-5
(subseq-list-5-body)
t)
(defun subseq-list-6-body ()
(let* ((x (make-list 100))
(z (loop for e on x collect e))
(y (subseq x 0)))
(loop
for e on x
and f on y
and g in z do
(when (or (not (eq g e))
(not (eql (car e) (car f)))
(car e)
(eq e f))
(return nil))
finally (return t))))
(deftest subseq-list-6 ;; check that no structure is shared
(subseq-list-6-body)
t)
(deftest subseq-list-7
(let ((x (loop for i from 0 to 9 collect i)))
(setf (subseq x 0 3) (list 'a 'b 'c))
x)
(a b c 3 4 5 6 7 8 9))
(deftest subseq-list-8
(let* ((x '(a b c d e))
(y (copy-seq x)))
(setf (subseq y 0) '(f g h))
(list x y))
((a b c d e) (f g h d e)))
(deftest subseq-list-9
(let* ((x '(a b c d e))
(y (copy-seq x)))
(setf (subseq y 1 3) '(1 2 3 4 5))
(list x y))
((a b c d e) (a 1 2 d e)))
(deftest subseq-list-10
(let* ((x '(a b c d e))
(y (copy-seq x)))
(setf (subseq y 5) '(1 2 3 4 5))
(list x y))
((a b c d e) (a b c d e)))
(deftest subseq-list-11
(let* ((x '(a b c d e))
(y (copy-seq x)))
(setf (subseq y 2 5) '(1))
(list x y))
((a b c d e) (a b 1 d e)))
(deftest subseq-list-12
(let* ((x '(a b c d e))
(y (copy-seq x)))
(setf (subseq y 0 0) '(1 2))
(list x y))
((a b c d e) (a b c d e)))
;; length of lists
(deftest length-list-1
(length ())
0)
(deftest length-list-2
(length '(a b c d e f g))
7)
(deftest length-list-3
(length (make-list 200000))
200000)
(defun length-list-4-body ()
(let ((x ()))
(loop
for i from 0 to 999 do
(progn
(unless (eql (length x) i) (return nil))
(push i x))
finally (return t))))
(deftest length-list-4
(length-list-4-body)
t)
;; reverse of lists
(deftest reverse-list-1
(reverse ())
())
(deftest reverse-list-2
(reverse '(a b c d e f))
(f e d c b a))
(defun reverse-list-3-body ()
(let* ((x (loop for i from 0 to 999 collect i))
(z (loop for e on x collect e))
(y (reverse x)))
(and
(loop
for e on x and f in z do
(unless (eq e f) (return nil))
finally (return t))
(every #'eql
y
(loop for i from 999 downto 0 collect i)))))
(deftest reverse-list-3
(reverse-list-3-body)
t)
(deftest nreverse-list-1
(nreverse nil)
nil)
(deftest nreverse-list-2
(nreverse (list 'a))
(a))
(deftest nreverse-list-3
(nreverse (list 'a 'b 'c 'd))
(d c b a))
(defun nreverse-list-4-body ()
(let* ((x (loop for i from 0 to 100000 collect i))
(y (copy-seq x)))
(equal y (nreverse (nreverse x)))))
(deftest nreverse-list-4
(nreverse-list-4-body)
t)
(deftest make-sequence-list-1
(make-sequence 'list 0)
nil)
(deftest make-sequence-list-2
(make-sequence 'list 5 :initial-element 'g)
(g g g g g))
(deftest make-sequence-list-3
(length (make-sequence 'list 100))
100)
(deftest make-sequence-list-4
(length (make-sequence 'list 123456))
123456)
(deftest make-sequence-list-5
(let ((x (make-sequence 'list 1000)))
(every #'(lambda (e) (eq (car x) e)) (cdr x)))
t)
This diff is collapsed.
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Sat Mar 14 10:13:21 1998
;;;; Contains: CL test case package definition
(defpackage :cl-test
(:use :cl :rt)
#+gcl (:use defpackage)
(:nicknames)
(:import-from "COMMON-LISP-USER" "COMPILE-AND-LOAD")
(:export))
#+cmu (import 'cl::quit :cl-test)
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Fri Mar 27 09:57:28 1998
;;;; Contains: MK portable system file for CL test suite
(mk::defsystem "cltest"
:source-pathname #.(directory-namestring *LOAD-TRUENAME*)
:source-extension "lsp"
:binary-pathname #.(mk::append-directories
(directory-namestring *LOAD-TRUENAME*)
"binary/")
:binary-extension
#+CMU #.(C::BACKEND-FASL-FILE-TYPE C::*TARGET-BACKEND*)
#+ALLEGRO "fasl"
#+(OR AKCL GCL) "o"
:initially-do (progn (load "rt/rt.system")
(mk::compile-system "rt"))
:components
("cl-test-package"
(:subsystem "cl-test-code"
:source-pathname ""
:binary-pathname ""
:depends-on ("cl-test-package")
:components
(
"aux"
"universe"
"cons-test-01"
"cons-test-02"
"cons-test-03"
"cons-test-04"
"cons-test-05"
"cons-test-06"
"cons-test-07"
"cons-test-08"
"cons-test-09"
"cons-test-10"
"cons-test-11"
"cons-test-12"
"cons-test-13"
"cons-test-14"
"cons-test-15"
"cons-test-16"
"cons-test-17"
"cons-test-18"
"cons-test-19"
"cons-test-20"
"cons-test-21"
"cons-test-22"
"cons-test-23"
"cons-test-24"
"types-and-class"
"cl-symbols"
"cases-14-1-arrays"
"cases-14-1-list"
"reader-test"
"packages-00"
"packages-01"
"packages-02"
"packages-03"
"packages-04"
"packages-05"
"packages-06"
"packages-07"
"packages-08"
"packages-09"
"packages-10"
"packages-11"
"packages-12"
"packages-13"
"packages-14"
"packages-15"
"packages-16"
"packages-17"
"packages-18"
"fill-strings"
"make-sequence"
"map"
"map-into"
"reduce"
"count"
"count-if"
"count-if-not"
"reverse"
"nreverse"
"sort"
"find"
"find-if"
"find-if-not"
"position"
"search-aux"
"search-list"
"search-vector"
"search-bitvector"
"search-string"
"mismatch"
"replace"
"substitute"
"substitute-if"
"substitute-if-not"
"nsubstitute"
"nsubstitute-if"
"nsubstitute-if-not"
"concatenate"
"merge"
"remove" ;; need to extend these tests
"structure-00"
"structures-01"
"structures-02"
))))
\ No newline at end of file
(in-package "COMMON-LISP-USER")
(eval-when (load eval compile)
(unless (fboundp 'compile-file-pathname)
(defun compile-file-pathname (pathname)
(make-pathname :defaults pathname :type "o"))))
(defun compile-and-load (pathspec)
"Find the file indicated by PATHSPEC, compiling it first if
the associated compiled file is out of date."
(let* ((pathname (pathname pathspec))
(compile-pathname (compile-file-pathname pathname))
(source-write-time (file-write-date pathname))
(target-write-time (and (probe-file compile-pathname)
(file-write-date compile-pathname))))
(when (or (not target-write-time)
(<= target-write-time source-write-time))
(compile-file pathname))
(load compile-pathname)))
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Wed Sep 4 22:53:51 2002
;;;; Contains: Tests for CONCATENATE
(in-package :cl-test)
(deftest concatenate.1
(concatenate 'list)
nil)
(deftest concatenate.2
(let* ((orig (list 'a 'b 'c 'd 'e))
(copy (concatenate 'list orig)))
(values
copy
(intersection (loop for e on orig collect e)
(loop for e on copy collect e)
:test #'eq)))
(a b c d e)
nil)
(deftest concatenate.3
(concatenate 'list "")
nil)
(deftest concatenate.4
(concatenate 'list "abcd" '(x y z) nil #*1101 #())
(#\a #\b #\c #\d x y z 1 1 0 1))