diff --git a/ansi-tests/ansi-aux.lsp b/ansi-tests/ansi-aux.lsp index 272fbaa7063f7a796cd16fe73e7fa23f4ec9ba98..6426a521342b30cb4d614c9469913f67916526c6 100644 --- a/ansi-tests/ansi-aux.lsp +++ b/ansi-tests/ansi-aux.lsp @@ -8,33 +8,32 @@ (declaim (optimize (safety 3))) +;;; A function for coercing truth values to BOOLEAN + +(defun notnot (x) (not (not x))) + ;;; Comparison functions that are like various builtins, ;;; but are guaranteed to return T for true. (defun eqt (x y) "Like EQ, but guaranteed to return T for true." - (if (eq x y) t nil)) + (apply #'values (mapcar #'notnot (multiple-value-list (eq x y))))) (defun eqlt (x y) "Like EQL, but guaranteed to return T for true." - (if (eql x y) t nil)) + (apply #'values (mapcar #'notnot (multiple-value-list (eql x y))))) (defun equalt (x y) "Like EQUAL, but guaranteed to return T for true." - (if (equal x y) t nil)) + (apply #'values (mapcar #'notnot (multiple-value-list (equal x y))))) (defun equalpt (x y) "Like EQUALP, but guaranteed to return T for true." - (if (equalp x y) t nil)) + (apply #'values (mapcar #'notnot (multiple-value-list (equalp x y))))) (defun =t (x &rest args) "Like =, but guaranteed to return T for true." - (if (apply #'= x args) t nil)) - - -;;; A function for coercing truth values to BOOLEAN - -(defun notnot (x) (not (not x))) + (apply #'values (mapcar #'notnot (multiple-value-list (apply #'= args))))) (defun make-int-list (n) (loop for i from 0 below n collect i)) @@ -222,15 +221,14 @@ the condition to go uncaught if it cannot be classified." count (not (eqt e (nth i x))))) ;;; -;;; The function SUBTYPEP returns two generalized booleans. -;;; This auxiliary function returns two booleans instead +;;; The function SUBTYPEP should return two generalized booleans. +;;; This auxiliary function returns booleans instead ;;; (which makes it easier to write tests). ;;; (defun subtypep* (obj type) - (multiple-value-bind (result good) - (subtypep obj type) - (values (notnot result) - (notnot good)))) + (apply #'values + (mapcar #'notnot + (multiple-value-list (subtypep obj type))))) ;;; (eval-when (load eval compile) ;;; (unless (fboundp 'complement) diff --git a/ansi-tests/gclload2.lsp b/ansi-tests/gclload2.lsp index 03cb1d1d3a945c6cd76e9f9440c29ba5806468aa..b4c13cff7f08c3ba13a9a5c995dd056d1d0d3353 100644 --- a/ansi-tests/gclload2.lsp +++ b/ansi-tests/gclload2.lsp @@ -150,6 +150,7 @@ (load "simple-vector-p.lsp") (load "svref.lsp") (load "upgraded-array-element-type.lsp") +(load "vector.lsp") ;;; Tests of packages diff --git a/ansi-tests/vector.lsp b/ansi-tests/vector.lsp new file mode 100644 index 0000000000000000000000000000000000000000..244858c1fe6f6fdc4a7876ce3b80b009b99b9bb0 --- /dev/null +++ b/ansi-tests/vector.lsp @@ -0,0 +1,71 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Thu Jan 23 06:32:02 2003 +;;;; Contains: Tests of VECTOR (type and function) + +(in-package :cl-test) + +;;; More tests of type vector in make-array.lsp + +(deftest vector.type.1 + (notnot (typep #(a b c) 'vector)) + t) + +(deftest vector.type.2 + (notnot (typep #() 'vector)) + t) + +(deftest vector.type.3 + (notnot (typep "" 'vector)) + t) + +(deftest vector.type.4 + (notnot (typep "abcdef" 'vector)) + t) + +(deftest vector.type.5 + (notnot (typep #* 'vector)) + t) + +(deftest vector.type.6 + (notnot (typep #*011011101011 'vector)) + t) + +(deftest vector.type.7 + (typep #0aNIL 'vector) + nil) + +(deftest vector.type.8 + (typep #2a((a b c d)) 'vector) + nil) + +(deftest vector.type.9 + (subtypep* 'vector 'array) + t t) + +(deftest vector.type.10 + (notnot (typep #(a b c) '(vector *))) + t) + +(deftest vector.type.11 + (notnot (typep #(a b c) '(vector t))) + t) + +(deftest vector.type.12 + (notnot (typep "abcde" '(vector *))) + t) + +(deftest vector.type.13 + (typep "abcdef" '(vector t)) + nil) + +(deftest vector.type.14 + (notnot (typep #*00110 '(vector *))) + t) + +(deftest vector.type.15 + (typep #*00110 '(vector t)) + nil) + + +