Commit 5990a06b authored by pfdietz's avatar pfdietz
Browse files

Redid the randomized tests of set-exclusive-or and nset-exclusive-or. They...

Redid the randomized tests of set-exclusive-or and nset-exclusive-or.  They were busted and missed a bug in nset-exclusive-or in cmucl and sbcl.
parent 0d03a145
......@@ -1211,6 +1211,7 @@ the condition to go uncaught if it cannot be classified."
(member e z :key key :test test)))
t))
#|
(defun do-random-set-exclusive-ors (size niters &optional (maxelem (* 2 size)))
(let ((state (make-random-state)))
(loop
......@@ -1223,6 +1224,7 @@ the condition to go uncaught if it cannot be classified."
(let ((is-good (check-set-exclusive-or x y z)))
(unless is-good (return (values x y z)))))))
nil))
|#
(defun nset-exclusive-or-with-check (x y &key (key 'no-key)
test test-not)
......@@ -1234,6 +1236,7 @@ the condition to go uncaught if it cannot be classified."
,@(when test `(:test ,test))
,@(when test-not `(:test-not ,test-not)))))
#|
(defun do-random-nset-exclusive-ors (size niters &optional (maxelem (* 2 size)))
(let ((state (make-random-state)))
(loop
......@@ -1246,6 +1249,7 @@ the condition to go uncaught if it cannot be classified."
(let ((is-good (check-set-exclusive-or x y z)))
(unless is-good (return (values x y z)))))))
nil))
|#
(defun subsetp-with-check (x y &key (key 'no-key) test test-not)
(let ((xcopy (make-scaffold-copy x))
......
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Thu Mar 6 17:45:42 2003
;;;; Contains: Auxiliary functions for cons-related tests
(in-package :cl-test)
(defun my-set-exclusive-or (set1 set2 &key key test test-not)
(assert (not (and test test-not)))
(cond
(test-not (when (symbolp test-not)
(setq test-not (symbol-function test-not)))
(setq test (complement test-not)))
((not test) (setq test #'eql)))
(when (symbolp test) (setq test (symbol-function test)))
(let* ((keys1 (if key (mapcar key set1) set1))
(keys2 (if key (mapcar key set2) set2))
(mask1 (make-array (length set1) :element-type 'bit
:initial-element 0))
(mask2 (make-array (length set2) :element-type 'bit
:initial-element 0)))
(loop for i1 from 0
for k1 in keys1
do
(loop for i2 from 0
for k2 in keys2
when (funcall test k1 k2)
do (setf (sbit mask1 i1) 1
(sbit mask2 i2) 1)))
(nconc
(loop for e in set1
for i across mask1
when (= i 0)
collect e)
(loop for e in set2
for i across mask2
when (= i 0)
collect e))))
(defun make-random-set-exclusive-or-input (n)
(let* ((set1 (loop for i from 1 to n collect (random n)))
(set2 (loop for i from 1 to n collect (random n)))
(test-args
(random-case nil nil nil
(list :test 'eql)
(list :test #'eql)
(list :test (complement #'eql))))
(test-not-args
(and (not test-args)
(random-case nil nil (list :test-not 'eql)
(list :test-not #'eql)
(list :test-not (complement #'eql)))))
(key-args
(random-case nil nil nil nil
(list :key nil)
(list :key 'identity)
(list :key 'not))))
(list* set1 set2
(reduce #'append (random-permute
(list test-args test-not-args key-args))))))
(defun random-set-exclusive-or-test (n reps &optional (fn 'set-exclusive-or))
(loop for i below reps
for args = (make-random-set-exclusive-or-input n)
for set1 = (car args)
for set2 = (cadr args)
for result1 = (sort (copy-list (apply #'my-set-exclusive-or args))
#'<)
for result2 = (sort (copy-list (apply fn
(copy-list set1)
(copy-list set2)
(cddr args)))
#'<)
unless (equal result1 result2)
return (list (list 'sort (cons fn args) '<) "actual: " result2 "should be: " result1)))
......@@ -86,9 +86,9 @@
:test 'equal)
(c))
(deftest set-exclusive-or.13
(do-random-set-exclusive-ors 100 100)
nil)
;;; (deftest set-exclusive-or.13
;;; (do-random-set-exclusive-ors 100 100)
;;; nil)
(deftest set-exclusive-or.14
(set-exclusive-or-with-check '((a . 1) (b . 2) (c . 3012))
......@@ -348,6 +348,11 @@
type-error)
;;; Randomized test
(deftest random-set-exclusive-or
(random-set-exclusive-or-test 10 100)
nil)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; nset-exclusive-or
......@@ -428,9 +433,9 @@
:test 'equal)
(c))
(deftest nset-exclusive-or.13
(do-random-nset-exclusive-ors 100 100)
nil)
;;; (deftest nset-exclusive-or.13
;;; (do-random-nset-exclusive-ors 100 100)
;;; nil)
(deftest nset-exclusive-or.14
(nset-exclusive-or-with-check '((a . 1) (b . 2) (c . 3012))
......@@ -649,6 +654,12 @@
#'<)
nil)
;;; Randomized test
(deftest random-nset-exclusive-or
(random-set-exclusive-or-test 10 1000 'nset-exclusive-or)
nil)
;;; Error tests
(deftest nset-exclusive-or.error.1
......
;;; Tests of conses
(compile-and-load "cons-aux.lsp")
(load "cons-test-01.lsp")
(load "cons-test-02.lsp")
(load "cons-test-03.lsp")
......
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