Commit 127895d2 authored by pfdietz's avatar pfdietz

Add SBCL misc test (misc.622).

Fix problems in random-type-prop tests on mutating operators
  -- Replicate the mutated argument
  -- Don't use that value in MEMBER or EQL types
More TODOs
Make the probabilities in the random form tester be set before
each iteration.  This may make the distribution of generated forms
more interesting.
parent 0f788f8e
......@@ -110,4 +110,8 @@ Got: 0
44. Add tests for SPECIAL declarations in MACROLET (requested by piso on #lisp)
(partially done)
45. Sweep files for missing order-of-execution tests
\ No newline at end of file
45. Sweep files for missing order-of-execution tests
46. Add tests that class objects are valid class specifiers in method definitions.
47. Test that :import-from in DEFPACKAGE can take a package object.
......@@ -11061,3 +11061,18 @@ Broken at C::WT-MAKE-CLOSURE.
(min -63 (rem 0 (min -67 0)))))))))
0)
;;; sbcl 0.9.9.8, x86 linux
;;; TYPE-ERROR: The value 17549.955 is not of type REAL.
(deftest misc.622
(funcall
(compile
nil
'(lambda (p2)
(declare (optimize (speed 3) (safety 2) (debug 3) (space 0))
(type real p2))
(+ 81535869 (the (member 17549.955 #:g35917) p2))))
17549.955)
#.(+ 81535869 17549.955))
......@@ -42,6 +42,26 @@
collect `((< ,r ,cw) ,@(cdr case)))
(t ,@(cdar (last cases)))))))
(defmacro rselect (cumulative-frequency-array &rest cases)
(let ((len (length cases))
(a (gensym "A"))
(max (gensym "MAX"))
(r (gensym "R"))
(p (gensym "P"))
(done (gensym "DONE")))
(assert (> len 0))
`(let ((,a ,cumulative-frequency-array))
(assert (eql ,len (length ,a)))
(let* ((,max (aref ,a ,(1- len)))
(,r (random ,max)))
(block ,done
,@(loop for i from 0
for c in cases
collect
`(let ((,p (aref ,a ,i)))
(when (< ,r ,p) (return-from ,done ,c))))
(error "Should not happen!"))))))
(defun make-random-integer-range (&optional var)
"Generate a list (LO HI) of integers, LO <= HI. This is used
for generating integer types."
......
This source diff could not be displayed because it is too large. You can view the blob instead.
......@@ -187,14 +187,12 @@
bit-vector-p simple-bit-vector-p)))
`(member ,@funs ,@(mapcar #'symbol-function funs)))
'(or list vector)
'(eql :test)
(let ((test-funs '(eq eql equal equalp)))
`(member ,@test-funs ,@(mapcar #'symbol-function test-funs))))
'(eql :key)
(let ((key-funs '(identity not null)))
`(member ,@key-funs ,@(mapcar #'symbol-function key-funs))))
4)
;;; Put count-if-not tests here
......@@ -270,4 +268,3 @@
(vector long-float))
(member < <= > >= ,#'< ,#'<= ,#'> ,#'>=))
2 :replicate '(t nil))
......@@ -12,11 +12,8 @@
(defvar *print-random-type-prop-input* nil)
(defparameter *random-type-prop-result* nil)
(defgeneric make-random-type-containing (val)
(:method-combination randomized)
(:documentation "Given a value, generate a random type that contains that value."))
(declaim (special *param-types* *params* *is-var?* *form*))
(declaim (special *replicate-type*))
(defparameter *default-reps* 1000)
(defparameter *default-cell* nil)
......@@ -105,7 +102,7 @@
(cell *default-cell*)
(ignore *default-ignore*)
(test #'regression-test::equalp-with-case)
(replicate nil))
(replicate nil replicate-p))
(assert (<= 1 minargs maxargs 20))
(prog1
(dotimes (i reps)
......@@ -122,6 +119,8 @@
(make-list (max 0 (- nargs (length arg-types)))
:initial-element rest-type))
0 nargs))
(replicate (if replicate-p replicate
(mapcar (constantly nil) types)))
; (vals (mapcar #'make-random-element-of-type types))
(vals (setq *params*
(or (make-random-arguments types) (go again))))
......@@ -138,7 +137,7 @@
(params (loop for x in is-var?
for p in param-names
when x collect p))
(param-types (mapcar #'make-random-type-containing vals))
(param-types (mapcar #'make-random-type-containing vals replicate))
(*param-types* param-types)
(type-decls (loop for x in is-var?
for p in param-names
......@@ -159,10 +158,11 @@
t))
(expr `(,operator ,@(loop for x in is-var?
for v in vals
for r in replicate
for p in param-names
collect (if x
(if (and arg-the (coin))
(let ((tp (make-random-type-containing v)))
(let ((tp (make-random-type-containing v r)))
`(the ,tp ,p))
p)
(if (or (consp v)
......@@ -239,19 +239,33 @@
#'(lambda (body) `(defmethod ,name ,@body))
bodies)))
(defmethods make-random-type-containing
(defgeneric make-random-type-containing* (val)
(:method-combination randomized)
(:documentation "Produce a random type containing VAL. If the special
variable *REPLICATE-TYPE* is true, and the value is mutable, then do not
use the value in MEMBER or EQL type specifiers."))
(defun make-random-type-containing (type &optional *replicate-type*)
(declare (special *replicate-type*))
(make-random-type-containing* type))
(defmethods make-random-type-containing*
(4 ((val t))
(declare (special *replicate-type*))
(rcase
(1 t)
(1 (if (consp val) 'cons 'atom))
(1 `(eql ,val))
(1 (let* ((n1 (random 4))
(1 (if *replicate-type* (make-random-type-containing* val)
`(eql ,val)))
(1
(if *replicate-type* (make-random-type-containing* val)
(let* ((n1 (random 4))
(n2 (random 4))
;; Replace these calls with (make-random-element-of-type t)
;; at some point
(l1 (loop repeat n1 collect (random-leaf)))
(l2 (loop repeat n2 collect (random-leaf))))
`(member ,@l1 ,val ,@l2)))))
`(member ,@l1 ,val ,@l2))))))
(1 ((val standard-object)) 'standard-object)
(1 ((val class)) 'class)
......@@ -349,7 +363,7 @@
(rcase (1 '*) (1 dim))))
;;; More methods
(defmethods make-random-type-containing
(defmethods make-random-type-containing*
(3 ((val bit-vector))
(let ((root (if (and (coin)
(typep val 'simple-bit-vector))
......@@ -406,13 +420,13 @@
(1 ((val cons))
(rcase
(1 'cons)
(2 `(cons ,(make-random-type-containing (car val))
,(make-random-type-containing (cdr val))))
(1 `(cons ,(make-random-type-containing (car val))
(2 `(cons ,(make-random-type-containing* (car val))
,(make-random-type-containing* (cdr val))))
(1 `(cons ,(make-random-type-containing* (car val))
,(random-from-seq #(t *))))
(1 `(cons ,(make-random-type-containing (car val))))
(1 `(cons ,(make-random-type-containing* (car val))))
(1 `(cons ,(random-from-seq #(t *))
,(make-random-type-containing (cdr val))
,(make-random-type-containing* (cdr val))
))))
(1 ((val complex))
......@@ -465,8 +479,8 @@
(1 `(vector ,element-type ,length))
(1 (make-list-type length 'null element-type))))
(defun make-random-sequence-type-containing (element)
(make-sequence-type (random 10) (make-random-type-containing element)))
(defun make-random-sequence-type-containing (element &optional *replicate-type*)
(make-sequence-type (random 10) (make-random-type-containing* element)))
(defun same-set-p (set1 set2 &rest args &key key test test-not)
(declare (ignorable key test test-not))
......
......@@ -174,9 +174,10 @@
collect (list t1 t2)
finally (terpri)))
(defun test-random-mutated-types (n size)
(defun test-random-mutated-types (n size &key (reps 1))
(loop for t1 = (make-random-type size)
for t2 = (mutate-type t1)
for t2 = (let ((x t1)) (loop repeat reps
do (setq x (mutate-type x))) x)
for i from 0 below n
;; do (print (list t1 t2))
do (setf *random-types* (list t1 t2))
......@@ -184,7 +185,7 @@
(format t "~A " i) (finish-output *standard-output*))
when (test-types t1 t2)
collect (list t1 t2)
finally (terpri)))
finally (terpri)))
(defun test-types (t1 t2)
(multiple-value-bind (sub success)
......
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