Commit 6002aae3 authored by pfdietz's avatar pfdietz

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.
parent 43682e08
......@@ -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))
......
This diff is collapsed.
;-*- 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)
......@@ -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")
......@@ -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)))
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