Skip to content
Snippets Groups Projects
Commit 6203b6f0 authored by Daniel Kochmański's avatar Daniel Kochmański
Browse files

restruct: add random tests to random directory

Not sure, but these tests weren't called ?
parent 5b208dda
No related branches found
No related tags found
No related merge requests found
Showing
with 6908 additions and 0 deletions
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Tue Dec 28 20:28:03 2004
;;;; Contains: Code to make random elements of types
(in-package :cl-test)
(defgeneric make-random-element-of (type)
(:documentation
"Create a random element of TYPE, or throw an error if it can't figure out how to do it."))
(defgeneric make-random-element-of-compound-type (type args &key &allow-other-keys)
(:documentation
"Create a random element of (TYPE . ARGS), or throw an error if it can't figure out how to do it."))
(defmethod make-random-element-of ((type cons))
(make-random-element-of-compound-type (car type) (cdr type)))
(defmethod make-random-element-of ((type (eql bit))) (random 2))
(defmethod make-random-element-of ((type (eql boolean)))
(random-from-seq #(nil t)))
(defmethod make-random-elememt-of ((type (eql symbol)))
(random-from-seq #(nil t a b c :a :b :c |z| foo |foo| car)))
(defmethod make-random-element-of ((type (eql unsigned-byte)))
(random-from-interval
(1+ (ash 1 (random *maximum-random-int-bits*)))))
(defmethod make-random-elememt-of ((type (eql signed-byte)))
(random-from-interval
(1+ (ash 1 (random *maximum-random-int-bits*)))
(- (ash 1 (random *maximum-random-int-bits*)))))
(defmethod make-random-element-of ((type (eql rational)))
(let* ((r (ash 1 (1+ (random *maximum-random-int-bits*))))
(n (random r))
(d (loop for x = (random r) unless (zerop x) do (return x))))
(if (coin) (/ n d) (- (/ n d)))))
(defmethod make-random-element-of ((type (eql integer)))
(let* ((b (random *maximum-random-int-bits*))
(x (ash 1 b)))
(rcase
(1 (+ x (make-random-element-of 'integer)))
(1 (- (make-random-element-of 'integer) x))
(6 (random-from-interval (1+ x) (- x))))))
(defmethod make-random-element-of ((type (eql short-float)))
(make-random-element-of (list type)))
(defmethod make-random-element-of ((type (eql single-float)))
(make-random-element-of (list type)))
(defmethod make-random-element-of ((type (eql double-float)))
(make-random-element-of (list type)))
(defmethod make-random-element-of ((type (eql long-float)))
(make-random-element-of (list type)))
(defmethod make-random-element-of ((type (eql float)))
(make-random-element-of
(list (random-from-seq #'(short-float single-float double-float long-float)))))
(defmethod make-random-element-of ((type (eql real)))
(make-random-element-of (random-from-seq #(integer rational float))))
(defmethod make-random-element-of ((type (eql ratio)))
(loop for x = (make-random-element-of 'rational)
unless (integerp x) return x))
(defmethod make-random-element-of ((type complex))
(make-random-element-of '(complex real)))
(defmethod make-random-element-of ((type fixnum))
(make-random-element-of `(integer ,most-negative-fixnum ,most-positive-fixnum)))
(defmethod make-random-element-of ((type bignum))
(make-random-element-of `(or (integer * (,most-negative-fixnum))
(integer (,most-positive-fixnum)))))
(defmethod make-random-element-of ((type (eql number)))
(make-random-element-of (random-from-seq #(integer rational float complex))))
(defmethod make-random-element-of ((type (eql character)))
(rcase
(3 (random-from-seq +standard-chars+))
(2 (let ((r (random 256)))
(or (code-char r) (make-random-element-of 'character))))
(1 (let ((r (random #.(ash 1 16))))
(or (code-char r) (make-random-element-of 'character))))
(1 (let ((r (random #.(ash 1 24))))
(or (code-char r) (make-random-element-of 'character))))))
(defmethod make-random-element-of ((type 'base-char))
(random-from-seq +standard-chars+))
(defmethod make-random-element-of ((type 'standard-char))
(random-from-seq +standard-chars+))
(defmethod make-random-element-of ((type (eql bit-vector)))
(make-random-vector 'bit '*))
(defmethod make-random-element-of ((type (eql simple-bit-vector)))
(make-random-vector 'bit '* :simple t))
(defmethod make-random-element-of ((type (eql vector)))
(make-random-vector '* '*))
(defmethod make-random-element-of ((type (eql simple-vector)))
(make-random-vector 't '* :simple t))
(defmethod make-random-elemnt-of ((type (eql array)))
(make-random-array '* '*))
(defmethod make-random-elemnt-of ((type (eql simple-array)))
(make-random-array '* '* :simple t))
(defmethod make-random-elememt-of ((type (eql string)))
(make-random-string '*))
(defmethod make-random-elememt-of ((type (eql simple-string)))
(make-random-string '* :simple t))
(defmethod make-random-element-of ((type (eql base-string)))
(make-random-vector 'base-char '*))
(defmethod make-random-element-of ((type (eql simple-base-string)))
(make-random-vector 'base-char '* :simple t))
(defmethod make-random-element-of ((type (eql cons)))
(make-random-element-of '(cons t t)))
(defmethod make-random-element-of ((type (eql null))) nil)
(defmethod make-random-elememt-of ((type (eql list)))
(let ((len (min (random 10) (random 10))))
(loop repeat len collect (make-random-element-of-type t))))
(defmethod make-random-element-of ((type (eql sequence)))
(make-random-element-of '(or list vector)))
;;;;
(defun make-random-vector (length &key simple (element-type '*))
(setq element-type (make-random-array-element-type element-type))
(make-random-element-of `(,(if simple 'simple-vector 'vector) ,element-type ,length)))
(defun make-random-array (dimensions &key simple (element-type '*))
(setq element-type (make-random-array-element-type element-type))
(make-random-element-of `(,(if simple 'simple-array 'array) ,element-type ,length)))
(defun make-random-array-element-type (elememt-type)
(if (eq element-type '*)
(rcase
(1 'bit)
(1 `(unsigned-byte (1+ (random *maximum-random-int-bits*))))
(1 `(signed-byte (1+ (random *maximum-random-int-bits*))))
(2 (random-from-seq #(character base-char standard-char)))
;; Put float, complex types here also
(4 t))
element-type))
;;;;
(defmethod make-random-element-of-compound-type ((type-op (eql or)) (args cons))
(make-random-element-of (random-from-seq args)))
(defmethod make-random-element-of-compound-type ((type-op (eql and)) (args cons))
(loop for e = (make-random-element-of (car args))
repeat 100
when (or (null (cdr args)) (typep e (cons 'and (cdr args))))
return x
finally (error "Cannot generate a random element of ~A"
(cons 'and args))))
(defmethod make-random-element-of-compound-type ((type-op (eql integer)) (args t))
(let ((lo (let ((lo (car args)))
(cond
((consp lo) (1+ (car lo)))
((eq lo nil) '*)
(t lo))))
(hi (let ((hi (cadr args)))
(cond
((consp hi) (1- (car hi)))
((eq hi nil) '*)
(t hi)))))
(if (eq lo '*)
(if (eq hi '*)
(let ((x (ash 1 (random *maximum-random-int-bits*))))
(random-from-interval x (- x)))
(random-from-interval (1+ hi)
(- hi (random (ash 1 *maximum-random-int-bits*)))))
(if (eq hi '*)
(random-from-interval (+ lo (random (ash 1 *maximum-random-int-bits*)) 1)
lo)
;; May generalize the next case to increase odds
;; of certain integers (near 0, near endpoints, near
;; powers of 2...)
(random-from-interval (1+ hi) lo)))))
(defmethod make-random-element-of-compound-type ((type-op (eql short-float)) (args t))
(make-random-element-of-float-type type args))
(defmethod make-random-element-of-compound-type ((type-op (eql single-float)) (args t))
(make-random-element-of-float-type type args))
(defmethod make-random-element-of-compound-type ((type-op (eql double-float)) (args t))
(make-random-element-of-float-type type args))
(defmethod make-random-element-of-compound-type ((type-op (eql long-float)) (args t))
(make-random-element-of-float-type type args))
(defun make-random-element-of-float-type (type-op args)
(let ((lo (car args))
(hi (cadr args))
lo= hi=)
(cond
((consp lo) nil)
((member lo '(* nil))
(setq lo (most-negative-float type-op))
(setq lo= t))
(t
(assert (typep lo type-op))
(setq lo= t)))
(cond
((consp hi) nil)
((member hi '(* nil))
(setq hi (most-positive-float type-op))
(setq hi= t))
(t
(assert (typep hi type-op))
(setq hi= t)))
(assert (<= lo hi))
(assert (or (< lo hi) (and lo= hi=)))
(let ((limit 100000))
(cond
((or (<= hi 0)
(>= lo 0)
(and (<= (- limit) hi limit) (<= (- limit) lo limit)))
(loop for x = (+ (random (- hi lo)) lo)
do (when (or lo= (/= x lo)) (return x))))
(t
(rcase
(1 (random (min hi (float limit hi))))
(1 (- (random (min (float limit lo) (- lo)))))))))))
(defmethod make-random-element-of-compound-type ((type-op (eql mod)) (args cons))
(let ((modulus (car args)))
(assert (integerp modulus))
(assert (plusp modulus))
(make-random-element-of `(integer 0 (,modulus)))))
(defmethod make-random-element-of-compound-type ((type-op (eql unsigned-byte)) (args t))
(if (null args)
(make-random-element-of '(integer 0 *))
(let ((bits (car args)))
(if (eq bits'*)
(make-random-element-of '(integer 0 *))
(progn
(assert (and (integerp bits) (>= bits 1)))
(make-random-element-of `(integer 0 ,(1- (ash 1 bits)))))))))
(defmethod make-random-element-of-compound-type ((type-op (eql eql)) (args cons))
(assert (null (cdr args)))
(car args))
(defmethod make-random-element-of-compound-type ((type-op (eql member)) (args cons))
(random-from-seq args))
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Sun Oct 10 07:13:47 2004
;;;; Contains: Randomized tests on classes
(in-package :cl-test)
(compile-and-load "random-class-aux.lsp")
This diff is collapsed.
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Contains: Code to randomly intern and unintern random strings
;;;; in a package. Exercises package and hash table routines
(in-package :cl-test)
(defconstant +max-len-random-symbol+ 63)
(defun make-random-symbol (package)
(declare (optimize (speed 3) (safety 3)))
(loop
(let* ((len (random (1+ +max-len-random-symbol+)))
(str (make-string len)))
(declare (type (integer 0 #.+max-len-random-symbol+) len))
(loop
for i from 0 to (1- len) do
(setf (schar str i)
(schar +base-chars+
(random +num-base-chars+))))
(multiple-value-bind
(symbol status)
(intern (copy-seq str) package)
(unless (equal str (symbol-name symbol))
(error "Intern gave bad symbol: ~A, ~A~%" str symbol))
(unless status (return symbol))))))
(defun queue-insert (q x)
(declare (type cons q))
(push x (cdr q)))
(defun queue-remove (q)
(declare (type cons q))
(when (null (car q))
(when (null (cdr q))
(error "Attempty to remove from empty queue.~%"))
(setf (car q) (nreverse (cdr q)))
(setf (cdr q) nil))
(pop (car q)))
(defun queue-empty (q)
(and (null (car q))
(null (cdr q))))
(defun random-intern (n)
(declare (fixnum n))
(let ((q (list nil))
(xp (defpackage "X" (:use))))
(declare (type cons q))
(loop
for i from 1 to n do
(if (and
(= (random 2) 0)
(not (queue-empty q)))
(unintern (queue-remove q) xp)
(queue-insert q (make-random-symbol xp))))))
(defun fill-intern (n)
(declare (fixnum n))
(let ((xp (defpackage "X" (:use))))
(loop
for i from 1 to n do
(make-random-symbol xp))))
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Sun Mar 6 20:36:56 2005
;;;; Contains: Test that invoke the random type prop infrastructure, part 1
(in-package :cl-test)
(def-type-prop-test special-operator-p 'special-operator-p '(symbol) 1)
(def-type-prop-test type-of 'type-of '(t) 1)
(def-type-prop-test typep.1 '(lambda (x y) (typep x (type-of y))) '(t t) 2)
(def-type-prop-test typep.2 'typep
(list t #'(lambda (x)
(let ((type (make-random-type-containing x)))
`(eql ,type))))
2)
(def-type-prop-test subtypep
'(lambda (x y) (subtypep (type-of x) (type-of y))) '(t t) 2)
(def-type-prop-test fboundp.1 'fboundp '(symbol) 1)
(def-type-prop-test fboundp.2 'fboundp '((cons (eql setf) (cons symbol null))) 1)
(def-type-prop-test functionp 'functionp '(t) 1)
(def-type-prop-test compiled-function-p 'compiled-function-p '(t) 1)
(def-type-prop-test not 'not '(t) 1)
(def-type-prop-test eq 'eq (list
'(and t (not number) (not character))
#'(lambda (x) (rcase
(1 `(eql ,x))
(1 '(and t (not number) (not character))))))
2)
(def-type-prop-test eql.1 'eql '(t t) 2)
(def-type-prop-test eql.2 'eql (list t #'(lambda (x) `(eql ,x))) 2)
(def-type-prop-test equal.1 'equal '(t t) 2)
(def-type-prop-test equal.2 'equal (list t #'(lambda (x) `(eql ,x))) 2)
(def-type-prop-test equalp.1 'equalp '(t t) 2)
(def-type-prop-test equalp.2 'equalp (list t #'(lambda (x) `(eql ,x))) 2)
(def-type-prop-test identity 'identity '(t) 1)
(def-type-prop-test complement
'(lambda (f y) (funcall (complement f) y)) (list `(eql ,#'symbolp) t) 2)
(def-type-prop-test constantly
'(lambda (x) (funcall (constantly x))) '(t) 1)
(def-type-prop-test and.1 'and '(t) 1)
(def-type-prop-test and.2 'and '((or null t) t) 2)
(def-type-prop-test and.3 'and '((or null t) (or null t) t) 3)
(def-type-prop-test if.1 'if '(boolean t) 2)
(def-type-prop-test if.2 'if '(boolean t t) 3)
(def-type-prop-test if.3 '(lambda (p q x y z) (if p (if q x y) z))
'(boolean boolean t t t) 5)
(def-type-prop-test if.4 '(lambda (p q x y z) (if p x (if q y z)))
'(boolean boolean t t t) 5)
(def-type-prop-test if.5 '(lambda (p q x y) (if (or p q) x y))
'(boolean boolean t t) 4)
(def-type-prop-test if.6 '(lambda (p q x y) (if (and p q) x y))
'(boolean boolean t t) 4)
(def-type-prop-test cond.1 '(lambda (p x y) (cond (p x) (t y))) '(boolean t t) 3)
(def-type-prop-test cond.2 '(lambda (p x y) (cond (p x) (t y))) '((or null t) t t) 3)
(def-type-prop-test or.1 'or '(t) 1)
(def-type-prop-test or.2 'or '((or null t) t) 2)
(def-type-prop-test or.3 'or '((or null null t) (or null t) t) 3)
(def-type-prop-test when 'when '((or null t) t) 2)
(def-type-prop-test unless 'unless '((or null t) t) 2)
(def-type-prop-test slot-exists-p 'slot-exists-p '(t symbol) 2)
(def-type-prop-test find-class 'find-class '(symbol null) 2)
(def-type-prop-test class-of 'class-of '(t) 1)
(def-type-prop-test find-restart 'find-restart '((and symbol (not null))) 1)
(def-type-prop-test symbolp 'symbolp '(t) 1)
(def-type-prop-test keywordp 'keywordp '(t) 1)
(def-type-prop-test make-symbol 'make-symbol '(string) 1
:test #'(lambda (x y) (string= (symbol-name x) (symbol-name y))))
(def-type-prop-test symbol-name 'symbol-name '(symbol) 1)
(def-type-prop-test symbol-package 'symbol-package '(symbol) 1)
(def-type-prop-test boundp 'boundp '(symbol) 1)
(def-type-prop-test find-symbol 'find-symbol '(string) 1)
(def-type-prop-test find-package 'find-package '((or string symbol character)) 1)
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Sun Mar 6 20:37:57 2005
;;;; Contains: Tests that invoke the random type prop infrastructure, part 2
(in-package :cl-test)
(def-type-prop-test =.1 '= '(number number) 2)
(def-type-prop-test =.2 '= '(number number number) 3)
(def-type-prop-test =.3 '= nil 4 :maxargs 10 :rest-type 'number)
(def-type-prop-test =.4 '= '(integer integer) 2)
(def-type-prop-test =.5 '= (list 'number #'(lambda (x) (if (coin) 'number
`(eql ,x)))) 2)
(def-type-prop-test =.6 '= (list 'number 'number
#'(lambda (x y) (rcase
(2 'number)
(1 `(eql ,x))
(1 `(eql ,y)))))
3)
(def-type-prop-test /=.1 '/= '(number number) 2)
(def-type-prop-test /=.2 '/= '(number number number) 3)
(def-type-prop-test /=.3 '/= nil 4 :maxargs 10 :rest-type 'number)
(def-type-prop-test /=.4 '/= '(integer integer) 2)
(def-type-prop-test /=.5 '/= (list 'number #'(lambda (x) (if (coin) 'number
`(eql ,x)))) 2)
(def-type-prop-test /=.6 '/= (list 'number 'number
#'(lambda (x y) (rcase
(2 'number)
(1 `(eql ,x))
(1 `(eql ,y)))))
3)
(def-type-prop-test <.1 '< '(real real) 2)
(def-type-prop-test <.2 '< '(real real real) 3)
(def-type-prop-test <.3 '< nil 4 :maxargs 10 :rest-type 'real)
(def-type-prop-test <.4 '< '(integer integer) 2)
(def-type-prop-test <.5 '< (list 'real #'(lambda (x) (if (coin) 'real
`(eql ,x)))) 2)
(def-type-prop-test <.6 '< (list 'real 'real
#'(lambda (x y) (rcase
(2 'real)
(1 `(eql ,x))
(1 `(eql ,y)))))
3)
(def-type-prop-test >.1 '> '(real real) 2)
(def-type-prop-test >.2 '> '(real real real) 3)
(def-type-prop-test >.3 '> nil 4 :maxargs 10 :rest-type 'real)
(def-type-prop-test >.4 '> '(integer integer) 2)
(def-type-prop-test >.5 '> (list 'real #'(lambda (x) (if (coin) 'real
`(eql ,x)))) 2)
(def-type-prop-test >.6 '> (list 'real 'real
#'(lambda (x y) (rcase
(2 'real)
(1 `(eql ,x))
(1 `(eql ,y)))))
3)
(def-type-prop-test <=.1 '<= '(real real) 2)
(def-type-prop-test <=.2 '<= '(real real real) 3)
(def-type-prop-test <=.3 '<= nil 4 :maxargs 10 :rest-type 'real)
(def-type-prop-test <=.4 '<= '(integer integer) 2)
(def-type-prop-test <=.5 '<= (list 'real #'(lambda (x) (if (coin) 'real
`(eql ,x)))) 2)
(def-type-prop-test <=.6 '<= (list 'real 'real
#'(lambda (x y) (rcase
(2 'real)
(1 `(eql ,x))
(1 `(eql ,y)))))
3)
(def-type-prop-test >=.1 '>= '(real real) 2)
(def-type-prop-test >=.2 '>= '(real real real) 3)
(def-type-prop-test >=.3 '>= nil 4 :maxargs 10 :rest-type 'real)
(def-type-prop-test >=.4 '>= '(integer integer) 2)
(def-type-prop-test >=.5 '>= (list 'real #'(lambda (x) (if (coin) 'real
`(eql ,x)))) 2)
(def-type-prop-test >=.6 '>= (list 'real 'real
#'(lambda (x y) (rcase
(2 'real)
(1 `(eql ,x))
(1 `(eql ,y)))))
3)
(def-type-prop-test min.1 'min nil 2 :maxargs 6 :rest-type 'integer)
(def-type-prop-test min.2 'min nil 2 :maxargs 6 :rest-type 'rational)
(def-type-prop-test min.3 'min nil 2 :maxargs 6 :rest-type 'real)
(def-type-prop-test max.1 'max nil 2 :maxargs 6 :rest-type 'integer)
(def-type-prop-test max.2 'max nil 2 :maxargs 6 :rest-type 'rational)
(def-type-prop-test max.3 'max nil 2 :maxargs 6 :rest-type 'real)
(def-type-prop-test minusp 'minusp '(real) 1)
(def-type-prop-test plusp 'plusp '(real) 1)
(def-type-prop-test zerop 'zerop '(number) 1)
(def-type-prop-test floor.1 'floor '(real) 1)
(def-type-prop-test floor.2 'floor '(real (and integer (not (satisfies zerop)))) 2)
(def-type-prop-test floor.3 'floor '(real (and real (not (satisfies zerop)))) 2)
(def-type-prop-test ffloor.1 'ffloor '(real) 1)
(def-type-prop-test ffloor.2 'ffloor '(real (and integer (not (satisfies zerop)))) 2)
(def-type-prop-test ffloor.3 'ffloor '(real (and real (not (satisfies zerop)))) 2)
(def-type-prop-test ceiling.1 'ceiling '(real) 1)
(def-type-prop-test ceiling.2 'ceiling '(real (and integer (not (satisfies zerop)))) 2)
(def-type-prop-test ceiling.3 'ceiling '(real (and real (not (satisfies zerop)))) 2)
(def-type-prop-test fceiling.1 'fceiling '(real) 1)
(def-type-prop-test fceiling.2 'fceiling '(real (and integer (not (satisfies zerop)))) 2)
(def-type-prop-test fceiling.3 'fceiling '(real (and real (not (satisfies zerop)))) 2)
(def-type-prop-test truncate.1 'truncate '(real) 1)
(def-type-prop-test truncate.2 'truncate '(real (and integer (not (satisfies zerop)))) 2)
(def-type-prop-test truncate.3 'truncate '(real (and real (not (satisfies zerop)))) 2)
(def-type-prop-test ftruncate.1 'ftruncate '(real) 1)
(def-type-prop-test ftruncate.2 'ftruncate '(real (and integer (not (satisfies zerop)))) 2)
(def-type-prop-test ftruncate.3 'ftruncate '(real (and real (not (satisfies zerop)))) 2)
(def-type-prop-test round.1 'round '(real) 1)
(def-type-prop-test round.2 'round '(real (and integer (not (satisfies zerop)))) 2)
(def-type-prop-test round.3 'round '(real (and real (not (satisfies zerop)))) 2)
(def-type-prop-test fround.1 'fround '(real) 1)
(def-type-prop-test fround.2 'fround '(real (and integer (not (satisfies zerop)))) 2)
(def-type-prop-test fround.3 'fround '(real (and real (not (satisfies zerop)))) 2)
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Sun Mar 6 20:39:10 2005
;;;; Contains: Tests that invoke the random type prop infrastructure, part 3
(in-package :cl-test)
;;; trig, hyperbolic functions here
;;; WARNING -- these tests may cause floating point overflow/underflow
;;; Ignore those failures
(def-type-prop-test *.1 '* '(integer integer) 2)
(def-type-prop-test *.2 '* nil 1 :rest-type 'integer :maxargs 4)
(def-type-prop-test *.3 '* nil 2 :rest-type 'integer :maxargs 10)
(def-type-prop-test *.4 '* '(real real) 2 :test #'approx=)
(def-type-prop-test *.5 '* '(number number) 2 :test #'approx=)
(def-type-prop-test \+.1 '+ '(integer integer) 2)
(def-type-prop-test \+.2 '+ nil 1 :rest-type 'integer :maxargs 4)
(def-type-prop-test \+.3 '+ nil 2 :rest-type 'integer :maxargs 10)
(def-type-prop-test \+.4 '+ '(real real) 2 :test #'approx=)
(def-type-prop-test \+.5 '+ '(number number) 2 :test #'approx=)
(def-type-prop-test \-.1 '- '(integer integer) 2)
(def-type-prop-test \-.2 '- nil 1 :rest-type 'integer :maxargs 4)
(def-type-prop-test \-.3 '- nil 2 :rest-type 'integer :maxargs 10)
(def-type-prop-test \-.4 '- '(real real) 2 :test #'approx=)
(def-type-prop-test \-.5 '- '(number number) 2 :test #'approx=)
(def-type-prop-test \-.6 '- '(number) 1)
;;; WARNING -- these tests may cause floating point overflow/underflow
;;; Ignore those failures
(def-type-prop-test /.1 '/ '((and integer (not (satisfies zerop)))) 1)
(def-type-prop-test /.2 '/ '((and rational (not (satisfies zerop)))) 1)
(def-type-prop-test /.3 '/ '((and real (not (satisfies zerop)))) 1 :ignore 'arithmetic-error)
(def-type-prop-test /.4 '/ '((and complex (not (satisfies zerop)))) 1 :ignore 'arithmetic-error)
(def-type-prop-test /.5 '/ '(integer) 2 :maxargs 6 :rest-type '(and integer (not (satisfies zerop))))
(def-type-prop-test /.6 '/ '(rational) 2 :maxargs 6 :rest-type '(and rational (not (satisfies zerop))))
(def-type-prop-test /.7 '/ '(real) 2 :maxargs 6 :rest-type '(and real (not (satisfies zerop)))
:test #'approx= :ignore 'arithmetic-error)
(def-type-prop-test /.8 '/ '(number) 2 :maxargs 6 :rest-type '(and number (not (satisfies zerop)))
:test #'approx= :ignore 'arithmetic-error)
(def-type-prop-test 1+.1 '1+ '(integer) 1)
(def-type-prop-test 1+.2 '1+ '(rational) 1)
(def-type-prop-test 1+.3 '1+ '(real) 1)
(def-type-prop-test 1+.4 '1+ '(number) 1)
(def-type-prop-test 1-.1 '1- '(integer) 1)
(def-type-prop-test 1-.2 '1- '(rational) 1)
(def-type-prop-test 1-.3 '1- '(real) 1)
(def-type-prop-test 1-.4 '1- '(number) 1)
(def-type-prop-test abs.1 'abs '(integer) 1)
(def-type-prop-test abs.2 'abs '(rational) 1)
(def-type-prop-test abs.3 'abs '(real) 1)
(def-type-prop-test abs.4 'abs '(number) 1)
(def-type-prop-test evenp 'evenp '(integer) 1)
(def-type-prop-test oddp 'oddp '(integer) 1)
;;; exp, expt here
(def-type-prop-test gcd 'gcd nil 1 :maxargs 6 :rest-type 'integer)
(def-type-prop-test lcm 'lcm nil 1 :maxargs 6 :rest-type 'integer)
(def-type-prop-test log.1 'log '((and real (not (satisfies zerop)))) 1 :test #'approx=)
(def-type-prop-test log.2 'log '((and number (not (satisfies zerop)))) 1 :test #'approx=)
(def-type-prop-test mod.1 'mod '(integer (and integer (not (satisfies zerop)))) 2)
(def-type-prop-test mod.2 'mod '(real (and real (not (satisfies zerop)))) 2 :test #'approx=)
(def-type-prop-test rem.1 'rem '(integer (and integer (not (satisfies zerop)))) 2)
(def-type-prop-test rem.2 'rem '(real (and real (not (satisfies zerop)))) 2 :test #'approx=)
(def-type-prop-test signum.1 'signum '(integer) 1)
(def-type-prop-test signum.2 'signum '(rational) 1)
(def-type-prop-test signum.3 'signum '(real) 1)
(def-type-prop-test signum.4 'signum '(number) 1)
(def-type-prop-test sqrt.1 'sqrt '(integer) 1 :test #'approx=)
(def-type-prop-test sqrt.2 'sqrt '(rational) 1 :test #'approx=)
(def-type-prop-test sqrt.3 'sqrt '(real) 1 :test #'approx=)
(def-type-prop-test sqrt.4 'sqrt '(number) 1 :test #'approx=)
(def-type-prop-test isqrt 'isqrt '((integer 0)) 1)
(def-type-prop-test numberp 'numberp '(t) 1)
(def-type-prop-test complex.1 'complex '(integer) 1)
(def-type-prop-test complex.2 'complex '(rational) 1)
(def-type-prop-test complex.3 'complex '(real) 1)
(def-type-prop-test complex.4 'complex '(rational rational) 2)
(def-type-prop-test complex.5 'complex '(real real) 2)
(def-type-prop-test complexp 'complexp '(t) 1)
(def-type-prop-test conjugate 'conjugate '(number) 1)
(def-type-prop-test phase.1 'phase '(real) 1)
(def-type-prop-test phase.2 'phase '(number) 1 :test #'approx=)
(def-type-prop-test realpart.1 'realpart '(real) 1)
(def-type-prop-test realpart.2 'realpart '(number) 1)
(def-type-prop-test imagpart.1 'imagpart '(real) 1)
(def-type-prop-test imagpart.2 'imagpart '(number) 1)
(def-type-prop-test realp 'realp '(t) 1)
(def-type-prop-test numerator 'numerator '(rational) 1)
(def-type-prop-test denominator 'denominator '(rational) 1)
(def-type-prop-test rational 'rational '(real) 1)
(def-type-prop-test rationalize 'rationalize '(real) 1)
(def-type-prop-test rationalp 'rationalp '(t) 1)
(def-type-prop-test ash.1 'ash '(integer (integer -32 32)) 2)
(def-type-prop-test ash.2 'ash '(integer (integer -100 100)) 2)
(def-type-prop-test integer-length 'integer-length '(integer) 1)
(def-type-prop-test integerp 'integerp '(t) 1)
(def-type-prop-test logand.1 'logand '(integer integer) 2)
(def-type-prop-test logand.2 'logand nil 2 :rest-type 'integer :maxargs 6)
(def-type-prop-test logandc1 'logandc1 '(integer integer) 2)
(def-type-prop-test logandc2 'logandc2 '(integer integer) 2)
(def-type-prop-test lognand 'lognand '(integer integer) 2)
(def-type-prop-test lognor 'lognor '(integer integer) 2)
(def-type-prop-test logeqv.1 'logeqv '(integer integer) 2)
(def-type-prop-test logeqv.2 'logeqv nil 2 :rest-type 'integer :maxargs 6)
(def-type-prop-test logior.1 'logior '(integer integer) 2)
(def-type-prop-test logior.2 'logior nil 2 :rest-type 'integer :maxargs 6)
(def-type-prop-test logxor.1 'logxor '(integer integer) 2)
(def-type-prop-test logxor.2 'logxor nil 2 :rest-type 'integer :maxargs 6)
(def-type-prop-test logorc1 'logorc1 '(integer integer) 2)
(def-type-prop-test logorc2 'logorc2 '(integer integer) 2)
(def-type-prop-test lognot 'lognot '(integer) 1)
(def-type-prop-test logbitp.1 'logbitp '((integer 0 32) integer) 2)
(def-type-prop-test logbitp.2 'logbitp '((integer 0 100) integer) 2)
; (def-type-prop-test logbitp.3 'logbitp '((integer 0) integer) 2)
(def-type-prop-test logcount 'logcount '(integer) 1)
(def-type-prop-test logtest 'logtest '(integer integer) 2)
(def-type-prop-test decode-float.1 'decode-float '(float) 1)
(def-type-prop-test decode-float.2 '(lambda (x) (nth-value 1 (decode-float x))) '(float) 1)
(def-type-prop-test decode-float.3 '(lambda (x) (nth-value 2 (decode-float x))) '(float) 1)
(def-type-prop-test float-radix 'float-radix '(float) 1)
(def-type-prop-test scale-float 'scale-float '(float (integer -30 30)) 2 :ignore 'arithmetic-error :test #'approx=)
(def-type-prop-test float-sign.1 'float-sign '(float) 1)
(def-type-prop-test float-sign.2 'float-sign '(float float) 2)
(def-type-prop-test float-digits 'float-digits '(float) 1)
(def-type-prop-test float-precision 'float-precision '(float) 1)
(def-type-prop-test integer-decode-float.1 'integer-decode-float '(float) 1)
(def-type-prop-test integer-decode-float.2 '(lambda (x) (nth-value 1 (integer-decode-float x))) '(float) 1)
(def-type-prop-test integer-decode-float.3 '(lambda (x) (nth-value 2 (integer-decode-float x))) '(float) 1)
(def-type-prop-test float.1 'float '(real) 1)
(def-type-prop-test float.2 'float '(real float) 2)
(def-type-prop-test floatp 'floatp '(t) 1)
(defun has-nonzero-length (x) (> (length x) 0))
(def-type-prop-test parse-integer.1 'parse-integer
'((and (vector (member #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
(satisfies has-nonzero-length)))
1)
(def-type-prop-test parse-integer.2 'parse-integer
`((and (vector (member #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
(satisfies has-nonzero-length))
(eql :start)
,#'(lambda (x &rest rest) (declare (ignore rest))
`(integer 0 (,(length x)))))
3)
(def-type-prop-test sxhash 'sxhash '(t) 1)
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Sun Mar 6 21:44:41 2005
;;;; Contains: Test that invoke the random type prop infrastructure, part 4
(in-package :cl-test)
(defun char-or-same (c &rest args)
(declare (ignore args))
(if (coin) `(eql ,c) 'character))
(eval-when (:load-toplevel :execute) (compile 'char-or-same))
(def-type-prop-test char=.1 'char= nil 2 :rest-type 'base-char :maxargs 5)
(def-type-prop-test char=.2 'char= '(character character) 2)
(def-type-prop-test char=.3 'char= (list 'character #'char-or-same) 2)
(def-type-prop-test char=.4 'char= (list 'character #'char-or-same #'char-or-same) 3)
(def-type-prop-test char=.5 'char= '(character) 3 :rest-type #'char-or-same :maxargs 6)
(def-type-prop-test char/=.1 'char/= nil 2 :rest-type 'base-char :maxargs 5)
(def-type-prop-test char/=.2 'char/= '(character character) 2)
(def-type-prop-test char/=.3 'char/= (list 'character #'char-or-same) 2)
(def-type-prop-test char/=.4 'char/= (list 'character 'character #'char-or-same) 3)
(def-type-prop-test char/=.5 'char/= nil 2 :rest-type 'character :maxargs 6)
(def-type-prop-test char<=.1 'char<= nil 2 :rest-type 'base-char :maxargs 5)
(def-type-prop-test char<=.2 'char<= '(character character) 2)
(def-type-prop-test char<=.3 'char<= (list 'character #'char-or-same) 2)
(def-type-prop-test char<=.4 'char<= (list 'character #'char-or-same #'char-or-same) 3)
(def-type-prop-test char<=.5 'char<= '(character) 3 :rest-type #'char-or-same :maxargs 6)
(def-type-prop-test char>=.1 'char>= nil 2 :rest-type 'base-char :maxargs 5)
(def-type-prop-test char>=.2 'char>= '(character character) 2)
(def-type-prop-test char>=.3 'char>= (list 'character #'char-or-same) 2)
(def-type-prop-test char>=.4 'char>= (list 'character #'char-or-same #'char-or-same) 3)
(def-type-prop-test char>=.5 'char>= '(character) 3 :rest-type #'char-or-same :maxargs 6)
(def-type-prop-test char<.1 'char< nil 2 :rest-type 'base-char :maxargs 5)
(def-type-prop-test char<.2 'char< '(character character) 2)
(def-type-prop-test char<.3 'char< (list 'character #'char-or-same) 2)
(def-type-prop-test char<.4 'char< (list 'character 'character #'char-or-same) 3)
(def-type-prop-test char<.5 'char< nil 2 :rest-type 'character :maxargs 6)
(def-type-prop-test char>.1 'char> nil 2 :rest-type 'base-char :maxargs 5)
(def-type-prop-test char>.2 'char> '(character character) 2)
(def-type-prop-test char>.3 'char> (list 'character #'char-or-same) 2)
(def-type-prop-test char>.4 'char> (list 'character 'character #'char-or-same) 3)
(def-type-prop-test char>.5 'char> nil 2 :rest-type 'character :maxargs 6)
(def-type-prop-test char-equal.1 'char-equal nil 2 :rest-type 'base-char :maxargs 5)
(def-type-prop-test char-equal.2 'char-equal '(character character) 2)
(def-type-prop-test char-equal.3 'char-equal (list 'character #'char-or-same) 2)
(def-type-prop-test char-equal.4 'char-equal (list 'character #'char-or-same #'char-or-same) 3)
(def-type-prop-test char-equal.5 'char-equal '(character) 3 :rest-type #'char-or-same :maxargs 6)
(def-type-prop-test char-not-equal.1 'char-not-equal nil 2 :rest-type 'base-char :maxargs 5)
(def-type-prop-test char-not-equal.2 'char-not-equal '(character character) 2)
(def-type-prop-test char-not-equal.3 'char-not-equal (list 'character #'char-or-same) 2)
(def-type-prop-test char-not-equal.4 'char-not-equal (list 'character 'character #'char-or-same) 3)
(def-type-prop-test char-not-equal.5 'char-not-equal nil 2 :rest-type 'character :maxargs 6)
(def-type-prop-test char-not-greaterp.1 'char-not-greaterp nil 2 :rest-type 'base-char :maxargs 5)
(def-type-prop-test char-not-greaterp.2 'char-not-greaterp '(character character) 2)
(def-type-prop-test char-not-greaterp.3 'char-not-greaterp (list 'character #'char-or-same) 2)
(def-type-prop-test char-not-greaterp.4 'char-not-greaterp (list 'character #'char-or-same #'char-or-same) 3)
(def-type-prop-test char-not-greaterp.5 'char-not-greaterp '(character) 3 :rest-type #'char-or-same :maxargs 6)
(def-type-prop-test char-not-lessp.1 'char-not-lessp nil 2 :rest-type 'base-char :maxargs 5)
(def-type-prop-test char-not-lessp.2 'char-not-lessp '(character character) 2)
(def-type-prop-test char-not-lessp.3 'char-not-lessp (list 'character #'char-or-same) 2)
(def-type-prop-test char-not-lessp.4 'char-not-lessp (list 'character #'char-or-same #'char-or-same) 3)
(def-type-prop-test char-not-lessp.5 'char-not-lessp '(character) 3 :rest-type #'char-or-same :maxargs 6)
(def-type-prop-test char-lessp.1 'char-lessp nil 2 :rest-type 'base-char :maxargs 5)
(def-type-prop-test char-lessp.2 'char-lessp '(character character) 2)
(def-type-prop-test char-lessp.3 'char-lessp (list 'character #'char-or-same) 2)
(def-type-prop-test char-lessp.4 'char-lessp (list 'character 'character #'char-or-same) 3)
(def-type-prop-test char-lessp.5 'char-lessp nil 2 :rest-type 'character :maxargs 6)
(def-type-prop-test char-greaterp.1 'char-greaterp nil 2 :rest-type 'base-char :maxargs 5)
(def-type-prop-test char-greaterp.2 'char-greaterp '(character character) 2)
(def-type-prop-test char-greaterp.3 'char-greaterp (list 'character #'char-or-same) 2)
(def-type-prop-test char-greaterp.4 'char-greaterp (list 'character 'character #'char-or-same) 3)
(def-type-prop-test char-greaterp.5 'char-greaterp nil 2 :rest-type 'character :maxargs 6)
(defun length1-p (seq) (= (length seq) 1))
(def-type-prop-test character 'character '((or character (and (string 1) (satisfies length1-p)))) 1)
(def-type-prop-test characterp 'characterp '(t) 1)
(def-type-prop-test alpha-char-p 'alpha-char-p '(character) 1)
(def-type-prop-test alphanumericp 'alphanumericp '(character) 1)
(def-type-prop-test digit-char 'digit-char '((or (integer 0 36) (integer 0)) (integer 2 36)) 1 :maxargs 2)
(def-type-prop-test digit-char-p 'digit-char-p '(character) 1)
(def-type-prop-test graphic-char-p 'graphic-char-p '(character) 1)
(def-type-prop-test standard-char-p 'standard-char-p '(character) 1)
(def-type-prop-test char-upcase 'char-upcase '(character) 1)
(def-type-prop-test char-downcase 'char-downcase '(character) 1)
(def-type-prop-test upper-case-p 'upper-case-p '(character) 1)
(def-type-prop-test lower-case-p 'lower-case-p '(character) 1)
(def-type-prop-test both-case-p 'both-case-p '(character) 1)
(def-type-prop-test char-code 'char-code '(character) 1)
(def-type-prop-test char-int 'char-int '(character) 1)
(def-type-prop-test code-char 'code-char '((integer 0 #.char-code-limit)) 1)
(def-type-prop-test char-name 'char-name '(character) 1)
(def-type-prop-test name-char 'name-char '(string) 1)
This diff is collapsed.
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Sun Mar 13 15:33:55 2005
;;;; Contains: Random type prop tests, part 6 (arrays)
(in-package :cl-test)
(def-type-prop-test adjustable-array-p 'adjustable-array-p '(array) 1)
(def-type-prop-test aref.0 'aref '((array * nil)) 1)
(def-type-prop-test aref.1 'aref (list '(array * (*)) (index-type-for-dim 0)) 2)
(def-type-prop-test aref.2 'aref (list '(array * (* *)) (index-type-for-dim 0) (index-type-for-dim 1)) 3)
(def-type-prop-test aref.3 'aref (list '(array * (* * *))
(index-type-for-dim 0) (index-type-for-dim 1) (index-type-for-dim 2))
4)
(def-type-prop-test array-dimension 'array-dimension
(list 'array #'(lambda (x) (let ((r (array-rank x))) (and (> r 0) `(integer 0 (,r))))))
2)
(def-type-prop-test array-dimensions 'array-dimensions '(array) 1)
(def-type-prop-test array-element-type 'array-element-type '(array) 1)
(def-type-prop-test array-has-fill-pointer-p.1 'array-has-fill-pointer-p '(array) 1)
(def-type-prop-test array-has-fill-pointer-p.2 'array-has-fill-pointer-p '(vector) 1)
(def-type-prop-test array-displacement.1 'array-displacement '(array) 1)
(def-type-prop-test array-displacement.2 'array-displacement '(vector) 1)
(def-type-prop-test array-in-bounds-p.0 'array-in-bounds-p '((array * nil)) 1)
(def-type-prop-test array-in-bounds-p.1 'array-in-bounds-p (list '(array * (*)) (index-type-for-dim 0)) 2)
(def-type-prop-test array-in-bounds-p.2 'array-in-bounds-p
(list '(array * (* *)) (index-type-for-dim 0) (index-type-for-dim 1)) 3)
(def-type-prop-test array-in-bounds-p.3 'array-in-bounds-p
(list '(array * (* * *)) (index-type-for-dim 0) (index-type-for-dim 1) (index-type-for-dim 2))
4)
(def-type-prop-test array-in-bounds-p.4 'array-in-bounds-p '((array * (*)) integer) 2)
(def-type-prop-test array-in-bounds-p.5 'array-in-bounds-p '((array * (* *)) integer integer) 3)
(def-type-prop-test array-in-bounds-p.6 'array-in-bounds-p '((array * (* * *)) integer integer integer) 4)
(def-type-prop-test array-rank 'array-rank '(array) 1)
(def-type-prop-test array-row-major-index.0 'array-row-major-index '((array * nil)) 1)
(def-type-prop-test array-row-major-index.1 'array-row-major-index (list '(array * (*)) (index-type-for-dim 0)) 2)
(def-type-prop-test array-row-major-index.2 'array-row-major-index
(list '(array * (* *)) (index-type-for-dim 0) (index-type-for-dim 1)) 3)
(def-type-prop-test array-row-major-index.3 'array-row-major-index
(list '(array * (* * *)) (index-type-for-dim 0) (index-type-for-dim 1) (index-type-for-dim 2))
4)
(def-type-prop-test array-total-size 'array-total-size '(array) 1)
(def-type-prop-test arrayp 'arrayp '(t) 1)
(def-type-prop-test fill-pointer '(lambda (x) (and (array-has-fill-pointer-p x) (fill-pointer x))) '(vector) 1)
(def-type-prop-test row-major-aref 'row-major-aref
(list 'array #'(lambda (a) (let ((s (array-total-size a))) (and (> s 0) `(integer 0 (,s))))))
2)
(def-type-prop-test upgraded-array-element-type 'upgraded-array-element-type
(list #'(lambda () (let ((x (make-random-element-of-type t)))
`(eql ,(make-random-type-containing x)))))
1)
(def-type-prop-test simple-vector-p.1 'simple-vector-p '(t) 1)
(def-type-prop-test simple-vector-p.2 'simple-vector-p '(vector) 1)
(def-type-prop-test svref 'svref (list 'simple-vector (index-type-for-dim 0)) 2)
(def-type-prop-test vector 'vector nil 1 :rest-type t :maxargs 10)
(def-type-prop-test vectorp.1 'vectorp '(t) 1)
(def-type-prop-test vectorp.2 'vectorp '(array) 1)
(def-type-prop-test bit.1 'bit (list '(array bit (*)) (index-type-for-dim 0)) 2)
(def-type-prop-test bit.2 'bit (list '(array bit (* *)) (index-type-for-dim 0) (index-type-for-dim 1)) 3)
(def-type-prop-test bit.3 'bit
(list '(array bit (* * *)) (index-type-for-dim 0) (index-type-for-dim 1) (index-type-for-dim 2))
4)
(def-type-prop-test sbit.1 'sbit (list '(simple-array bit (*)) (index-type-for-dim 0)) 2)
(def-type-prop-test sbit.2 'sbit (list '(simple-array bit (* *)) (index-type-for-dim 0) (index-type-for-dim 1)) 3)
(def-type-prop-test sbit.3 'sbit
(list '(simple-array bit (* * *)) (index-type-for-dim 0) (index-type-for-dim 1) (index-type-for-dim 2))
4)
(def-type-prop-test bit-and.1 'bit-and (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a)))
`(array bit ,dims))))
2)
(def-type-prop-test bit-and.2 'bit-and
(list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null)
3)
(def-type-prop-test bit-andc1.1 'bit-andc1 (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a)))
`(array bit ,dims))))
2)
(def-type-prop-test bit-andc1.2 'bit-andc1
(list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null)
3)
(def-type-prop-test bit-andc2.1 'bit-andc2 (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a)))
`(array bit ,dims))))
2)
(def-type-prop-test bit-andc2.2 'bit-andc2
(list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null)
3)
(def-type-prop-test bit-ior.1 'bit-ior (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a)))
`(array bit ,dims))))
2)
(def-type-prop-test bit-ior.2 'bit-ior
(list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null)
3)
(def-type-prop-test bit-orc1.1 'bit-orc1 (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a)))
`(array bit ,dims))))
2)
(def-type-prop-test bit-orc1.2 'bit-orc1
(list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null)
3)
(def-type-prop-test bit-orc2.1 'bit-orc2 (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a)))
`(array bit ,dims))))
2)
(def-type-prop-test bit-orc2.2 'bit-orc2
(list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null)
3)
(def-type-prop-test bit-eqv.1 'bit-eqv (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a)))
`(array bit ,dims))))
2)
(def-type-prop-test bit-eqv.2 'bit-eqv
(list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null)
3)
(def-type-prop-test bit-xor.1 'bit-xor (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a)))
`(array bit ,dims))))
2)
(def-type-prop-test bit-xor.2 'bit-xor
(list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null)
3)
(def-type-prop-test bit-nand.1 'bit-nand (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a)))
`(array bit ,dims))))
2)
(def-type-prop-test bit-nand.2 'bit-nand
(list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null)
3)
(def-type-prop-test bit-nor.1 'bit-nor (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a)))
`(array bit ,dims))))
2)
(def-type-prop-test bit-nor.2 'bit-nor
(list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null)
3)
(def-type-prop-test bit-not.1 'bit-not '((array bit)) 1)
(def-type-prop-test bit-not.2 'bit-not '((array bit) null) 2)
(def-type-prop-test bit-vector-p 'bit-vector-p '(t) 1)
(def-type-prop-test simple-bit-vector-p 'simple-bit-vector-p '(t) 1)
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Sun Mar 13 17:03:52 2005
;;;; Contains: Random type prop tests, part 7 (strings)
(in-package :cl-test)
(def-type-prop-test simple-string-p 'simple-string-p '(t) 1)
(def-type-prop-test char 'char (list 'string (index-type-for-dim 0)) 2)
(def-type-prop-test schar 'schar (list 'simple-string (index-type-for-dim 0)) 2)
(def-type-prop-test string 'string '((or string symbol character)) 1)
(def-type-prop-test string-upcase 'string-upcase '(string) 1)
(def-type-prop-test string-downcase 'string-downcase '(string) 1)
(def-type-prop-test string-capitalize 'string-capitalize '(string) 1)
(def-type-prop-test string-trim.1 'string-trim '(string string) 2)
(def-type-prop-test string-trim.2 'string-trim (list #'(lambda () (make-list-type (random 10) 'null 'character))
'string)
2)
(def-type-prop-test string-left-trim.1 'string-left-trim '(string string) 2)
(def-type-prop-test string-left-trim.2 'string-left-trim (list #'(lambda () (make-list-type (random 10) 'null 'character))
'string)
2)
(def-type-prop-test string-right-trim.1 'string-right-trim '(string string) 2)
(def-type-prop-test string-right-trim.2 'string-right-trim
(list #'(lambda () (make-list-type (random 10) 'null 'character)) 'string)
2)
(defmacro def-string-comparison-type-prop-test (op)
(flet ((%makename (n) (intern (format nil "~A.~A" op n) :cl-test)))
`(progn
(def-type-prop-test ,(%makename 1) ',op '(string string) 2)
(def-type-prop-test ,(%makename 2) ',op
`(string string (eql :start1) ,#'index-type-for-v1)
4)
(def-type-prop-test ,(%makename 3) ',op
`(string string (eql :start2) ,#'index-type-for-v2)
4)
(def-type-prop-test ,(%makename 4) ',op
`(string string (eql :end1) ,#'end-type-for-v1)
4)
(def-type-prop-test ,(%makename 5) ',op
`(string string (eql :end2) ,#'end-type-for-v2)
4)
(def-type-prop-test ,(%makename 6) ',op
`(string string
(eql :start1) ,#'index-type-for-v1
(eql :end1) ,#'end-type-for-v1)
6)
(def-type-prop-test ,(%makename 7) ',op
`(string string
(eql :start1) ,#'index-type-for-v1
(eql :end2) ,#'end-type-for-v2)
6)
(def-type-prop-test ,(%makename 8) ',op
`(string string
(eql :start2) ,#'index-type-for-v2
(eql :end1) ,#'end-type-for-v1)
6)
(def-type-prop-test ,(%makename 9) ',op
`(string string
(eql :start2) ,#'index-type-for-v2
(eql :end2) ,#'end-type-for-v2)
6)
(def-type-prop-test ,(%makename 10) ',op
`(string string
(eql :start1) ,#'index-type-for-v1
(eql :start2) ,#'index-type-for-v2
(eql :end1) ,#'end-type-for-v1)
8)
(def-type-prop-test ,(%makename 11) ',op
`(string string
(eql :start1) ,#'index-type-for-v1
(eql :start2) ,#'index-type-for-v2
(eql :end2) ,#'end-type-for-v2)
8)
(def-type-prop-test ,(%makename 12) ',op
`(string string
(eql :start1) ,#'index-type-for-v1
(eql :end2) ,#'end-type-for-v2
(eql :end1) ,#'end-type-for-v1)
8)
(def-type-prop-test ,(%makename 13) ',op
`(string string
(eql :start2) ,#'index-type-for-v2
(eql :end2) ,#'end-type-for-v2
(eql :end1) ,#'end-type-for-v1)
8)
(def-type-prop-test ,(%makename 14) ',op
`(string string
(eql :start1) ,#'index-type-for-v1
(eql :start2) ,#'index-type-for-v2
(eql :end2) ,#'end-type-for-v2
(eql :end1) ,#'end-type-for-v1)
10)
)))
(def-string-comparison-type-prop-test string=)
(def-string-comparison-type-prop-test string/=)
(def-string-comparison-type-prop-test string<)
(def-string-comparison-type-prop-test string<=)
(def-string-comparison-type-prop-test string>)
(def-string-comparison-type-prop-test string>=)
(def-string-comparison-type-prop-test string-equal)
(def-string-comparison-type-prop-test string-not-equal)
(def-string-comparison-type-prop-test string-lessp)
(def-string-comparison-type-prop-test string-greaterp)
(def-string-comparison-type-prop-test string-not-lessp)
(def-string-comparison-type-prop-test string-not-greaterp)
(def-type-prop-test stringp 'stringp '(t) 1)
(def-type-prop-test make-string.1 'make-string '((integer 0 100) (eql :initial-element) character) 3)
(def-type-prop-test make-string.2 'make-string `((integer 0 100) (eql :initial-element) character
(eql :element-type)
,#'(lambda (&rest args)
`(eql (and character
,(make-random-type-containing (third args))))))
5)
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Sun Mar 13 18:31:57 2005
;;;; Contains: Random type prop tests, part 8 (sequences)
(in-package :cl-test)
(def-type-prop-test copy-seq 'copy-seq '((or vector list)) 1)
(def-type-prop-test elt 'elt (list '(or vector list)
#'(lambda (x) (let ((len (length x)))
(and (> len 0) `(integer 0 (,len))))))
2)
(defmacro rfill (x y &rest other-args)
`(fill ,y ,x ,@other-args))
(def-type-prop-test fill.1 'rfill
(list t #'make-random-sequence-type-containing)
2 :replicate '(nil t))
(def-type-prop-test fill.2 'rfill
(list 'integer #'make-random-sequence-type-containing)
2 :replicate '(nil t))
(def-type-prop-test fill.3 'rfill
(list 'character #'make-random-sequence-type-containing)
2 :replicate '(nil t))
(def-type-prop-test fill.4 'rfill
(list t #'make-random-sequence-type-containing
'(eql :start)
#'(lambda (v s k1) (declare (ignore v k1))
(let ((len (length s)))
`(integer 0 ,len))))
4 :replicate '(nil t nil nil))
(def-type-prop-test fill.5 'rfill
(list t #'make-random-sequence-type-containing
'(eql :end)
#'(lambda (v s k1) (declare (ignore v k1))
(let ((len (length s)))
`(integer 0 ,len))))
4 :replicate '(nil t nil nil))
(def-type-prop-test fill.6 'rfill
(list t #'make-random-sequence-type-containing
'(eql :start)
#'(lambda (v s k1) (declare (ignore v k1))
(let ((len (length s)))
`(integer 0 ,len)))
'(eql :end)
#'(lambda (v s k1 start k2)
(declare (ignore v k1 k2))
(let ((len (length s)))
`(integer ,start ,len))))
6 :replicate '(nil t nil nil nil nil))
;;; make-sequence tests here
(def-type-prop-test subseq.1 'subseq
(list 'sequence #'(lambda (s) `(integer 0 ,(length s))))
2)
(def-type-prop-test subseq.2 'subseq
(list 'sequence #'(lambda (s) `(integer 0 ,(length s)))
#'(lambda (s start) `(integer ,start ,(length s))))
3)
;;; map tests here
(def-type-prop-test map.1 'map
(list '(member list vector)
'(member list #.#'list)
'(or list vector))
3)
(def-type-prop-test map.2 'map
(list '(member list vector)
'(member list #.#'list)
'(or list vector)
'(or list vector))
4)
(def-type-prop-test map.3 'map
(list '(member list vector)
'(member list #.#'list)
'(or list vector)
'(or list vector)
'(or list vector))
5)
(def-type-prop-test map.4 'map
(list '(member list vector (vector (unsigned-byte 32)))
'(member 1+ #.#'1+)
`(or ,@(loop for i from 1 to 31 collect `(vector (unsigned-byte ,i)))))
3)
(def-type-prop-test map.5 'map
(list `(member ,@(loop for i from 1 to 32 collect `(vector (unsigned-byte ,i))))
'(member 1+ #.#'1+)
#'(lambda (type fun)
(declare (ignore fun))
(let ((i (cadadr type)))
`(or ,@(loop for j from i to 32 collect `(vector (integer 0 ,(- (ash 1 i) 2))))))))
3)
;;; map-into tests here
(def-type-prop-test map-into.1 'map-into
(list '(or list (vector t))
'(member list #.#'list)
'(or list vector))
3 :replicate '(t nil nil))
(def-type-prop-test map-into.2 'map-into
(list '(or list (vector t))
'(member list #.#'list)
'(or list vector)
'(or list vector))
4 :replicate '(t nil nil nil))
;;; reduce tests here
(def-type-prop-test count.1 'count '(t sequence) 2)
(def-type-prop-test count.2 'count
(list t #'make-random-sequence-type-containing)
2)
(def-type-prop-test count.3 'count
(list t #'make-random-sequence-type-containing
'(eql :start)
#'(lambda (x s k1) (declare (ignore x k1))
`(integer 0 ,(length s))))
4)
(def-type-prop-test count.4 'count
(list t #'make-random-sequence-type-containing
'(eql :end)
#'(lambda (x s k1) (declare (ignore x k1))
`(integer 0 ,(length s))))
4)
(def-type-prop-test count.5 'count
(list t #'make-random-sequence-type-containing
'(eql :start)
#'(lambda (x s k1) (declare (ignore x k1))
`(integer 0 ,(length s)))
'(eql :end)
#'(lambda (x s k1 start k2) (declare (ignore x k1 k2))
`(integer ,start ,(length s))))
6)
(def-type-prop-test count.6 'count
(list '(or short-float single-float double-float long-float)
#'(lambda (f) `(vector (or ,(typecase f
(short-float 'short-float)
(single-float 'single-float)
(double-float 'double-float)
(long-float 'long-float)
(t 'float))
(eql ,f)))))
2)
(def-type-prop-test count.7 'count '(bit (vector bit)) 2)
(def-type-prop-test count.8 'count '((unsigned-byte 2) (vector (unsigned-byte 2))) 2)
(def-type-prop-test count.9 'count '((unsigned-byte 4) (vector (unsigned-byte 4))) 2)
(def-type-prop-test count.10 'count '((unsigned-byte 8) (vector (unsigned-byte 8))) 2)
;;; count-if tests
(def-type-prop-test count-if.1 'count-if
(list (let ((funs '(numberp rationalp realp floatp complexp
symbolp identity null functionp listp consp
arrayp vectorp simple-vector-p
stringp simple-string-p
bit-vector-p simple-bit-vector-p)))
`(member ,@funs ,@(mapcar #'symbol-function funs)))
'(or list vector))
2)
(def-type-prop-test count-if.2 'count-if
(list (let ((funs '(numberp rationalp realp floatp complexp
symbolp identity null functionp listp consp
arrayp vectorp simple-vector-p
stringp simple-string-p
bit-vector-p simple-bit-vector-p)))
`(member ,@funs ,@(mapcar #'symbol-function funs)))
'(or list vector)
'(eql :key)
(let ((key-funs '(identity not null)))
`(member ,@key-funs ,@(mapcar #'symbol-function key-funs))))
4)
;;; Put count-if-not tests here
(def-type-prop-test length.1 'length '(sequence) 1)
(def-type-prop-test reverse.1 'reverse '(sequence) 1)
(def-type-prop-test nreverse.1 'nreverse '(sequence) 1 :replicate '(t))
(def-type-prop-test sort.1 'sort
`((vector bit) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2
:replicate '(t nil))
(def-type-prop-test sort.2 'sort
`((or (vector (unsigned-byte 2))
(vector (unsigned-byte 3))
(vector (unsigned-byte 4))
(vector (unsigned-byte 5))
(vector (unsigned-byte 6))
(vector (unsigned-byte 7))
(vector (unsigned-byte 8)))
(member < <= > >= ,#'< ,#'<= ,#'> ,#'>=))
2 :replicate '(t nil))
(def-type-prop-test sort.3 'sort
`((or (vector (unsigned-byte 10))
(vector (unsigned-byte 13))
(vector (unsigned-byte 15))
(vector (unsigned-byte 16)))
(member < <= > >= ,#'< ,#'<= ,#'> ,#'>=))
2 :replicate '(t nil))
(def-type-prop-test sort.4 'sort
`((or (vector (unsigned-byte 20))
(vector (unsigned-byte 24))
(vector (unsigned-byte 28))
(vector (unsigned-byte 31))
(vector (unsigned-byte 32)))
(member < <= > >= ,#'< ,#'<= ,#'> ,#'>=))
2 :replicate '(t nil))
(def-type-prop-test sort.5 'sort
`((or (vector (signed-byte 2))
(vector (signed-byte 3))
(vector (signed-byte 4))
(vector (signed-byte 5))
(vector (signed-byte 6))
(vector (signed-byte 7))
(vector (signed-byte 8)))
(member < <= > >= ,#'< ,#'<= ,#'> ,#'>=))
2 :replicate '(t nil))
(def-type-prop-test sort.6 'sort
`((or (vector (signed-byte 10))
(vector (signed-byte 13))
(vector (signed-byte 15))
(vector (signed-byte 16)))
(member < <= > >= ,#'< ,#'<= ,#'> ,#'>=))
2 :replicate '(t nil))
(def-type-prop-test sort.7 'sort
`((or (vector (signed-byte 20))
(vector (signed-byte 24))
(vector (signed-byte 28))
(vector (signed-byte 31))
(vector (signed-byte 32)))
(member < <= > >= ,#'< ,#'<= ,#'> ,#'>=))
2 :replicate '(t nil))
(def-type-prop-test sort.8 'sort
`((or (vector short-float)
(vector single-float)
(vector double-float)
(vector long-float))
(member < <= > >= ,#'< ,#'<= ,#'> ,#'>=))
2 :replicate '(t nil))
;;; Stable sort
(def-type-prop-test stable-sort.1 'stable-sort
`((vector bit) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2
:replicate '(t nil))
(def-type-prop-test stable-sort.2 'stable-sort
`((or (vector (unsigned-byte 2))
(vector (unsigned-byte 3))
(vector (unsigned-byte 4))
(vector (unsigned-byte 5))
(vector (unsigned-byte 6))
(vector (unsigned-byte 7))
(vector (unsigned-byte 8)))
(member < <= > >= ,#'< ,#'<= ,#'> ,#'>=))
2 :replicate '(t nil))
(def-type-prop-test stable-sort.3 'stable-sort
`((or (vector (unsigned-byte 10))
(vector (unsigned-byte 13))
(vector (unsigned-byte 15))
(vector (unsigned-byte 16)))
(member < <= > >= ,#'< ,#'<= ,#'> ,#'>=))
2 :replicate '(t nil))
(def-type-prop-test stable-sort.4 'stable-sort
`((or (vector (unsigned-byte 20))
(vector (unsigned-byte 24))
(vector (unsigned-byte 28))
(vector (unsigned-byte 31))
(vector (unsigned-byte 32)))
(member < <= > >= ,#'< ,#'<= ,#'> ,#'>=))
2 :replicate '(t nil))
(def-type-prop-test stable-sort.5 'stable-sort
`((or (vector (signed-byte 2))
(vector (signed-byte 3))
(vector (signed-byte 4))
(vector (signed-byte 5))
(vector (signed-byte 6))
(vector (signed-byte 7))
(vector (signed-byte 8)))
(member < <= > >= ,#'< ,#'<= ,#'> ,#'>=))
2 :replicate '(t nil))
(def-type-prop-test stable-sort.6 'stable-sort
`((or (vector (signed-byte 10))
(vector (signed-byte 13))
(vector (signed-byte 15))
(vector (signed-byte 16)))
(member < <= > >= ,#'< ,#'<= ,#'> ,#'>=))
2 :replicate '(t nil))
(def-type-prop-test stable-sort.7 'stable-sort
`((or (vector (signed-byte 20))
(vector (signed-byte 24))
(vector (signed-byte 28))
(vector (signed-byte 31))
(vector (signed-byte 32)))
(member < <= > >= ,#'< ,#'<= ,#'> ,#'>=))
2 :replicate '(t nil))
(def-type-prop-test stable-sort.8 'stable-sort
`((or (vector short-float)
(vector single-float)
(vector double-float)
(vector long-float))
(member < <= > >= ,#'< ,#'<= ,#'> ,#'>=))
2 :replicate '(t nil))
(def-type-prop-test stable-sort.9 'stable-sort
`((vector (cons (integer 0 4) (eql nil)))
(member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)
(eql :key)
(member car ,#'car))
4 :replicate '(t nil nil nil)
:test #'equalp-and-eql-elements)
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Sun Feb 20 11:50:26 2005
;;;; Contains: Randomized tests of type propagation during compilation
(compile-and-load "random-type-prop.lsp")
(in-package :cl-test)
(load "random-type-prop-tests-01.lsp")
(load "random-type-prop-tests-02.lsp")
(load "random-type-prop-tests-03.lsp")
(load "random-type-prop-tests-04.lsp")
(load "random-type-prop-tests-05.lsp")
(load "random-type-prop-tests-06.lsp")
(load "random-type-prop-tests-07.lsp")
(load "random-type-prop-tests-08.lsp")
(load "random-type-prop-tests-09.lsp")
(load "random-type-prop-tests-10.lsp")
(load "random-type-prop-tests-structs.lsp")
This diff is collapsed.
This diff is collapsed.
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment