diff --git a/ansi-tests/random-type-prop.lsp b/ansi-tests/random-type-prop.lsp index adfe6f34cd9014cb447f2e4615d872379903a2fb..815341a263c2adc0f0b176495e79e321b0840e75 100644 --- a/ansi-tests/random-type-prop.lsp +++ b/ansi-tests/random-type-prop.lsp @@ -5,15 +5,16 @@ (in-package :cl-test) -(eval-when (:compile-toplevel :load-toplevel :execute) +(eval-when (:compile-toplevel :load-toplevel) + (compile-and-load "random-aux.lsp") (compile-and-load "random-int-form.lsp")) (defvar *print-random-type-prop-input* nil) (defparameter *random-type-prop-result* nil) (defgeneric make-random-type-containing (val) - (:documentation - "Given a value, generate a random type that contains that value.")) + (:method-combination randomized) + (:documentation "Given a value, generate a random type that contains that value.")) (declaim (special *param-types* *params* *is-var?* *form*)) @@ -232,95 +233,114 @@ ;; (dolist (v vals) (describe v)) vals)) -;; Default method -(defmethod make-random-type-containing ((val t)) t) - -(defmethod make-random-type-containing ((val standard-class)) - (random-from-seq #(standard-class class t))) - -(defmethod make-random-type-containing ((val structure-class)) - (random-from-seq #(structure-class class t))) - -(defmethod make-random-type-containing ((val integer)) - (rcase - (2 (let ((tp (random-from-seq '(t number real rational)))) - (if #-allegro (coin) #+allegro nil - (find-class tp) tp))) - (1 (random-from-seq '(integer signed-byte atom))) - #- allegro (1 (find-class 'integer)) - (2 `(eql ,val)) - (2 (let* ((n1 (random 4)) - (n2 (random 4)) - (l1 (loop repeat n1 collect (make-random-integer))) - (l2 (loop repeat n2 collect (make-random-integer)))) - `(member ,@l1 ,val ,@l2))) - (4 (let ((lo (abs (make-random-integer)))) - `(integer ,(- val lo)))) - (4 (let ((lo (abs (make-random-integer)))) - `(integer ,(- val lo) *))) - (4 (let ((hi (abs (make-random-integer)))) - `(integer * ,(+ val hi)))) - (8 (let ((lo (abs (make-random-integer))) - (hi (abs (make-random-integer)))) - `(integer ,(- val lo) ,(+ val hi)))) - (2 (if (>= val 0) `unsigned-byte - (make-random-type-containing val))))) - -(defmethod make-random-type-containing ((val character)) - (rcase - (1 `(eql ,val)) - (1 'character) - (1 (if (typep val 'base-char) 'base-char (make-random-type-containing val))) - (1 (if (typep val 'standard-char) 'standard-char (make-random-type-containing val))) - (1 (if (typep val 'extended-char) 'extended-char (make-random-type-containing val))) - (1 (let* ((n1 (random 4)) - (n2 (random 4)) - (l1 (loop repeat n1 collect (make-random-character))) - (l2 (loop repeat n2 collect (make-random-character)))) - `(member ,@l1 ,val ,@l2))) - (1 (random-from-seq #(t atom))))) - -(defmethod make-random-type-containing ((val symbol)) - (rcase - (1 `(eql ,val)) - (3 'symbol) - (1 (if (null val) 'null (make-random-type-containing val))) - (1 (if (member val '(t nil)) 'boolean (make-random-type-containing val))) - (1 (if (keywordp val) 'keyword (make-random-type-containing val))) - (1 (let* ((n1 (random 4)) - (n2 (random 4)) - (l1 (loop repeat n1 collect (make-random-symbol))) - (l2 (loop repeat n2 collect (make-random-symbol)))) - `(member ,@l1 ,val ,@l2))) - (1 (random-from-seq #(t atom))))) - -(defmethod make-random-type-containing ((val rational)) - (rcase - (1 `(eql ,val)) - (1 (let* ((n1 (random 4)) - (n2 (random 4)) - (l1 (loop repeat n1 collect (make-random-element-of-type 'rational))) - (l2 (loop repeat n2 collect (make-random-element-of-type 'rational)))) - `(member ,@l1 ,val ,@l2))) - (1 `(rational ,val)) - (1 `(rational * ,val)) - (1 (let ((v (make-random-element-of-type 'rational))) - (if (<= v val) - `(rational ,v ,val) - `(rational ,val ,v)))) - )) - -(defmethod make-random-type-containing ((val float)) - (let ((names (loop for tp in '(short-float single-float double-float long-float) - when (typep val tp) - collect tp))) - (rcase - (1 `(eql ,val)) - (1 `(member ,val)) - (1 (random-from-seq names)) - (1 (if (>= val 0) - `(,(random-from-seq names) ,(float 0 val) ,val) - `(,(random-from-seq names) ,val ,(float 0 val))))))) +(defmacro defmethods (name &rest bodies) + `(progn + ,@(mapcar + #'(lambda (body) `(defmethod ,name ,@body)) + bodies))) + +(defmethods make-random-type-containing + (4 ((val t)) + (rcase + (1 t) + (1 (if (consp val) 'cons 'atom)) + (1 `(eql ,val)) + (1 (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))))) + + (1 ((val standard-object)) 'standard-object) + (1 ((val class)) 'class) + (1 ((val standard-class)) 'standard-class) + (1 ((val structure-class)) 'structure-class) + (1 ((val number)) 'number) + (1 ((val real)) 'real) + (1 ((val ratio)) 'ratio) + + (1 ((val integer)) + (rcase + (1 'integer) + (1 'signed-byte) + (1 (let* ((n1 (random 4)) + (n2 (random 4)) + (l1 (loop repeat n1 collect (make-random-integer))) + (l2 (loop repeat n2 collect (make-random-integer)))) + `(member ,@l1 ,val ,@l2))) + (1 (let ((lo (abs (make-random-integer)))) + `(integer ,(- val lo)))) + (2 (let ((lo (abs (make-random-integer)))) + `(integer ,(- val lo) *))) + (2 (let ((hi (abs (make-random-integer)))) + `(integer * ,(+ val hi)))) + (4 (let ((lo (abs (make-random-integer))) + (hi (abs (make-random-integer)))) + `(integer ,(- val lo) ,(+ val hi)))) + (1 (if (>= val 0) 'unsigned-byte (throw 'fail nil))))) + + (2 ((val character)) + (rcase + (1 'character) + (1 (if (typep val 'base-char) 'base-char + #-sbcl 'extended-char + #+sbcl (throw 'fail nil) + )) + (1 (if (typep val 'standard-char) 'standard-char (throw 'fail nil))) + (1 (let* ((n1 (random 4)) + (n2 (random 4)) + (l1 (loop repeat n1 collect (make-random-character))) + (l2 (loop repeat n2 collect (make-random-character)))) + `(member ,@l1 ,val ,@l2))))) + + (1 ((val null)) 'null) + + (2 ((val symbol)) + (rcase + (1 'symbol) + (1 (typecase val (boolean 'boolean) (keyword 'keyword) (otherwise (throw 'fail nil)))) + (1 (let* ((n1 (random 4)) + (n2 (random 4)) + (l1 (loop repeat n1 collect (make-random-symbol))) + (l2 (loop repeat n2 collect (make-random-symbol)))) + `(member ,@l1 ,val ,@l2))))) + + (1 ((val rational)) + (rcase + (1 'rational) + (1 (let* ((n1 (random 4)) + (n2 (random 4)) + (l1 (loop repeat n1 collect (make-random-element-of-type 'rational))) + (l2 (loop repeat n2 collect (make-random-element-of-type 'rational)))) + `(member ,@l1 ,val ,@l2))) + (1 `(rational ,val)) + (1 `(rational * ,val)) + (1 (let ((v (make-random-element-of-type 'rational))) + (if (<= v val) + `(rational ,v ,val) + `(rational ,val ,v)))))) + + (1 ((val float)) + (rcase + (1 (let* ((n1 (random 4)) + (n2 (random 4)) + (l1 (loop repeat n1 collect (- 2 (random (float 1.0 val))))) + (l2 (loop repeat n2 collect (- 2 (random (float 1.0 val)))))) + `(member ,@l1 ,val ,@l2))) + (1 (let ((names (float-types-containing val))) + (random-from-seq names))) + (1 (let ((name (random-from-seq (float-types-containing val)))) + (if (>= val 0) + `(,name ,(coerce 0 name) ,val) + `(,name ,val ,(coerce 0 name))))))) + ) + +(defun float-types-containing (val) + (loop for n in '(short-float single-float double-float long-float float) + when (typep val n) + collect n)) (defun make-random-array-dimension-spec (array dim-index) (assert (<= 0 dim-index)) @@ -328,20 +348,19 @@ (let ((dim (array-dimension array dim-index))) (rcase (1 '*) (1 dim)))) -(defmethod make-random-type-containing ((val bit-vector)) - (rcase - (1 (let ((root (if (and (coin) - (typep val 'simple-bit-vector)) - 'simple-bit-vector - 'bit-vector))) - (rcase (1 root) - (1 `(,root)) - (3 `(,root ,(make-random-array-dimension-spec val 0)))))) - (2 (call-next-method)))) - -(defmethod make-random-type-containing ((val vector)) - (rcase - (2 (let ((root 'vector) +;;; More methods +(defmethods make-random-type-containing + (3 ((val bit-vector)) + (let ((root (if (and (coin) + (typep val 'simple-bit-vector)) + 'simple-bit-vector + 'bit-vector))) + (rcase (1 root) + (1 `(,root)) + (3 `(,root ,(make-random-array-dimension-spec val 0)))))) + + (3 ((val vector)) + (let ((root 'vector) (alt-root (if (and (coin) (simple-vector-p val)) 'simple-vector 'vector)) (etype (rcase (1 '*) (1 (array-element-type val)) @@ -353,91 +372,76 @@ (2 (if (and (simple-vector-p val) (coin)) `(simple-vector ,(make-random-array-dimension-spec val 0)) `(,root ,etype ,(make-random-array-dimension-spec val 0))))))) - (3 (call-next-method)))) -(defmethod make-random-type-containing ((val array)) - (let ((root (if (and (coin) (typep val 'simple-array)) 'simple-array 'array)) + (3 ((val array)) + (let ((root (if (and (coin) (typep val 'simple-array)) 'simple-array 'array)) (etype (rcase (1 (array-element-type val)) (1 '*))) (rank (array-rank val))) - (rcase - (1 root) - (1 `(,root)) - (1 `(,root ,etype)) - (1 `(,root ,etype ,(loop for i below rank collect (make-random-array-dimension-spec val i)))) - (1 `(,root ,etype ,(loop for i below rank collect (array-dimension val i)))) - #-ecl (1 `(,root ,etype ,rank)) - (4 (call-next-method)) - ))) - -(defmethod make-random-type-containing ((val string)) - (rcase - (1 (let ((root (cond - ((and (coin) - (typep val 'base-string)) - (cond - ((and (coin) (typep val 'simple-base-string)) - 'simple-base-string) - (t 'base-string))) - ((and (coin) - (typep val 'simple-string)) - 'simple-string) - (t 'string)))) - (rcase (1 root) - (1 `(,root)) - (3 `(,root ,(make-random-array-dimension-spec val 0)))))) - (2 (call-next-method)))) - -(defmethod make-random-type-containing ((val cons)) - (rcase - (2 'cons) - (2 'list) - (1 `(cons ,(make-random-type-containing (car val)))) - (1 `(cons ,(make-random-type-containing (car val)) - ,(random-from-seq #(t *)))) - (2 `(cons ,(random-from-seq #(t *)) - ,(make-random-type-containing (cdr val)))) - (2 `(cons ,(make-random-type-containing (car val)) - ,(make-random-type-containing (cdr val)))) - (1 t))) - -(defmethod make-random-type-containing ((val complex)) - (rcase - (1 'complex) - (1 'number) - #-gcl (1 - (let* ((t1 (type-of (realpart val))) - (t2 (type-of (imagpart val))) - (part-type - (cond - ((subtypep t1 t2) (upgraded-complex-part-type t2)) - ((subtypep t2 t1) (upgraded-complex-part-type t1)) - ((and (subtypep t1 'rational) - (subtypep t2 'rational)) - 'rational) - (t - (upgraded-complex-part-type `(or ,t1 ,t2)))))) - (if (subtypep 'real part-type) - '(complex real) - `(complex ,part-type)))) - (1 `(eql ,val)))) - -(defmethod make-random-type-containing ((val generic-function)) - (rcase - (1 'generic-function) - (1 (call-next-method)))) - -(defmethod make-random-type-containing ((val function)) - (rcase - (1 'function) - (1 (if (typep val 'compiled-function) - 'compiled-function - 'function)) - (1 t))) - -(defmethod make-random-type-containing ((val sequence)) - (rcase - (1 'sequence) - (2 (call-next-method)))) + (rcase + (1 root) + (1 `(,root)) + (1 `(,root ,etype)) + (1 `(,root ,etype ,(loop for i below rank collect (make-random-array-dimension-spec val i)))) + (1 `(,root ,etype ,(loop for i below rank collect (array-dimension val i)))) + #-ecl (1 `(,root ,etype ,rank))))) + + (3 ((val string)) + (let ((root (cond + ((and (coin) + (typep val 'base-string)) + (cond + ((and (coin) (typep val 'simple-base-string)) + 'simple-base-string) + (t 'base-string))) + ((and (coin) + (typep val 'simple-string)) + 'simple-string) + (t 'string)))) + (rcase (1 root) + (1 `(,root)) + (3 `(,root ,(make-random-array-dimension-spec val 0)))))) + + (1 ((val list)) 'list) + + (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)) + ,(random-from-seq #(t *)))) + (1 `(cons ,(make-random-type-containing (car val)))) + (1 `(cons ,(random-from-seq #(t *)) + ,(make-random-type-containing (cdr val)) + )))) + + (1 ((val complex)) + (rcase + (1 'complex) + #-gcl + (1 (let* ((t1 (type-of (realpart val))) + (t2 (type-of (imagpart val))) + (part-type + (cond + ((subtypep t1 t2) (upgraded-complex-part-type t2)) + ((subtypep t2 t1) (upgraded-complex-part-type t1)) + ((and (subtypep t1 'rational) + (subtypep t2 'rational)) + 'rational) + (t + (upgraded-complex-part-type `(or ,t1 ,t2)))))) + (if (subtypep 'real part-type) + '(complex real) + `(complex ,part-type)))))) + + (1 ((val generic-function)) 'generic-function) + (1 ((val function)) + (rcase + (1 'function) + (1 (if (typep val 'compiled-function) + 'compiled-function + 'function)))) + ) ;;; Macro for defining random type prop tests