Commit 7a23cd5a authored by pfdietz's avatar pfdietz

Added note objects and logic for disabling tests with disabled notes. Still...

Added note objects and logic for disabling tests with disabled notes.  Still need to add printing of note names when tests fail.  Changed eval-when to avoid annoying style warnings.
parent 683662bb
......@@ -12,3 +12,12 @@ Please tell me when you find incorrect test cases.
Paul Dietz
dietz@dls.net
--------------------------------
(30 Jun 2003) I've decided to add metainformation to the tests,
in the form of :<attribute> <value> pairs after DEFTEST. Also,
I've added a DEFNOTE form to define note objects whose names
can be attached to properties of tests, to enable selective
disabling of classes of tests.
......@@ -91,7 +91,11 @@ Results: ~A~%" expected-number form n results))))
(loop for i from 0 below n collect i))
(defun make-int-array (n &optional (fn #'make-array))
(let ((a (funcall fn n)))
(when (symbolp fn)
(assert (fboundp fn))
(setf fn (symbol-function (the symbol fn))))
(let ((a (funcall (the function fn) n)))
(declare (type (array * *) a))
(loop for i from 0 below n do (setf (aref a i) i))
a))
......@@ -106,17 +110,19 @@ Results: ~A~%" expected-number form n results))))
(equal (aref a1) (aref a2))
(let ((ad (array-dimensions a1)))
(and (equal ad (array-dimensions a2))
(if (= (array-rank a1) 1)
(let ((as (first ad)))
(loop
for i from 0 below as
always (equal (aref a1 i) (aref a2 i))))
(let ((as (array-total-size a1)))
(and (= as (array-total-size a2))
(loop
for i from 0 below as
always (equal (row-major-aref a1 i)
(row-major-aref a2 i)))))))))))
(locally
(declare (type (array * *) a1 a2))
(if (= (array-rank a1) 1)
(let ((as (first ad)))
(loop
for i from 0 below as
always (equal (aref a1 i) (aref a2 i))))
(let ((as (array-total-size a1)))
(and (= as (array-total-size a2))
(loop
for i from 0 below as
always (equal (row-major-aref a1 i)
(row-major-aref a2 i))))))))))))
;;; *universe* is defined elsewhere -- it is a list of various
;;; lisp objects used when stimulating things in various tests.
......@@ -207,11 +213,17 @@ Results: ~A~%" expected-number form n results))))
"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."
(when (symbolp p)
(assert (fboundp p))
(setf p (symbol-function p)))
(assert (typep p 'function))
(loop
for x in *universe* count
(block failed
(let ((p1 (handler-case
(funcall P x)
(funcall (the function p) x)
(error () (format t "(FUNCALL ~S ~S) failed~%"
P x)
(return-from failed t))))
......@@ -376,8 +388,8 @@ the condition to go uncaught if it cannot be classified."
(defun compose (&rest fns)
(let ((rfns (reverse fns)))
#'(lambda (x) (loop for f of-type function
in rfns do (setf x (funcall f x))) x)))
#'(lambda (x) (loop for f
in rfns do (setf x (funcall (the function f) x))) x)))
(defun evendigitp (c)
(notnot (find c "02468")))
......@@ -417,8 +429,9 @@ the condition to go uncaught if it cannot be classified."
(cons 'list args)))
(defparameter +standard-chars+
(coerce
"abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789~!@#$%^&*()_+|\\=-`{}[]:\";'<>?,./
")
" 'simple-base-string))
(defparameter
+base-chars+ #.(concatenate 'simple-base-string
......@@ -436,16 +449,21 @@ the condition to go uncaught if it cannot be classified."
(defparameter +upper-case-chars+ (subseq +alpha-chars+ 26 52))
(defparameter +alphanumeric-chars+ (subseq +standard-chars+ 0 62))
(defparameter +digit-chars+ "0123456789")
(defparameter +extended-digit-chars+ "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ")
(defparameter +extended-digit-chars+ (coerce
"0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
'simple-base-string))
(declaim (type simple-base-string +alpha-chars+ +lower-case-chars+
+upper-case-chars+ +alphanumeric-chars+))
+upper-case-chars+ +alphanumeric-chars+ +extended-digit-chars+
+standard-chars+))
(defparameter +code-chars+
(coerce (loop for i from 0 below 256
for c = (code-char i)
when c collect c)
'string))
'simple-string))
(declaim (type simple-string +code-chars+))
(defparameter +rev-code-chars+ (reverse +code-chars+))
......@@ -453,7 +471,7 @@ the condition to go uncaught if it cannot be classified."
(defun has-non-abort-restart (c)
(throw 'handled
(if (position 'abort (compute-restarts c)
(if (position 'abort (the list (compute-restarts c))
:key #'restart-name :test-not #'eq)
'success
'fail)))
......@@ -1256,11 +1274,11 @@ the condition to go uncaught if it cannot be classified."
(classify-error* (elt x n)))
(defmacro defstruct* (&body args)
`(eval-when (load eval compile)
`(eval-when #+gcl (load eval compile)
#-gcl (:load-toplevel :compile-toplevel :execute)
(handler-case (eval '(defstruct ,@args))
(serious-condition () nil))))
(defun sort-package-list (x)
(sort (copy-list x)
#'string<
......
......@@ -6,6 +6,7 @@
(in-package :cl-test)
(defun is-ordered-by (seq fn)
(declare (type function fn))
(let ((n (length seq)))
(loop for i from 0 below (1- n)
for e = (elt seq i)
......@@ -14,21 +15,28 @@
always (funcall fn e (elt seq j))))))
(defun is-antisymmetrically-ordered-by (seq fn)
(declare (type function fn))
(and (is-ordered-by seq fn)
(is-ordered-by (reverse seq) (complement fn))))
(defun is-case-insensitive (fn)
(loop for c across +code-chars+
for c1 = (char-upcase c)
for c2 = (if (eql c c1) (char-downcase c) c1)
always
(loop for d across +code-chars+
for d1 = (char-upcase d)
for d2 = (if (eql d d1) (char-downcase d) d1)
always (equiv (funcall fn c d)
(funcall fn c2 d)
(funcall fn c d2)
(funcall fn c2 d2)))))
(when (symbolp fn)
(assert (fboundp fn))
(setf fn (symbol-function fn)))
(assert (typep fn 'function))
(locally
(declare (type function fn))
(loop for c across +code-chars+
for c1 = (char-upcase c)
for c2 = (if (eql c c1) (char-downcase c) c1)
always
(loop for d across +code-chars+
for d1 = (char-upcase d)
for d2 = (if (eql d d1) (char-downcase d) d1)
always (equiv (funcall fn c d)
(funcall fn c2 d)
(funcall fn c d2)
(funcall fn c2 d2))))))
(defun equiv (&rest args)
(declare (dynamic-extent args))
......@@ -40,9 +48,15 @@
;;; From character.lsp
(defun char-type-error-check (fn)
(loop for x in *universe*
always (or (characterp x)
(eqt (catch-type-error (funcall fn x)) 'type-error))))
(when (symbolp fn)
(assert (fboundp fn))
(setf fn (symbol-function fn)))
(assert (typep fn 'function))
(locally
(declare (type function fn))
(loop for x in *universe*
always (or (characterp x)
(eqt (catch-type-error (funcall fn x)) 'type-error)))))
(defun standard-char.5.body ()
(loop for i from 0 below (min 65536 char-code-limit)
......
......@@ -1134,14 +1134,6 @@
;;; Various error cases for symbol-related functions
(deftest symbolp.error.1
(classify-error (symbolp))
program-error)
(deftest symbolp.error.2
(classify-error (symbolp nil nil))
program-error)
(deftest symbol-function.error.1
(classify-error (symbol-function))
program-error)
......
......@@ -8,8 +8,6 @@
;; #+gcl (:use defpackage)
(:nicknames)
(:import-from "COMMON-LISP-USER" #:compile-and-load "==>")
(:export))
(:export #:random-from-seq #:random-case #:coin #:random-permute))
#+cmu (import 'cl::quit :cl-test)
......@@ -6,7 +6,8 @@
(when (eq excl:*current-case-mode* :case-sensitive-lower)
(push :lower-case *features*)))
(eval-when (load eval compile)
(eval-when #+gcl (load eval compile)
#-gcl (:load-toplevel :compile-toplevel :execute)
(intern "==>" "CL-USER")
(unless (fboundp 'compile-file-pathname)
(defun compile-file-pathname (pathname)
......
......@@ -167,7 +167,8 @@
`(progn
(declaim (special ,class-var-name))
(eval-when (load eval compile)
(eval-when #+gcl (load eval compile)
#-gcl (:load-toplevel :compile-toplevel :execute)
(ignore-errors (setq ,class-var-name (defclass ,@(cdr args)))))
(deftest ,(make-defclass-test-name class-name "-DEFCLASS-RETURNS-CLASS")
......
......@@ -19,7 +19,8 @@
(dolist (parent parents) (assert (symbolp parent)))
(let ((name (symbol-name name-symbol)))
`(eval-when (load eval compile)
`(eval-when #+gcl (load eval compile)
#-gcl (:load-toplevel :compile-toplevel :execute)
(ignore-errors (eval '(define-condition ,name-symbol ,parents
,slot-specs ,@options)))
,@(loop for parent in (adjoin 'condition parents)
......
......@@ -53,7 +53,8 @@
c
(c b))
(eval-when (load eval compile)
(eval-when #+gcl (load eval compile)
#-gcl (:load-toplevel :compile-toplevel :execute)
(ignore-errors
(defun (setf defun-test-fun-4) (newval x)
(return-from defun-test-fun-4 (setf (car x) newval)))))
......@@ -27,7 +27,8 @@
(not-mv (fboundp 'fboundp-5-fn))
nil)
(eval-when (eval compile)
(eval-when #+gcl (eval compile)
#-gcl (:load-toplevel :compile-toplevel)
(ignore-errors
(defun (setf fboundp-6-accessor) (y x) (setf (car x) y))))
......
......@@ -47,7 +47,8 @@
(typep '(lambda (x) x) 'function)
nil)
(eval-when (eval compile)
(eval-when #+gcl (eval compile)
#-gcl (:load-toplevel :compile-toplevel)
(ignore-errors
(defun (setf function-7-accessor) (y x) (setf (car x) y) y)))
......
......@@ -46,7 +46,8 @@
(functionp '(lambda (x) x))
nil)
(eval-when (eval compile)
(eval-when #+gcl (eval compile)
#-gcl (:load-toplevel :compile-toplevel)
(ignore-errors
(defun (setf functionp-7-accessor) (y x) (setf (car x) y) y)))
......
......@@ -93,6 +93,13 @@
*gensym-counter*)
10)
;;; GENSYM counter is a non-negative integer
(deftest gensym-counter.1
(and (integerp *gensym-counter*)
(>= *gensym-counter* 0)
t)
t)
;;; Check response to erroneous arguments
;;; Note! NIL is not the same as no argument
;;; gensym should be implemented so that its only
......
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Sun Jun 22 09:32:09 2003
;;;; Contains: Tests of GENTEMP
(in-package :cl-test)
......@@ -2,10 +2,13 @@
(compile-and-load "cl-symbols-aux.lsp")
;; (load "cl-symbol-names.lsp") ;; moved to gclload1.lsp
(load "cl-symbols.lsp")
(load "symbolp.lsp")
(load "boundp.lsp")
(load "copy-symbol.lsp")
(load "gensym.lsp")
(load "gentemp.lsp")
(load "keywordp.lsp")
(load "make-symbol.lsp")
(load "symbol-name.lsp")
(load "special-operator-p.lsp")
(load "set.lsp")
......@@ -4,8 +4,8 @@
;;;; Contains: Package definition for RT
(eval-when
;;(:execute :compile-toplevel :load-toplevel)
(load eval compile)
#-gcl (:execute :compile-toplevel :load-toplevel)
#+gcl (load eval compile)
(defpackage :regression-test
(:use :cl)
(:nicknames :rtest #-lispworks :rt)
......@@ -21,6 +21,7 @@
#:pending-tests
#:rem-all-tests
#:rem-test
#:defnote
)))
(in-package :regression-test)
......@@ -46,9 +46,23 @@
(defvar *expected-failures* nil
"A list of test names that are expected to fail.")
(defvar *notes* (make-hash-table :test 'equal)
"A mapping from names of notes to note objects.")
(defstruct (entry (:conc-name nil))
pend name props form vals)
;;; Note objects are used to attach information to tests.
;;; A typical use is to mark tests that depend on a particular
;;; part of a set of requirements, or a particular interpretation
;;; of the requirements.
(defstruct note
name
contents
disabled ;; When true, tests with this note are considered inactive
)
;; (defmacro vals (entry) `(cdddr ,entry))
(defmacro defn (entry)
......@@ -87,6 +101,20 @@
name))
entry))
(defun entry-notes (entry)
(let* ((props (props entry))
(notes (getf props :notes)))
(if (listp notes)
notes
(list notes))))
(defun has-disabled-note (entry)
(let ((notes (entry-notes entry)))
(loop for n in notes
for note = (if (note-p n) n
(gethash n *notes*))
thereis (and note (note-disabled note)))))
(defmacro deftest (name &rest body)
(let* ((p body)
(properties
......@@ -279,11 +307,11 @@
(defun do-entries (s)
(format s "~&Doing ~A pending test~:P ~
of ~A tests total.~%"
(count t (cdr *entries*)
:key #'pend)
(count t (the list (cdr *entries*)) :key #'pend)
(length (cdr *entries*)))
(dolist (entry (cdr *entries*))
(when (pend entry)
(when (and (pend entry)
(not (has-disabled-note entry)))
(format s "~@[~<~%~:; ~:@(~S~)~>~]"
(do-entry entry s))))
(let ((pending (pending-tests))
......@@ -314,3 +342,12 @@
new-failures)))
))
(null pending))))
;;; Note handling functions and macros
(defmacro defnote (name contents)
`(eval-when #+gcl (load eval) #-gcl (:load-toplevel :execute)
(let ((note (make-note :name ,name :contents ,contents)))
(setf (gethash *notes* (note-name note)) note)
note)))
......@@ -263,7 +263,8 @@ do the defstruct."
(cons slot-name (defstruct-maketemp name "SLOTTEMP" i)))))
)
;; Build the tests in an eval-when form
`(eval-when (compile load eval)
`(eval-when #+gcl (compile load eval)
#-gcl (:load-toplevel :compile-toplevel :execute)
(ignore-errors
(eval '(defstruct ,name-and-options
......
......@@ -376,7 +376,8 @@
;;; Initializer forms are evaluated only when needed, and are
;;; evaluated in the lexical environment in which they were defined
(eval-when (load eval)
(eval-when #+gcl (load eval)
#-gcl (:load-toplevel)
(let ((x nil))
(flet ((%f () x)
(%g (y) (setf x y)))
......
......@@ -98,11 +98,11 @@
;;;; Tests on the definitions of various vector types
(deftest string-is-vector-of-character.1
(deftest string-is-not-vector-of-character.1
(subtypep* 'string '(vector character))
t t)
nil t)
(deftest string-is-vector-of-character.2
(deftest vector-of-character-is-string.2
(subtypep* '(vector character) 'string)
t t)
......@@ -110,7 +110,7 @@
(subtypep* '(string *) '(vector character))
nil t)
(deftest string-is-vector-of-character.4
(deftest vector-of-character-is-string.4
(subtypep* '(vector character) '(string *))
t t)
......@@ -118,7 +118,7 @@
(subtypep* '(string 17) '(vector character 17))
nil t)
(deftest string-is-vector-of-character.6
(deftest vector-of-character-is-string.6
(subtypep* '(vector character 17) '(string 17))
t t)
......@@ -174,7 +174,7 @@
(subtypep* 'simple-string '(simple-array character (*)))
nil t)
(deftest simple-string-is-simple-1d-array-of-character.2
(deftest simple-1d-array-of-character-is-simple-string.2
(subtypep* '(simple-array character (*)) 'simple-string)
t t)
......@@ -182,7 +182,7 @@
(subtypep* '(simple-string *) '(simple-array character (*)))
nil t)
(deftest simple-string-is-simple-1d-array-of-character.4
(deftest simple-1d-array-of-character-is-simple-string.4
(subtypep* '(simple-array character (*)) '(simple-string *))
t t)
......@@ -190,7 +190,7 @@
(subtypep* '(simple-string 17) '(simple-array character (17)))
nil t)
(deftest simple-string-is-simple-1d-array-of-character.6
(deftest simple-1d-array-of-character-is-simple-string.6
(subtypep* '(simple-array character (17)) '(simple-string 17))
t t)
......
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Sun Jun 22 08:59:12 2003
;;;; Contains: Tests for SYMBOLP
(in-package :cl-test)
(deftest symbolp.1
(notnot-mv (symbolp nil))
t)
(deftest symbolp.2
(loop for x in *symbols*
unless (symbolp x)
collect x)
nil)
(deftest symbolp.3
(loop for x in (set-difference *universe* *symbols*)
when (symbolp x)
collect x)
nil)
;;; Error cases
(deftest symbolp.error.1
(classify-error (symbolp))
program-error)
(deftest symbolp.error.2
(classify-error (symbolp nil nil))
program-error)
......@@ -294,7 +294,12 @@
(make-array '(5) :element-type 'long-float
:initial-contents '(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0))
)
;; The ever-popular NIL array
(handler-case
(list (make-array '(0) :element-type nil))
(error () nil))
;; more kinds of arrays here later
))
......@@ -353,7 +358,7 @@
(defgeneric meaningless-user-generic-function-for-universe (x y z)
(:method ((x integer) (y integer) (z integer)) (+ x y z)))
(eval-when (load)
(eval-when #+gcl (load) #-gcl (:load-toplevel)
(compile 'meaningless-user-function-for-universe)
(compile 'meaningless-user-generic-function-for-universe)
)
......
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