Commit ce07b060 authored by pfdietz's avatar pfdietz
Browse files

Extend random type prop tests to structure accessors; fix problem with...

Extend random type prop tests to structure accessors; fix problem with replicate argument in some of the tests
parent 3a0daa15
......@@ -42,6 +42,16 @@
(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)
......
......@@ -21,8 +21,8 @@
(def-type-prop-test consp 'consp '(t) 1)
(def-type-prop-test atom 'atom '(t) 1)
(def-type-prop-test rplaca 'rplaca '(cons t) 2 :replicate t)
(def-type-prop-test rplacd 'rplacd '(cons t) 2 :replicate t)
(def-type-prop-test rplaca 'rplaca '(cons t) 2 :replicate '(t nil))
(def-type-prop-test rplacd 'rplacd '(cons t) 2 :replicate '(t nil))
(def-type-prop-test car 'car '((cons t t)) 1)
(def-type-prop-test first 'first '((cons t t)) 1)
......@@ -104,20 +104,20 @@
(eql :key) (or null (eql not) (eql ,#'not))
(eql :test) (or (eql equal) (eql ,#'equal))) 7)
(def-type-prop-test nsubst.1 'nsubst '(t t t) 3 :replicate t)
(def-type-prop-test nsubst.2 'nsubst '(t t (cons t t)) 3 :replicate t)
(def-type-prop-test nsubst.3 'nsubst '(t t list) 3 :replicate t)
(def-type-prop-test nsubst.4 'nsubst '(t t (cons (cons t t) (cons t t))) 3 :replicate t)
(def-type-prop-test nsubst.1 'nsubst '(t t t) 3 :replicate '(nil nil t))
(def-type-prop-test nsubst.2 'nsubst '(t t (cons t t)) 3 :replicate '(nil nil t))
(def-type-prop-test nsubst.3 'nsubst '(t t list) 3 :replicate '(nil nil t))
(def-type-prop-test nsubst.4 'nsubst '(t t (cons (cons t t) (cons t t))) 3 :replicate '(nil nil t))
(def-type-prop-test nsubst.5 'nsubst `(boolean t (cons (cons t t) (cons t t))
(eql :key)
(or null (eql not) (eql ,#'not))) 5
:replicate t)
(def-type-prop-test nsubst.6 'nsubst `(t t (cons (cons t t) (cons t t)) (eql :test) (or (eql equal) (eql ,#'equal))) 5 :replicate t)
(def-type-prop-test nsubst.7 'nsubst `(t t (cons (cons t t) (cons t t)) (eql :test-not) (or (eql equal) (eql ,#'equal))) 5 :replicate t)
:replicate '(nil nil t nil nil))
(def-type-prop-test nsubst.6 'nsubst `(t t (cons (cons t t) (cons t t)) (eql :test) (or (eql equal) (eql ,#'equal))) 5 :replicate '(nil nil t nil nil))
(def-type-prop-test nsubst.7 'nsubst `(t t (cons (cons t t) (cons t t)) (eql :test-not) (or (eql equal) (eql ,#'equal))) 5 :replicate '(nil nil t nil nil))
(def-type-prop-test nsubst.8 'nsubst `(t t (cons (cons t t) (cons t t))
(eql :key) (or null (eql not) (eql ,#'not))
(eql :test) (or (eql equal) (eql ,#'equal))) 7
:replicate t)
:replicate '(nil nil t nil nil nil nil))
(def-type-prop-test subst-if.1 'subst-if `(t (or (eql not) (eql ,#'not)) list) 3)
......@@ -126,12 +126,12 @@
(cons (cons (cons t t) (cons t t)) (cons (cons t t) (cons t t)))
(eql :key) (or null (eql not) (eql ,#'not))) 5)
(def-type-prop-test nsubst-if.1 'nsubst-if `(t (or (eql not) (eql ,#'not)) list) 3 :replicate t)
(def-type-prop-test nsubst-if.2 'nsubst-if `(t (or (eql not) (eql ,#'not)) (cons (or null t) (or null t))) 3 :replicate t)
(def-type-prop-test nsubst-if.1 'nsubst-if `(t (or (eql not) (eql ,#'not)) list) 3 :replicate '(nil nil t))
(def-type-prop-test nsubst-if.2 'nsubst-if `(t (or (eql not) (eql ,#'not)) (cons (or null t) (or null t))) 3 :replicate '(nil nil t))
(def-type-prop-test nsubst-if.3 'nsubst-if `(t (eql identity)
(cons (cons (cons t t) (cons t t)) (cons (cons t t) (cons t t)))
(eql :key) (or null (eql not) (eql ,#'not))) 5
:replicate t)
:replicate '(nil nil t nil nil))
(def-type-prop-test subst-if-not.1 'subst-if-not `(t (or (eql not) (eql ,#'not)) list) 3)
(def-type-prop-test subst-if-not.2 'subst-if-not `(t (or (eql not) (eql ,#'not)) (cons (or null t) (or null t))) 3)
......@@ -139,12 +139,12 @@
(cons (cons (cons t t) (cons t t)) (cons (cons t t) (cons t t)))
(eql :key) (or null (eql not) (eql ,#'not))) 5)
(def-type-prop-test nsubst-if-not.1 'nsubst-if-not `(t (or (eql not) (eql ,#'not)) list) 3 :replicate t)
(def-type-prop-test nsubst-if-not.2 'nsubst-if-not `(t (or (eql not) (eql ,#'not)) (cons (or null t) (or null t))) 3 :replicate t)
(def-type-prop-test nsubst-if-not.1 'nsubst-if-not `(t (or (eql not) (eql ,#'not)) list) 3 :replicate '(nil nil t))
(def-type-prop-test nsubst-if-not.2 'nsubst-if-not `(t (or (eql not) (eql ,#'not)) (cons (or null t) (or null t))) 3 :replicate '(nil nil t))
(def-type-prop-test nsubst-if-not.3 'nsubst-if-not `(t (eql identity)
(cons (cons (cons t t) (cons t t)) (cons (cons t t) (cons t t)))
(eql :key) (or null (eql not) (eql ,#'not))) 5
:replicate t)
:replicate '(nil nil t nil nil))
(def-type-prop-test tree-equal.1 'tree-equal (list t #'(lambda (x) `(or t (eql ,(copy-tree x))))) 2)
(def-type-prop-test tree-equal.2 'tree-equal (list 'list #'(lambda (x) `(or list (eql ,(copy-tree t))))) 2)
......@@ -180,18 +180,18 @@
(def-type-prop-test append.4 'append '(list list list t) 4)
(def-type-prop-test nconc.1 'nconc '(list) 1)
(def-type-prop-test nconc.2 'nconc '(list list) 2 :replicate t)
(def-type-prop-test nconc.3 'nconc '(list list list) 3 :replicate t)
(def-type-prop-test nconc.4 'nconc '(list list list list) 4 :replicate t)
(def-type-prop-test nconc.2 'nconc '(list list) 2 :replicate '(t nil))
(def-type-prop-test nconc.3 'nconc '(list list list) 3 :replicate '(t t nil))
(def-type-prop-test nconc.4 'nconc '(list list list list) 4 :replicate '(t t t nil))
(def-type-prop-test revappend 'revappend '(list t) 2)
(def-type-prop-test nreconc 'nreconc '(list t) 2 :replicate t)
(def-type-prop-test nreconc 'nreconc '(list t) 2 :replicate '(t nil))
(def-type-prop-test butlast.1 'butlast '(list) 1)
(def-type-prop-test butlast.2 'butlast '(list (integer 0 20)) 2)
(def-type-prop-test nbutlast.1 'nbutlast '(list) 1 :replicate t)
(def-type-prop-test nbutlast.2 'nbutlast '(list (integer 0 20)) 2 :replicate t)
(def-type-prop-test nbutlast.1 'nbutlast '(list) 1 :replicate '(t))
(def-type-prop-test nbutlast.2 'nbutlast '(list (integer 0 20)) 2 :replicate '(t nil))
(def-type-prop-test last.1 'last '(list) 1)
(def-type-prop-test last.2 'last '(list (integer 0 15)) 2)
......@@ -399,8 +399,8 @@
4
:test #'(lambda (x y) (same-set-p x y :key #'car)))
(def-type-prop-test nintersection.1 'nintersection '(list list) 2 :test #'same-set-p :replicate t)
(def-type-prop-test nintersection.2 'nintersection '(list list (eql :key) (eql identity)) 4 :test #'same-set-p :replicate t)
(def-type-prop-test nintersection.1 'nintersection '(list list) 2 :test #'same-set-p :replicate '(t t))
(def-type-prop-test nintersection.2 'nintersection '(list list (eql :key) (eql identity)) 4 :test #'same-set-p :replicate '(t t nil nil))
(def-type-prop-test nintersection.3 'nintersection
(list #'(lambda () (make-list-type (random 10) 'null 'integer))
#'(lambda (x) (make-list-type (random 10) 'null 'integer))
......@@ -408,7 +408,7 @@
`(member 1+ ,#'1+))
4
:test #'same-set-p
:replicate t)
:replicate '(t t nil nil))
(def-type-prop-test nintersection.4 'nintersection
(list #'(lambda () (make-list-type (random 10) 'null '(cons integer null)))
#'(lambda (x) (make-list-type (random 10) 'null '(cons integer null)))
......@@ -416,7 +416,7 @@
`(member car ,#'car))
4
:test #'(lambda (x y) (same-set-p x y :key #'car))
:replicate t)
:replicate '(t t nil nil))
(def-type-prop-test nintersection.5 'nintersection
(list #'(lambda () (make-list-type (random 10) 'null '(cons integer null)))
#'(lambda (x) (make-list-type (random 10) 'null '(cons integer null)))
......@@ -424,7 +424,7 @@
`(member equal ,#'equal))
4
:test #'(lambda (x y) (same-set-p x y :key #'car))
:replicate t)
:replicate '(t t nil nil))
(def-type-prop-test adjoin.1 'adjoin '(t list) 2)
......@@ -470,22 +470,22 @@
(eql :key) (member evenp oddp ,#'evenp ,#'oddp))
4)
(def-type-prop-test nset-difference.1 'nset-difference '(list list) 2 :replicate t)
(def-type-prop-test nset-difference.1 'nset-difference '(list list) 2 :replicate '(t t))
(def-type-prop-test nset-difference.2 'nset-difference '((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))
(cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))))
2 :replicate t)
2 :replicate '(t t))
(def-type-prop-test nset-difference.3 'nset-difference `((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))
(cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))
(eql :test) (member = ,#'=))
4 :replicate t)
4 :replicate '(t t nil nil))
(def-type-prop-test nset-difference.4 'nset-difference `((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))
(cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))
(eql :test-not) (member /= ,#'/=))
4 :replicate t)
4 :replicate '(t t nil nil))
(def-type-prop-test nset-difference.5 'nset-difference `((cons (unsigned-byte 3) (cons (unsigned-byte 3) null))
(cons (unsigned-byte 3) (cons (unsigned-byte 3) null))
(eql :key) (member evenp oddp ,#'evenp ,#'oddp))
4 :replicate t)
4 :replicate '(t t nil nil))
(def-type-prop-test set-exclusive-or.1 'set-exclusive-or '(list list) 2)
......@@ -505,22 +505,22 @@
(eql :key) (member evenp oddp ,#'evenp ,#'oddp))
4)
(def-type-prop-test nset-exclusive-or.1 'nset-exclusive-or '(list list) 2 :replicate t)
(def-type-prop-test nset-exclusive-or.1 'nset-exclusive-or '(list list) 2 :replicate '(t t))
(def-type-prop-test nset-exclusive-or.2 'nset-exclusive-or '((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))
(cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))))
2 :replicate t)
2 :replicate '(t t))
(def-type-prop-test nset-exclusive-or.3 'nset-exclusive-or `((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))
(cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))
(eql :test) (member = ,#'=))
4 :replicate t)
4 :replicate '(t t nil nil))
(def-type-prop-test nset-exclusive-or.4 'nset-exclusive-or `((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))
(cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))
(eql :test-not) (member /= ,#'/=))
4 :replicate t)
4 :replicate '(t t nil nil))
(def-type-prop-test nset-exclusive-or.5 'nset-exclusive-or `((cons (unsigned-byte 3) (cons (unsigned-byte 3) null))
(cons (unsigned-byte 3) (cons (unsigned-byte 3) null))
(eql :key) (member evenp oddp ,#'evenp ,#'oddp))
4 :replicate t)
4 :replicate '(t t nil nil))
(def-type-prop-test subsetp.1 'subsetp '(list list) 2)
(def-type-prop-test subsetp.2 'subsetp '((cons integer null)
......
......@@ -22,3 +22,51 @@
(1 ((val rtpt-1)) 'rtpt-1))
(def-type-prop-test structure-ref.1 'rtpt-1-a '(rtpt-1) 1)
(def-type-prop-test copy-structure.1 'copy-structure '(rtpt-1) 1
:test #'equalp)
(defstruct rtpt-2 a)
(defstruct (rtpt-2.1 (:include rtpt-2)) c d)
(defstruct (rtpt-2.2 (:include rtpt-2)) d e)
(defmethod make-random-element-of-type ((type (eql 'rtpt-2)))
(rcase
(1 (make-rtpt-2 :a (make-random-element-of-type t)))
(1 (make-random-element-of-type 'rtpt-2.1))
(1 (make-random-element-of-type 'rtpt-2.2))))
(defmethod make-random-element-of-type ((type (eql 'rtpt-2.1)))
(make-rtpt-2.1 :a (make-random-element-of-type t)
:c (make-random-element-of-type t)
:d (make-random-element-of-type t)))
(defmethod make-random-element-of-type ((type (eql 'rtpt-2.2)))
(make-rtpt-2.2 :a (make-random-element-of-type t)
:d (make-random-element-of-type t)
:e (make-random-element-of-type t)))
(defmethod replicate ((obj rtpt-2))
(replicate-with (obj x (make-rtpt-2))
(setf (rtpt-2-a x) (replicate (rtpt-2-a obj)))))
(defmethod replicate ((obj rtpt-2.1))
(replicate-with (obj x (make-rtpt-2.1))
(setf (rtpt-2.1-a x) (replicate (rtpt-2.1-a obj)))
(setf (rtpt-2.1-c x) (replicate (rtpt-2.1-c obj)))
(setf (rtpt-2.1-d x) (replicate (rtpt-2.1-d obj)))))
(defmethod replicate ((obj rtpt-2.2))
(replicate-with (obj x (make-rtpt-2.2))
(setf (rtpt-2.2-a x) (replicate (rtpt-2.2-a obj)))
(setf (rtpt-2.2-d x) (replicate (rtpt-2.2-d obj)))
(setf (rtpt-2.2-e x) (replicate (rtpt-2.2-e obj)))))
(defmethods make-random-type-containing*
(1 ((val rtpt-2)) 'rtpt-2)
(1 ((val rtpt-2.1)) 'rtpt-2.1)
(1 ((val rtpt-2.2)) 'rtpt-2.2))
(def-type-prop-test structure-ref.2 'rtpt-2-a '(rtpt-2) 1)
......@@ -527,6 +527,13 @@ use the value in MEMBER or EQL type specifiers."))
(defgeneric replicate (obj)
(:documentation "Copies the structure of a lisp object recursively, preserving sharing."))
(defmacro replicate-with ((source-obj dest-obj copy-form) &body body)
`(or (gethash ,source-obj *replicate-table*)
(let ((,dest-obj ,copy-form))
(setf (gethash ,source-obj *replicate-table*) ,dest-obj)
,@body
,dest-obj)))
(declaim (special *replicate-table*))
(defmethod replicate :around ((obj t))
......
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