From 6002aae3e80984a4cd17360d741ff2bef8a07888 Mon Sep 17 00:00:00 2001 From: pfdietz <pfdietz@localhost> Date: Sun, 26 Feb 2006 02:41:23 +0000 Subject: [PATCH] Redo make-random-element-of-type to use generic functions. Fix some bugs in make-random-string. Begin adding random type prop tests for structure accessors. --- ansi-tests/random-aux.lsp | 15 +- ansi-tests/random-int-form.lsp | 851 ++++++++++++------ ansi-tests/random-type-prop-tests-structs.lsp | 24 + ansi-tests/random-type-prop-tests.lsp | 2 + ansi-tests/random-type-prop.lsp | 9 +- 5 files changed, 626 insertions(+), 275 deletions(-) create mode 100644 ansi-tests/random-type-prop-tests-structs.lsp diff --git a/ansi-tests/random-aux.lsp b/ansi-tests/random-aux.lsp index 1056915a..41fe5e9e 100644 --- a/ansi-tests/random-aux.lsp +++ b/ansi-tests/random-aux.lsp @@ -201,17 +201,20 @@ (setf (char s i) (elt #(#\a #\b #\A #\B) (random 4)))) (dotimes (i size) (setf (char s i) - (or (and use-random-byte (or (code-char (random (min char-code-limit (ash 1 16)))) - (code-char (random 256)))) + (or (and (eql etype 'character) + use-random-byte + (or (code-char (random (min char-code-limit (ash 1 16)))) + (code-char (random 256)))) (elt "abcdefghijklmnopqrstuvwyxzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" (random 62)))))) (when (and (not simple) (not *random-readable*) (coin 5)) - (let* ((len (length s)) - (len2 (random (1+ len)))) - (setf s (make-array len2 + (let ((len (+ (random (1+ size)) size))) + (setq s (make-random-string len)) + (setq etype (array-element-type s)) + (setq s (make-array size :element-type etype :displaced-to s - :displaced-index-offset (random (1+ (- len len2))))))) + :displaced-index-offset (random (1+ (- len size))))))) s)) diff --git a/ansi-tests/random-int-form.lsp b/ansi-tests/random-int-form.lsp index 642b9796..5edef21b 100644 --- a/ansi-tests/random-int-form.lsp +++ b/ansi-tests/random-int-form.lsp @@ -1078,44 +1078,325 @@ (sform (1+ (random 33)))) `(byte ,sform ,pform))) -(defun make-random-element-of-type (type) - "Create a random element of a lisp type." - (cond - ((consp type) - (let ((type-op (first type))) - (ecase type-op - (or - (assert (cdr type)) - (make-random-element-of-type (random-from-seq (cdr type)))) - (and - (assert (cdr type)) - (loop for x = (make-random-element-of-type (cadr type)) - repeat 100 - when (typep x (cons 'and (cddr type))) - return x - finally (error "Cannot generate random element of ~A" type))) - (not - (assert (cdr type)) - (assert (not (cddr type))) - (make-random-element-of-type `(and t ,type))) - (integer - (let ((lo (let ((lo (cadr type))) - (cond - ((consp lo) (1+ (car lo))) - ((eq lo nil) '*) - (t lo)))) - (hi (let ((hi (caddr type))) - (cond - ((consp hi) (1- (car hi))) - ((eq hi nil) '*) - (t hi))))) +(defgeneric make-random-element-of-type (type) + (:documentation "Create a random element of a lisp type.")) + +(defgeneric make-random-element-of-compound-type (type-op type-args) + (:documentation "Create a random element of type `(,TYPE-OP ,@TYPE-ARGS)") + (:method ((type-op (eql 'or)) type-args) + (assert type-args) + (make-random-element-of-type (random-from-seq type-args))) + (:method ((type-op (eql 'and)) type-args) + (assert type-args) + (loop for x = (make-random-element-of-type (car type-args)) + repeat 100 + when (typep x (cons 'and (cdr type-args))) + return x + finally (error "Cannot generate random element of ~A" + (cons type-op type-args)))) + (:method ((type-op (eql 'not)) type-args) + (assert (eql (length type-args) 1)) + (make-random-element-of-type `(and t (not ,(car type-args))))) + (:method ((type-op (eql 'integer)) type-args) + (let ((lo (let ((lo (car type-args))) + (cond + ((consp lo) (1+ (car lo))) + ((eq lo nil) '*) + (t lo)))) + (hi (let ((hi (cadr type-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))))) + (:method ((type-op (eql 'rational)) type-args) + (let ((type (cons type-op type-args))) + (or + (let ((r (make-random-element-of-type 'rational))) + (and (typep r type) r)) + (let ((lo (car type-args)) + (hi (cadr type-args)) + lo= hi=) + (cond + ((consp lo) nil) + ((member lo '(* nil)) + (setq lo nil) + (setq lo= nil)) + (t + (assert (typep lo 'rational)) + (setq lo= t))) + (cond + ((consp hi) nil) + ((member hi '(* nil)) + (setq hi nil) + (setq hi= nil)) + (t + (assert (typep hi 'rational)) + (setq hi= t))) + (assert (or (null lo) (null hi) (<= lo hi))) + (assert (or (null lo) (null hi) (< lo hi) (and lo= hi=))) + (cond + ((null lo) + (cond + ((null hi) (make-random-rational)) + (hi= (- hi (make-random-nonnegative-rational))) + (t (- hi (make-random-positive-rational))))) + ((null hi) + (cond + (lo= (+ lo (make-random-nonnegative-rational))) + (t (+ lo (make-random-positive-rational))))) + (t + (+ lo (make-random-bounded-rational (- hi lo) lo= hi=)))))))) + + (:method ((type-op (eql 'ratio)) type-args) + (let ((r 0)) + (loop + do (setq r (make-random-element-of-compound-type 'rational type-args)) + while (integerp r)) + r)) + + (:method ((type-op (eql 'real)) type-args) + (rcase + (1 (let ((lo (and (numberp (car type-args)) + (rational (car type-args)))) + (hi (and (numberp (cadr type-args)) + (rational (cadr type-args))))) + (make-random-element-of-compound-type 'rational + `(,(or lo '*) + ,(or hi '*))))) + (1 (make-random-element-of-compound-type 'float + `(,(or (car type-args) '*) + ,(or (cadr type-args) '*)))))) + + (:method ((type-op (eql 'float)) type-args) + (let* ((new-type-op (random-from-seq #(single-float double-float long-float short-float))) + (lo (car type-args)) + (hi (cadr type-args)) + (most-neg (most-negative-float new-type-op)) + (most-pos (most-positive-float new-type-op))) + (cond + ((or (and (realp lo) (< lo most-neg)) + (and (realp hi) (> hi most-pos))) + ;; try again + (make-random-element-of-compound-type type-op type-args)) + (t + (when (and (realp lo) (not (typep lo new-type-op))) + (cond + ((< lo most-neg) (setq lo '*)) + (t (setq lo (coerce lo new-type-op))))) + (when (and (realp hi) (not (typep hi new-type-op))) + (cond + ((> hi most-pos) (setq hi '*)) + (t (setq hi (coerce hi new-type-op))))) + (make-random-element-of-compound-type new-type-op `(,(or lo '*) ,(or hi '*))))))) + + (:method ((type-op (eql 'short-float)) type-args) + (assert (<= (length type-args) 2)) + (apply #'make-random-element-of-float-type type-op type-args)) + (:method ((type-op (eql 'single-float)) type-args) + (assert (<= (length type-args) 2)) + (apply #'make-random-element-of-float-type type-op type-args)) + (:method ((type-op (eql 'double-float)) type-args) + (assert (<= (length type-args) 2)) + (apply #'make-random-element-of-float-type type-op type-args)) + (:method ((type-op (eql 'long-float)) type-args) + (assert (<= (length type-args) 2)) + (apply #'make-random-element-of-float-type type-op type-args)) + + (:method ((type-op (eql 'mod)) type-args) + (let ((modulus (second type-args))) + (assert (integerp modulus)) + (assert (plusp modulus)) + (make-random-element-of-compound-type 'integer `(0 (,modulus))))) + + (:method ((type-op (eql 'unsigned-byte)) type-args) + (assert (<= (length type-args) 1)) + (if (null type-args) + (make-random-element-of-type '(integer 0 *)) + (let ((bits (first type-args))) + (if (eq bits '*) + (make-random-element-of-type '(integer 0 *)) + (progn + (assert (and (integerp bits) (>= bits 1))) + (make-random-element-of-type + `(integer 0 ,(1- (ash 1 bits))))))))) + + (:method ((type-op (eql 'signed-byte)) type-args) + (assert (<= (length type-args) 1)) + (if (null type-args) + (make-random-element-of-type 'integer) + (let ((bits (car type-args))) + (if (eq bits'*) + (make-random-element-of-type 'integer) + (progn + (assert (and (integerp bits) (>= bits 1))) + (make-random-element-of-type + `(integer ,(- (ash 1 (1- bits))) ,(1- (ash 1 (1- bits)))))))))) + + (:method ((type-op (eql 'eql)) type-args) + (assert (= (length type-args) 1)) + (car type-args)) + + (:method ((type-op (eql 'member)) type-args) + (assert type-args) + (random-from-seq type-args)) + + (:method ((type-op (eql 'vector)) type-args) + (assert (<= (length type-args) 2)) + (let ((etype-spec (if type-args (car type-args) '*)) + (size-spec (if (cdr type-args) (cadr type-args) '*))) + (make-random-vector etype-spec size-spec))) + + (:method ((type-op (eql 'aimple-vector)) type-args) + (assert (<= (length type-args) 1)) + (let ((size-spec (if type-args (car type-args) '*))) + (make-random-vector t size-spec :simple t))) + + (:method ((type-op (eql 'array)) type-args) + (assert (<= (length type-args) 2)) + (let ((etype-spec (if type-args (car type-args) '*)) + (size-spec (if (cdr type-args) (cadr type-args) '*))) + (make-random-array etype-spec size-spec))) + + (:method ((type-op (eql 'simple-array)) type-args) + (assert (<= (length type-args) 2)) + (let ((etype-spec (if type-args (car type-args) '*)) + (size-spec (if (cdr type-args) (cadr type-args) '*))) + (make-random-array etype-spec size-spec :simple t))) + + (:method ((type-op (eql 'string)) type-args) + (assert (<= (length type-args) 1)) + (let ((size-spec (if type-args (car type-args) '*))) + (make-random-string size-spec))) + + (:method ((type-op (eql 'simple-string)) type-args) + (assert (<= (length type-args) 1)) + (let ((size-spec (if type-args (car type-args) '*))) + (make-random-string size-spec :simple t))) + + (:method ((type-op (eql 'base-string)) type-args) + (assert (<= (length type-args) 1)) + (let ((size-spec (if type-args (car type-args) '*))) + (make-random-vector 'base-char size-spec))) + + (:method ((type-op (eql 'simple-base-string)) type-args) + (assert (<= (length type-args) 1)) + (let ((size-spec (if type-args (car type-args) '*))) + (make-random-vector 'base-char size-spec :simple t))) + + (:method ((type-op (eql 'bit-vector)) type-args) + (assert (<= (length type-args) 1)) + (let ((size-spec (if type-args (car type-args) '*))) + (make-random-vector 'bit size-spec))) + + (:method ((type-op (eql 'simple-bit-vector)) type-args) + (assert (<= (length type-args) 1)) + (let ((size-spec (if type-args (car type-args) '*))) + (make-random-vector 'bit size-spec :simple t))) + + (:method ((type-op (eql 'cons)) type-args) + (assert (<= (length type-args) 2)) + (cons (make-random-element-of-type (if type-args (car type-args) t)) + (make-random-element-of-type (if (cdr type-args) (cadr type-args) t)))) + + (:method ((type-op (eql 'complex)) type-args) + (cond + ((null type-args) + (make-random-element-of-type 'complex)) + (t + (assert (null (cdr type-args))) + (let ((etype (car type-args))) + (loop for v1 = (make-random-element-of-type etype) + for v2 = (make-random-element-of-type etype) + for c = (complex v1 v2) + when (typep c (cons 'complex type-args)) + return c))))) + ) + +(defmethod make-random-element-of-type ((type cons)) + (make-random-element-of-compound-type (car type) (cdr type))) + +(defun make-random-element-of-float-type (type-op &optional lo hi) + (let (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-type ((type cons)) + (let ((type-op (first type))) + (ecase type-op + (or + (assert (cdr type)) + (make-random-element-of-type (random-from-seq (cdr type)))) + (and + (assert (cdr type)) + (loop for x = (make-random-element-of-type (cadr type)) + repeat 100 + when (typep x (cons 'and (cddr type))) + return x + finally (error "Cannot generate random element of ~A" type))) + (not + (assert (cdr type)) + (assert (not (cddr type))) + (make-random-element-of-type `(and t ,type))) + (integer + (let ((lo (let ((lo (cadr type))) + (cond + ((consp lo) (1+ (car lo))) + ((eq lo nil) '*) + (t lo)))) + (hi (let ((hi (caddr type))) + (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) @@ -1123,247 +1404,281 @@ ;; of certain integers (near 0, near endpoints, near ;; powers of 2...) (random-from-interval (1+ hi) lo))))) - - (rational - (or - (let ((r (make-random-element-of-type 'rational))) - (and (typep r type) r)) - (let ((lo (cadr type)) - (hi (caddr type)) - lo= hi=) - (cond - ((consp lo) nil) - ((member lo '(* nil)) - (setq lo nil) - (setq lo= nil)) - (t - (assert (typep lo 'rational)) - (setq lo= t))) - (cond - ((consp hi) nil) - ((member hi '(* nil)) - (setq hi nil) - (setq hi= nil)) - (t - (assert (typep hi 'rational)) - (setq hi= t))) - (assert (or (null lo) (null hi) (<= lo hi))) - (assert (or (null lo) (null hi) (< lo hi) (and lo= hi=))) - (cond - ((null lo) - (cond - ((null hi) (make-random-rational)) - (hi= (- hi (make-random-nonnegative-rational))) - (t (- hi (make-random-positive-rational))))) - ((null hi) - (cond - (lo= (+ lo (make-random-nonnegative-rational))) - (t (+ lo (make-random-positive-rational))))) - (t - (+ lo (make-random-bounded-rational (- hi lo) lo= hi=))))))) - - (ratio - (let ((r 0)) - (loop - do (setq r (make-random-element-of-type `(rational ,@(cdr type)))) - while (integerp r)) - r)) - - (real - (rcase - (1 (let ((lo (and (numberp (cadr type)) - (rational (cadr type)))) - (hi (and (numberp (caddr type)) - (rational (caddr type))))) - (make-random-element-of-type `(rational ,(or lo '*) - ,(or hi '*))))) - (1 (make-random-element-of-type `(float ,(or (cadr type) '*) - ,(or (caddr type) '*)))))) - - ((float) - (let* ((new-type-op (random-from-seq #(single-float double-float - long-float short-float))) - (lo (cadr type)) - (hi (caddr type)) - (most-neg (most-negative-float new-type-op)) - (most-pos (most-positive-float new-type-op))) + + (rational + (or + (let ((r (make-random-element-of-type 'rational))) + (and (typep r type) r)) + (let ((lo (cadr type)) + (hi (caddr type)) + lo= hi=) + (cond + ((consp lo) nil) + ((member lo '(* nil)) + (setq lo nil) + (setq lo= nil)) + (t + (assert (typep lo 'rational)) + (setq lo= t))) + (cond + ((consp hi) nil) + ((member hi '(* nil)) + (setq hi nil) + (setq hi= nil)) + (t + (assert (typep hi 'rational)) + (setq hi= t))) + (assert (or (null lo) (null hi) (<= lo hi))) + (assert (or (null lo) (null hi) (< lo hi) (and lo= hi=))) + (cond + ((null lo) + (cond + ((null hi) (make-random-rational)) + (hi= (- hi (make-random-nonnegative-rational))) + (t (- hi (make-random-positive-rational))))) + ((null hi) + (cond + (lo= (+ lo (make-random-nonnegative-rational))) + (t (+ lo (make-random-positive-rational))))) + (t + (+ lo (make-random-bounded-rational (- hi lo) lo= hi=))))))) + + (ratio + (let ((r 0)) + (loop + do (setq r (make-random-element-of-type `(rational ,@(cdr type)))) + while (integerp r)) + r)) + + (real + (rcase + (1 (let ((lo (and (numberp (cadr type)) + (rational (cadr type)))) + (hi (and (numberp (caddr type)) + (rational (caddr type))))) + (make-random-element-of-type `(rational ,(or lo '*) + ,(or hi '*))))) + (1 (make-random-element-of-type `(float ,(or (cadr type) '*) + ,(or (caddr type) '*)))))) + + ((float) + (let* ((new-type-op (random-from-seq #(single-float double-float + long-float short-float))) + (lo (cadr type)) + (hi (caddr type)) + (most-neg (most-negative-float new-type-op)) + (most-pos (most-positive-float new-type-op))) + (cond + ((or (and (realp lo) (< lo most-neg)) + (and (realp hi) (> hi most-pos))) + ;; try again + (make-random-element-of-type type)) + (t + (when (and (realp lo) (not (typep lo new-type-op))) + (cond + ((< lo most-neg) (setq lo '*)) + (t (setq lo (coerce lo new-type-op))))) + (when (and (realp hi) (not (typep hi new-type-op))) + (cond + ((> hi most-pos) (setq hi '*)) + (t (setq hi (coerce hi new-type-op))))) + (make-random-element-of-type + `(,new-type-op ,(or lo '*) ,(or hi '*))))))) + + ((single-float double-float long-float short-float) + (let ((lo (cadr type)) + (hi (caddr type)) + 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 (and (realp lo) (< lo most-neg)) - (and (realp hi) (> hi most-pos))) - ;; try again - (make-random-element-of-type type)) + ((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 - (when (and (realp lo) (not (typep lo new-type-op))) - (cond - ((< lo most-neg) (setq lo '*)) - (t (setq lo (coerce lo new-type-op))))) - (when (and (realp hi) (not (typep hi new-type-op))) - (cond - ((> hi most-pos) (setq hi '*)) - (t (setq hi (coerce hi new-type-op))))) - (make-random-element-of-type - `(,new-type-op ,(or lo '*) ,(or hi '*))))))) - - ((single-float double-float long-float short-float) - (let ((lo (cadr type)) - (hi (caddr type)) - 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))))))))))) - - (mod - (let ((modulus (second type))) - (assert (and (integerp modulus) - (plusp modulus))) - (make-random-element-of-type `(integer 0 (,modulus))))) - (unsigned-byte - (if (null (cdr type)) + (rcase + (1 (random (min hi (float limit hi)))) + (1 (- (random (min (float limit lo) (- lo))))))))))) + + (mod + (let ((modulus (second type))) + (assert (and (integerp modulus) + (plusp modulus))) + (make-random-element-of-type `(integer 0 (,modulus))))) + (unsigned-byte + (if (null (cdr type)) (make-random-element-of-type '(integer 0 *)) - (let ((bits (second type))) - (if (eq bits'*) - (make-random-element-of-type '(integer 0 *)) - (progn - (assert (and (integerp bits) (>= bits 1))) - (make-random-element-of-type - `(integer 0 ,(1- (ash 1 bits))))))))) - (signed-byte - (if (null (cdr type)) + (let ((bits (second type))) + (if (eq bits'*) + (make-random-element-of-type '(integer 0 *)) + (progn + (assert (and (integerp bits) (>= bits 1))) + (make-random-element-of-type + `(integer 0 ,(1- (ash 1 bits))))))))) + (signed-byte + (if (null (cdr type)) (make-random-element-of-type 'integer) - (let ((bits (second type))) - (if (eq bits'*) - (make-random-element-of-type 'integer) - (progn - (assert (and (integerp bits) (>= bits 1))) - (make-random-element-of-type - `(integer ,(- (ash 1 (1- bits))) ,(1- (ash 1 (1- bits)))))))))) - (eql - (assert (= (length type) 2)) - (cadr type)) - (member - (assert (cdr type)) - (random-from-seq (cdr type))) - ((vector) - (let ((etype-spec (if (cdr type) (cadr type) '*)) - (size-spec (if (cddr type) (caddr type) '*))) - (make-random-vector etype-spec size-spec))) - ((simple-vector) - (let ((size-spec (if (cdr type) (cadr type) '*))) - (make-random-vector t size-spec :simple t))) - ((array simple-array) - (let ((etype-spec (if (cdr type) (cadr type) '*)) - (size-spec (if (cddr type) (caddr type) '*))) - (make-random-array etype-spec size-spec :simple (eql (car type) 'simple-array)))) - ((string simple-string) - (let ((size-spec (if (cdr type) (cadr type) '*))) - (make-random-string size-spec :simple (eql (car type) 'simple-string)))) - ((base-string simple-base-string) - (let ((size-spec (if (cdr type) (cadr type) '*))) - (make-random-vector 'base-char size-spec :simple (eql (car type) 'simple-base-string)))) - ((bit-vector simple-bit-vector) - (let ((size-spec (if (cdr type) (cadr type) '*))) - (make-random-vector 'bit size-spec :simple (eql (car type) 'simple-bit-vector)))) - ((cons) - (cons (make-random-element-of-type (if (cdr type) (cadr type) t)) - (make-random-element-of-type (if (cddr type) (caddr type) t)))) - ((complex) - (cond - ((null (cdr type)) - (make-random-element-of-type 'complex)) - (t - (assert (null (cddr type))) - (let ((etype (cadr type))) - (loop for v1 = (make-random-element-of-type etype) - for v2 = (make-random-element-of-type etype) - for c = (complex v1 v2) - when (typep c type) - return c))))) - ))) - ((typep type 'class) - (make-random-element-of-type (class-name type))) - (t - (ecase type - (bit (random 2)) - (boolean (random-from-seq #(nil t))) - (symbol (random-from-seq #(nil t a b c :a :b :c |z| foo |foo| car))) - (keyword (random-from-seq #(:a :b :c :d :e :f :g :h :i :j))) - (unsigned-byte (random-from-interval - (1+ (ash 1 (random *maximum-random-int-bits*))) 0)) - (signed-byte (random-from-interval - (1+ (ash 1 (random *maximum-random-int-bits*))) - (- (ash 1 (random *maximum-random-int-bits*))))) - (rational (locally (declare (notinline make-random-rational)) (make-random-rational))) - (ratio (let ((r 0)) - (loop do (setq r (make-random-element-of-type 'rational)) - while (integerp r)) - r)) - (integer (let ((x (ash 1 (random *maximum-random-int-bits*)))) - (random-from-interval (1+ x) (- x)))) - ((single-float short-float double-float long-float) - (make-random-element-of-type (list type))) - ((float) - (make-random-element-of-type (random-from-seq #(short-float single-float double-float long-float)))) - ((real) (make-random-element-of-type (random-from-seq #(integer rational float)))) - ((number) (make-random-element-of-type (random-from-seq #(integer rational float #-ecl complex)))) - ((bit-vector) (make-random-vector 'bit '*)) - ((simple-bit-vector) (make-random-vector 'bit '* :simple t)) - ((vector) (make-random-vector '* '*)) - ((simple-vector) (make-random-vector 't '* :simple t)) - ((array) (make-random-array '* '*)) - ((simple-array) (make-random-array '* '* :simple t)) - ((string) (make-random-string '*)) - ((simple-string) (make-random-string '* :simple t)) - ((simple-array) (make-random-string '* :simple t)) - ((base-string) (make-random-vector 'base-char '*)) - ((simple-base-string) (make-random-vector 'base-char '* :simple t)) - ((base-char standard-char) - (random-from-seq +standard-chars+)) - ((character) (make-random-character)) - ((extended-char) (loop for x = (make-random-character) when (typep x 'extended-char) return x)) - ;; Default - ((atom t *) (make-random-element-of-type - (random-from-seq #(real symbol boolean integer unsigned-byte - #-ecl complex character - (string 1) (bit-vector 1))))) - ((null) nil) - ((fixnum) - (random-from-interval (1+ most-positive-fixnum) most-negative-fixnum)) - ((complex) - (make-random-element-of-type '(complex real))) + (let ((bits (second type))) + (if (eq bits'*) + (make-random-element-of-type 'integer) + (progn + (assert (and (integerp bits) (>= bits 1))) + (make-random-element-of-type + `(integer ,(- (ash 1 (1- bits))) ,(1- (ash 1 (1- bits)))))))))) + (eql + (assert (= (length type) 2)) + (cadr type)) + (member + (assert (cdr type)) + (random-from-seq (cdr type))) + ((vector) + (let ((etype-spec (if (cdr type) (cadr type) '*)) + (size-spec (if (cddr type) (caddr type) '*))) + (make-random-vector etype-spec size-spec))) + ((simple-vector) + (let ((size-spec (if (cdr type) (cadr type) '*))) + (make-random-vector t size-spec :simple t))) + ((array simple-array) + (let ((etype-spec (if (cdr type) (cadr type) '*)) + (size-spec (if (cddr type) (caddr type) '*))) + (make-random-array etype-spec size-spec :simple (eql (car type) 'simple-array)))) + ((string simple-string) + (let ((size-spec (if (cdr type) (cadr type) '*))) + (make-random-string size-spec :simple (eql (car type) 'simple-string)))) + ((base-string simple-base-string) + (let ((size-spec (if (cdr type) (cadr type) '*))) + (make-random-vector 'base-char size-spec :simple (eql (car type) 'simple-base-string)))) + ((bit-vector simple-bit-vector) + (let ((size-spec (if (cdr type) (cadr type) '*))) + (make-random-vector 'bit size-spec :simple (eql (car type) 'simple-bit-vector)))) ((cons) - (make-random-element-of-type '(cons t t))) - ((list) - (let ((len (min (random 10) (random 10)))) - (loop repeat len collect (make-random-element-of-type t)))) - ((sequence) - (make-random-element-of-type '(or list vector))) - )))) + (cons (make-random-element-of-type (if (cdr type) (cadr type) t)) + (make-random-element-of-type (if (cddr type) (caddr type) t)))) + ((complex) + (cond + ((null (cdr type)) + (make-random-element-of-type 'complex)) + (t + (assert (null (cddr type))) + (let ((etype (cadr type))) + (loop for v1 = (make-random-element-of-type etype) + for v2 = (make-random-element-of-type etype) + for c = (complex v1 v2) + when (typep c type) + return c))))) + ))) +|# + +(defmethod make-random-element-of-type ((type class)) + (make-random-element-of-type (class-name type))) + +(defmethod make-random-element-of-type ((type (eql 'bit))) (random 2)) +(defmethod make-random-element-of-type ((type (eql 'boolean))) + (random-from-seq #(nil t))) +(defmethod make-random-element-of-type ((type (eql 'symbol))) + (random-from-seq #(nil t a b c :a :b :c |z| foo |foo| car))) +(defmethod make-random-element-of-type ((type (eql 'keyword))) + (random-from-seq #(:a :b :c :d :e :f :g :h :i :j))) +(defmethod make-random-element-of-type ((type (eql 'unsigned-byte))) + (random-from-interval (1+ (ash 1 (random *maximum-random-int-bits*))) 0)) +(defmethod make-random-element-of-type ((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 ((type (eql 'rational))) + (make-random-rational)) +(defmethod make-random-element-of-type ((type (eql 'ratio))) + (let ((r 0)) + (loop do (setq r (make-random-element-of-type 'rational)) + while (integerp r)) + r)) +(defmethod make-random-element-of-type ((type (eql 'integer))) + (let ((x (ash 1 (random *maximum-random-int-bits*)))) + (random-from-interval (1+ x) (- x)))) +(defmethod make-random-element-of-type ((type (eql 'float))) + (make-random-element-of-type + (random-from-seq #(short-float single-float double-float long-float)))) +(defmethod make-random-element-of-type ((type (eql 'real))) + (make-random-element-of-type (random-from-seq #(integer rational float)))) +(defmethod make-random-element-of-type ((type (eql 'number))) + (make-random-element-of-type (random-from-seq #(integer rational float #-ecl complex)))) +(defmethod make-random-element-of-type ((type (eql 'bit-vector))) + (make-random-vector 'bit '*)) +(defmethod make-random-element-of-type ((type (eql 'simple-bit-vector))) + (make-random-vector 'bit '* :simple t)) +(defmethod make-random-element-of-type ((type (eql 'vector))) + (make-random-vector '* '*)) +(defmethod make-random-element-of-type ((type (eql 'simple-vector))) + (make-random-vector 't '* :simple t)) +(defmethod make-random-element-of-type ((type (eql 'array))) + (make-random-array '* '*)) +(defmethod make-random-element-of-type ((type (eql 'simple-array))) + (make-random-array '* '* :simple t)) +(defmethod make-random-element-of-type ((type (eql 'string))) + (make-random-string '*)) +(defmethod make-random-element-of-type ((type (eql 'simple-string))) + (make-random-string '* :simple t)) +(defmethod make-random-element-of-type ((type (eql 'base-string))) + (make-random-vector 'base-char '*)) +(defmethod make-random-element-of-type ((type (eql 'simple-base-string))) + (make-random-vector 'base-char '* :simple t)) +(defmethod make-random-element-of-type ((type (eql 'character))) + (make-random-character)) +(defmethod make-random-element-of-type ((type (eql 'extended-char))) + (loop for x = (make-random-character) + when (typep x 'extended-char) return x)) +(defmethod make-random-element-of-type ((type (eql 'null))) nil) +(defmethod make-random-element-of-type ((type (eql 'fixnum))) + (random-from-interval (1+ most-positive-fixnum) most-negative-fixnum)) +(defmethod make-random-element-of-type ((type (eql 'complex))) + (make-random-element-of-type '(complex real))) +(defmethod make-random-element-of-type ((type (eql 'cons))) + (make-random-element-of-type '(cons t t))) +(defmethod make-random-element-of-type ((type (eql 'list))) + ;; Should modify this to allow non-proper lists? + (let ((len (min (random 10) (random 10)))) + (loop repeat len collect (make-random-element-of-type t)))) +(defmethod make-random-element-of-type ((type (eql 'sequence))) + (make-random-element-of-type '(or list vector))) +(defmethod make-random-element-of-type ((type (eql 'function))) + (rcase + (5 (symbol-function (random-from-seq *cl-function-symbols*))) + (5 (symbol-function (random-from-seq *cl-accessor-symbols*))) + (1 #'(lambda (x) (cons x x))) + (1 (eval '#'(lambda (x) (cons x x)))))) + +(defmethod make-random-element-of-type ((type symbol)) + (case type + ((single-float short-float double-float long-float) + (make-random-element-of-type (list type))) + ((base-char standard-char) + (random-from-seq +standard-chars+)) + ;; Default + ((atom t *) (make-random-element-of-type + (random-from-seq #(real symbol boolean integer unsigned-byte + #-ecl complex character + (string 1) (bit-vector 1))))) + (t (call-next-method type)) + )) (defun make-random-character () (loop diff --git a/ansi-tests/random-type-prop-tests-structs.lsp b/ansi-tests/random-type-prop-tests-structs.lsp new file mode 100644 index 00000000..d8c3ce0f --- /dev/null +++ b/ansi-tests/random-type-prop-tests-structs.lsp @@ -0,0 +1,24 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Contains: Random type prop tests: structures + +(in-package :cl-test) + +(defstruct rtpt-1 a b) + +(defmethod make-random-element-of-type ((type (eql 'rtpt-1))) + (make-rtpt-1 :a (make-random-element-of-type t) + :b (make-random-element-of-type t))) + +(defmethod replicate ((obj rtpt-1)) + (or (gethash obj *replicate-table*) + (let ((x (make-rtpt-1))) + (setf (gethash obj *replicate-table*) x) + (setf (rtpt-1-a x) (replicate (rtpt-1-a obj))) + (setf (rtpt-1-b x) (replicate (rtpt-1-b obj))) + x))) + +(defmethods make-random-type-containing* + (1 ((val rtpt-1)) 'rtpt-1)) + +(def-type-prop-test structure-ref.1 'rtpt-1-a '(rtpt-1) 1) diff --git a/ansi-tests/random-type-prop-tests.lsp b/ansi-tests/random-type-prop-tests.lsp index a932ad16..6f86d1c7 100644 --- a/ansi-tests/random-type-prop-tests.lsp +++ b/ansi-tests/random-type-prop-tests.lsp @@ -18,3 +18,5 @@ (load "random-type-prop-tests-09.lsp") (load "random-type-prop-tests-10.lsp") +(load "random-type-prop-tests-structs.lsp") + diff --git a/ansi-tests/random-type-prop.lsp b/ansi-tests/random-type-prop.lsp index 918f0f1d..1bbee404 100644 --- a/ansi-tests/random-type-prop.lsp +++ b/ansi-tests/random-type-prop.lsp @@ -268,6 +268,7 @@ use the value in MEMBER or EQL type specifiers.")) `(member ,@l1 ,val ,@l2)))))) (1 ((val standard-object)) 'standard-object) + (1 ((val structure-object)) 'structure-object) (1 ((val class)) 'class) (1 ((val standard-class)) 'standard-class) (1 ((val structure-class)) 'structure-class) @@ -477,7 +478,9 @@ use the value in MEMBER or EQL type specifiers.")) (defun make-sequence-type (length &optional (element-type t)) (rcase (1 `(vector ,element-type ,length)) - (1 (make-list-type length 'null element-type)))) + (1 `(array ,element-type (,length))) + (1 `(simple-array ,element-type (,length))) + (2 (make-list-type length 'null element-type)))) (defun make-random-sequence-type-containing (element &optional *replicate-type*) (make-sequence-type (random 10) (make-random-type-containing* element))) @@ -647,4 +650,8 @@ use the value in MEMBER or EQL type specifiers.")) always (isomorphic-p* (row-major-aref obj1 i) (row-major-aref obj2 i))))))))))) +;;; Test that sequences have identical elements +(defun equalp-and-eql-elements (s1 s2) + (and (equalp s1 s2) + (every #'eql s1 s2))) -- GitLab