From 7a23cd5a634bfadc00e8c71964fa9f3947c7aac1 Mon Sep 17 00:00:00 2001 From: pfdietz <pfdietz@localhost> Date: Tue, 1 Jul 2003 02:08:54 +0000 Subject: [PATCH] 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. --- ansi-tests/README | 9 +++++ ansi-tests/ansi-aux.lsp | 62 +++++++++++++++++++---------- ansi-tests/char-aux.lsp | 42 ++++++++++++------- ansi-tests/cl-symbols.lsp | 8 ---- ansi-tests/cl-test-package.lsp | 4 +- ansi-tests/compile-and-load.lsp | 3 +- ansi-tests/defclass-aux.lsp | 3 +- ansi-tests/define-condition-aux.lsp | 3 +- ansi-tests/defun.lsp | 3 +- ansi-tests/fboundp.lsp | 3 +- ansi-tests/function.lsp | 3 +- ansi-tests/functionp.lsp | 3 +- ansi-tests/gensym.lsp | 7 ++++ ansi-tests/gentemp.lsp | 8 ++++ ansi-tests/load-symbols.lsp | 3 ++ ansi-tests/rt-package.lsp | 5 ++- ansi-tests/rt.lsp | 43 ++++++++++++++++++-- ansi-tests/structure-00.lsp | 3 +- ansi-tests/structures-02.lsp | 3 +- ansi-tests/subtypep-array.lsp | 16 ++++---- ansi-tests/symbolp.lsp | 32 +++++++++++++++ ansi-tests/universe.lsp | 9 ++++- 22 files changed, 204 insertions(+), 71 deletions(-) create mode 100644 ansi-tests/gentemp.lsp create mode 100644 ansi-tests/symbolp.lsp diff --git a/ansi-tests/README b/ansi-tests/README index 1d56d805..f40f50a3 100644 --- a/ansi-tests/README +++ b/ansi-tests/README @@ -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. + + diff --git a/ansi-tests/ansi-aux.lsp b/ansi-tests/ansi-aux.lsp index 74456b22..2ec44f1a 100644 --- a/ansi-tests/ansi-aux.lsp +++ b/ansi-tests/ansi-aux.lsp @@ -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< diff --git a/ansi-tests/char-aux.lsp b/ansi-tests/char-aux.lsp index 61d6d42f..523f2694 100644 --- a/ansi-tests/char-aux.lsp +++ b/ansi-tests/char-aux.lsp @@ -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) diff --git a/ansi-tests/cl-symbols.lsp b/ansi-tests/cl-symbols.lsp index e0287fcf..a60cba8f 100644 --- a/ansi-tests/cl-symbols.lsp +++ b/ansi-tests/cl-symbols.lsp @@ -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) diff --git a/ansi-tests/cl-test-package.lsp b/ansi-tests/cl-test-package.lsp index 5a77e47c..042d44c9 100644 --- a/ansi-tests/cl-test-package.lsp +++ b/ansi-tests/cl-test-package.lsp @@ -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) - - diff --git a/ansi-tests/compile-and-load.lsp b/ansi-tests/compile-and-load.lsp index a1a3e500..5fa96156 100644 --- a/ansi-tests/compile-and-load.lsp +++ b/ansi-tests/compile-and-load.lsp @@ -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) diff --git a/ansi-tests/defclass-aux.lsp b/ansi-tests/defclass-aux.lsp index 10c1e189..b65ff770 100644 --- a/ansi-tests/defclass-aux.lsp +++ b/ansi-tests/defclass-aux.lsp @@ -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") diff --git a/ansi-tests/define-condition-aux.lsp b/ansi-tests/define-condition-aux.lsp index eabafeb7..4e94c743 100644 --- a/ansi-tests/define-condition-aux.lsp +++ b/ansi-tests/define-condition-aux.lsp @@ -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) diff --git a/ansi-tests/defun.lsp b/ansi-tests/defun.lsp index 6ed7830d..d422cf30 100644 --- a/ansi-tests/defun.lsp +++ b/ansi-tests/defun.lsp @@ -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))))) diff --git a/ansi-tests/fboundp.lsp b/ansi-tests/fboundp.lsp index 0ec7332d..c993d48f 100644 --- a/ansi-tests/fboundp.lsp +++ b/ansi-tests/fboundp.lsp @@ -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)))) diff --git a/ansi-tests/function.lsp b/ansi-tests/function.lsp index f6039c65..cd4733cb 100644 --- a/ansi-tests/function.lsp +++ b/ansi-tests/function.lsp @@ -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))) diff --git a/ansi-tests/functionp.lsp b/ansi-tests/functionp.lsp index 23edd093..5275ed8a 100644 --- a/ansi-tests/functionp.lsp +++ b/ansi-tests/functionp.lsp @@ -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))) diff --git a/ansi-tests/gensym.lsp b/ansi-tests/gensym.lsp index 6d4e6684..7661c03c 100644 --- a/ansi-tests/gensym.lsp +++ b/ansi-tests/gensym.lsp @@ -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 diff --git a/ansi-tests/gentemp.lsp b/ansi-tests/gentemp.lsp new file mode 100644 index 00000000..85c0e240 --- /dev/null +++ b/ansi-tests/gentemp.lsp @@ -0,0 +1,8 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Jun 22 09:32:09 2003 +;;;; Contains: Tests of GENTEMP + +(in-package :cl-test) + + diff --git a/ansi-tests/load-symbols.lsp b/ansi-tests/load-symbols.lsp index d8863f00..27c014d0 100644 --- a/ansi-tests/load-symbols.lsp +++ b/ansi-tests/load-symbols.lsp @@ -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") diff --git a/ansi-tests/rt-package.lsp b/ansi-tests/rt-package.lsp index 02fc12f3..351617e7 100644 --- a/ansi-tests/rt-package.lsp +++ b/ansi-tests/rt-package.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) diff --git a/ansi-tests/rt.lsp b/ansi-tests/rt.lsp index 31191705..6525c3cb 100644 --- a/ansi-tests/rt.lsp +++ b/ansi-tests/rt.lsp @@ -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))) + diff --git a/ansi-tests/structure-00.lsp b/ansi-tests/structure-00.lsp index d1b00e3b..83d07d46 100644 --- a/ansi-tests/structure-00.lsp +++ b/ansi-tests/structure-00.lsp @@ -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 diff --git a/ansi-tests/structures-02.lsp b/ansi-tests/structures-02.lsp index e34e2526..9c15d71a 100644 --- a/ansi-tests/structures-02.lsp +++ b/ansi-tests/structures-02.lsp @@ -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))) diff --git a/ansi-tests/subtypep-array.lsp b/ansi-tests/subtypep-array.lsp index 49d0d018..edd0bf34 100644 --- a/ansi-tests/subtypep-array.lsp +++ b/ansi-tests/subtypep-array.lsp @@ -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) diff --git a/ansi-tests/symbolp.lsp b/ansi-tests/symbolp.lsp new file mode 100644 index 00000000..a2c7b4d0 --- /dev/null +++ b/ansi-tests/symbolp.lsp @@ -0,0 +1,32 @@ +;-*- 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) diff --git a/ansi-tests/universe.lsp b/ansi-tests/universe.lsp index b47affae..c4700a01 100644 --- a/ansi-tests/universe.lsp +++ b/ansi-tests/universe.lsp @@ -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) ) -- GitLab